tax Credit in Haskell, using DSL-like syntax to read more like English

taxc3.hs

#!stack
-- stack --resolver lts-15.12 script

import Data.List (isPrefixOf)

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

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

type RateTransformer = Person -> Int -> Int

data TaxCredit = TaxCredit { tcname      :: String
                           , rateDefault :: Int
                           , rateTrans   :: [RateTransformer]
                           , rate        :: Person -> TaxCredit -> Int
                           }

taxCredit_ = TaxCredit { tcname      = "default"
                       , rateDefault = 100
                       , rateTrans   = []
                       , rate        = \person tc -> foldl (flip (.)) id (rateTrans tc <*> [person]) (rateDefault tc)
                       -- apply all the rate transformers, starting with the default
                       }

taxCreditB = taxCredit_ { tcname = "Tax Credit B" }

taxCreditA = "Tax Credit A" `isJustLike` taxCreditB `butAdding_RateTransformer` \person -> (`div` 2) `onlyWhen` (length (children person) == 2)

taxCreditC = "Tax Credit C" `isJustLike` taxCreditA `butReplacing_RateTransformerWith` \person -> (*2) `onlyWhen` ("A" `isPrefixOf` pname person)

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

{-
    Alice:       Tax Credit B = 100
    Bob:         Tax Credit B = 100
    Carol:       Tax Credit B = 100
    Alice:       Tax Credit A = 100
    Bob:         Tax Credit A = 100
    Carol:       Tax Credit A = 50
    Alice:       Tax Credit C = 200
    Bob:         Tax Credit C = 100
    Carol:       Tax Credit C = 100
-}


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