tax Credits using numbers closer to reality

taxc4.hs

#!stack
-- stack --resolver lts-15.12 script
{-# LANGUAGE MultiWayIf #-}

import Data.List (isPrefixOf)

data Person = Person { pname :: String, children :: [Person], income :: Float }

a = Person "Alice" []      8000
b = Person "Bob"   []      2000
c = Person "Carol" [a, b] 10000

taxCreditA = taxCredit_ { tcname = "Tax Credit A"
                        , rateDefault = 0.15 }

taxCreditB = "Tax Credit B" `isJustLike` taxCreditA
  `butAdding_RateTransformer` \person -> (/ 2) `onlyWhen` (person `has` 2 $ children)

taxCreditC = "Tax Credit C" `isJustLike` taxCreditB
  `butReplacing_RateTransformerWith` \person -> (+ 0.2) `onlyWhen` (person `has` 2 $ children)

taxCreditD = "Tax Credit D" `isJustLike` taxCreditC
  `butAdding_RateTransformer` \person -> if
  | "Al" `isPrefixOf` pname person -> (+ 0.1)
  | "Bo" `isPrefixOf` pname person -> (subtract 0.1)
  | otherwise                      -> noChange

main = do
  mapM_ putStrLn [ unwords [ pname p ++ ":\t", tcname tc, "=", show (round $ creditAmount p tc) ]
                 | tc <- [taxCreditA, taxCreditB, taxCreditC, taxCreditD]
                 , p  <- [a, b, c] ]

{-
    20200613-01:37:13 mengwong@venice4:~/tmp/python/taxc% stack ./taxc2.hs
    Alice:       Tax Credit A = 1200
    Bob:         Tax Credit A = 300
    Carol:       Tax Credit A = 1500
    Alice:       Tax Credit B = 1200
    Bob:         Tax Credit B = 300
    Carol:       Tax Credit B = 750
    Alice:       Tax Credit C = 1200
    Bob:         Tax Credit C = 300
    Carol:       Tax Credit C = 3500
    Alice:       Tax Credit D = 2000
    Bob:         Tax Credit D = 100
    Carol:       Tax Credit D = 3500
-}


isJustLike :: String -> TaxCredit -> TaxCredit
isJustLike newname prototype = prototype { tcname = newname }

butAdding_RateTransformer  :: TaxCredit -> RateTransformer -> TaxCredit
butAdding_RateTransformer  template newRT  = template { rateTrans = rateTrans template <> [newRT] }

butAdding_RateTransformers :: TaxCredit -> [RateTransformer] -> TaxCredit
butAdding_RateTransformers template newRTs = template { rateTrans = rateTrans template <> newRTs }

butReplacing_RateTransformerWith  :: TaxCredit -> RateTransformer -> TaxCredit
butReplacing_RateTransformerWith  template newRT  = template { rateTrans = [newRT] }

butReplacing_RateTransformersWith :: TaxCredit -> [RateTransformer] -> TaxCredit
butReplacing_RateTransformersWith template newRTs = template { rateTrans = newRTs }

onlyWhen :: (a -> a) -> Bool -> (a -> a)
onlyWhen x True  = x
onlyWhen x False = id

noChange = id

type RateTransformer = Person -> Float -> Float

data TaxCredit = TaxCredit { tcname      :: String
                           , rateDefault :: Float
                           , rateTrans   :: [RateTransformer]
                           }

creditAmount :: Person -> TaxCredit -> Float -- apply all the rate transformers, starting with the default
creditAmount p tc = income p * foldl (flip (.)) id (rateTrans tc <*> [p]) (rateDefault tc)

taxCredit_ = TaxCredit { tcname      = "default"
                       , rateDefault = 0
                       , rateTrans   = []
                       }

has :: Person -> Int -> (Person -> [Person]) -> Bool
has p n c  = length (c p) == n