Skip to content

Instantly share code, notes, and snippets.

@rebeccaskinner

rebeccaskinner/CashOutlay.hs

Created March 15, 2022 16:35
Show Gist options
  • Save rebeccaskinner/58b49fb50e5596a675804307c3ab0253 to your computer and use it in GitHub Desktop.
Save rebeccaskinner/58b49fb50e5596a675804307c3ab0253 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
CashOutlay.hs
{-# HLINT ignore "Use lambda-case" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main where
import Data.Kind
import GHC.TypeLits
import Data.Proxy
import Text.Read
import Text.Printf
newtype (description :: Symbol) :&: (chattyType :: Type) = ChattyValue chattyType
getChattyValue :: desc :&: val -> val
getChattyValue (ChattyValue val) = val
justChattyValue :: desc :&: Maybe val -> val
justChattyValue (ChattyValue (Just val)) = val
justChattyValue (ChattyValue Nothing) = error "assumed a Just value but got Nothing"
data Chattiness a = Chatty a
| NotChatty a
readChatty :: forall desc fieldType. (KnownSymbol desc, Read fieldType) => IO (desc :&: Maybe fieldType)
readChatty = do
putStrLn . symbolVal $ Proxy @desc
ChattyValue . Just <$> readLn
readChattyDefault :: forall desc fieldType. (KnownSymbol desc, Show fieldType, Read fieldType) => fieldType -> IO (desc :&: Maybe fieldType)
readChattyDefault defaultValue = do
putStrLn $ printf "%s (default: %s)" (symbolVal (Proxy @desc)) (show defaultValue)
input <- getLine
pure $
case readMaybe input of
Just result -> ChattyValue (Just result)
Nothing -> ChattyValue (Just defaultValue)
type family HKD f a where
HKD 'Chatty (desc :&: t) = desc :&: Maybe t
HKD 'NotChatty (desc :&: t) = t
type USD = Double
type AnnotatedCost = (String, USD)
data DownPayment
= DownPaymentDollars USD
| DownPaymentPercent Double
deriving (Eq)
instance Read DownPayment where
readsPrec _ s =
case s of
[] -> fail "cannot read an empty list"
'$':s' -> [(DownPaymentDollars (read s'), "")]
s'
| last s' == '%' -> [(DownPaymentPercent (read s'),"")]
| otherwise ->
fail "cannot read down payment amount. Start with '$' for dollars, or end with '%' for percent"
instance Show DownPayment where
show (DownPaymentDollars usd) = "$" <> show usd
show (DownPaymentPercent pct) = printf "%3.3f%%" pct
class CostSummarySection a where
summarySectionName :: proxy a -> String
itemizedCosts :: a -> [(String, USD)]
costTotal :: a -> USD
costTotal = sum . map snd . itemizedCosts
data ClosingCosts chatty = ClosingCosts
{ closingTitleFees :: HKD chatty ("Title Fees" :&: USD)
, closingLenderFees :: HKD chatty ("Lender Fees" :&: USD)
, closingAppraisal :: HKD chatty ("Appraisal" :&: USD)
, closingBoundarySurvey :: HKD chatty ("Boundary Survey" :&: USD)
, closingPrepaidInterest :: HKD chatty ("Prepaid Interest" :&: USD)
}
instance CostSummarySection (ClosingCosts 'NotChatty) where
summarySectionName = const "Closing Costs"
itemizedCosts ClosingCosts{..} =
[ ("closingTitleFees",closingTitleFees)
, ("closingLenderFees", closingLenderFees)
, ("closingAppraisal", closingAppraisal)
, ("closingBoundarySurvey", closingBoundarySurvey)
, ("closingPrepaidInterest", closingPrepaidInterest)
]
finalizeClosingCosts :: ClosingCosts 'Chatty -> Maybe (ClosingCosts 'NotChatty)
finalizeClosingCosts ClosingCosts{..} =
ClosingCosts
<$> getChattyValue closingTitleFees
<*> getChattyValue closingLenderFees
<*> getChattyValue closingAppraisal
<*> getChattyValue closingBoundarySurvey
<*> getChattyValue closingPrepaidInterest
readClosingCosts :: MortgageRate 'NotChatty -> PurchasePrice 'NotChatty -> IO (ClosingCosts 'Chatty)
readClosingCosts (MortgageRate rate) price =
ClosingCosts
<$> readChattyDefault defaultTitleFees
<*> readChattyDefault defaultLenderFees
<*> readChattyDefault defaultAppraisalFees
<*> readChattyDefault defaultBoundarySurveyFees
<*> readChattyDefault defaultPrepaidInterest
where
defaultTitleFees = 2000.0
defaultLenderFees = 2000.0
defaultAppraisalFees = 500
defaultBoundarySurveyFees = 500
defaultPrepaidInterest =
let
dailyInterestRate = rate / 365
loanAmount = (purchaseHomeCost price - getDownPayment price)
dailyHomeInterest = dailyInterestRate * loanAmount
numberOfDays = 31
in numberOfDays * dailyHomeInterest
getDownPayment :: PurchasePrice 'NotChatty -> Double
getDownPayment PurchasePrice{..} =
case purchaseDownPayment of
DownPaymentDollars amount -> amount
DownPaymentPercent pct -> (pct / 100) * purchaseHomeCost
data PurchasePrice chatty = PurchasePrice
{ purchaseHomeCost :: HKD chatty ("Sale Price" :&: USD)
, purchaseDownPayment :: HKD chatty ("Down Payment" :&: DownPayment)
, purchaseStructuralRepairs :: HKD chatty ("Est. Structural Repairs" :&: USD)
, purchaseCosmeticRepairs :: HKD chatty ("Est. Cosmetic Repairs" :&: USD)
, purchaseAdditionalCosts :: HKD chatty ("Est. Additional Cost" :&: [AnnotatedCost])
}
instance CostSummarySection (PurchasePrice 'NotChatty) where
summarySectionName = const "Purchase Price"
itemizedCosts price@PurchasePrice{..} =
[ ("purchaseHomeCost" , purchaseHomeCost)
, ("purchaseDownPayment", getDownPayment price)
, ("purchaseStructuralRepairs", purchaseStructuralRepairs)
, ("purchaseCosmeticRepairs", purchaseCosmeticRepairs)
] <> purchaseAdditionalCosts
costTotal price = sum (map snd $ itemizedCosts price) - purchaseHomeCost price
finalizePurchasePrice :: PurchasePrice 'Chatty -> Maybe (PurchasePrice 'NotChatty)
finalizePurchasePrice PurchasePrice{..} =
PurchasePrice
<$> getChattyValue purchaseHomeCost
<*> getChattyValue purchaseDownPayment
<*> getChattyValue purchaseStructuralRepairs
<*> getChattyValue purchaseCosmeticRepairs
<*> getChattyValue purchaseAdditionalCosts
readAnnotatedCosts :: forall desc. KnownSymbol desc => IO (desc :&: Maybe [AnnotatedCost])
readAnnotatedCosts = do
putStrLn $ symbolVal (Proxy @desc)
ChattyValue . Just <$> readCosts []
where
readCosts :: [AnnotatedCost] -> IO [AnnotatedCost]
readCosts acc = do
putStrLn "Enter cost description (enter to skip)"
desc <- getLine
case desc of
"" -> pure acc
_otherwise -> do
dollarAmount <- readLn
readCosts $ (desc, dollarAmount) : acc
readPurchasePrice :: IO (PurchasePrice 'Chatty)
readPurchasePrice =
PurchasePrice
<$> readChatty
<*> readChattyDefault (DownPaymentPercent 20)
<*> readChattyDefault 0
<*> readChattyDefault 0
<*> readAnnotatedCosts
newtype MortgageRate chatty = MortgageRate
{ mortgageInterestRate :: HKD chatty ("Interest Rate" :&: Double)
}
instance CostSummarySection (MortgageRate 'NotChatty) where
summarySectionName = const "Mortgage Rate"
costTotal = const 0
itemizedCosts (MortgageRate rate) = [("rate (percent)", rate * 100)]
finalizeMortgageRate :: MortgageRate 'Chatty -> Maybe (MortgageRate 'NotChatty)
finalizeMortgageRate (MortgageRate r) = MortgageRate <$> getChattyValue r
readMortgageRate :: IO (MortgageRate 'Chatty)
readMortgageRate = MortgageRate <$> readChattyDefault 0.045
data OtherFees chatty = OtherFees
{ otherInspectionFees :: HKD chatty ("Inspection Fees" :&: USD)
, otherLeaseBuyOutFees :: HKD chatty ("Lease Buy-Out Fees" :&: USD)
, otherApplianceFees :: HKD chatty ("Cost of Appliances" :&: USD)
, otherCleaningFees :: HKD chatty ("Cleaning Costs" :&: USD)
, otherMovingFees :: HKD chatty ("Moving Fees" :&: USD)
, otherInsuranceFees :: HKD chatty ("Annual Insurance" :&: USD)
, otherPersonalPropertyTax :: HKD chatty ("Personal Property Tax (Annual)" :&: USD)
, otherFundingEscrow :: HKD chatty ("Funding Escrow" :&: USD)
, otherAdditionalFees :: HKD chatty ("Est. Additional Fees" :&: [AnnotatedCost])
}
instance CostSummarySection (OtherFees 'NotChatty) where
summarySectionName = const "Other Fees"
itemizedCosts OtherFees{..} =
[ ("otherInspectionFees", otherInspectionFees)
, ("otherLeaseBuyOutFees", otherLeaseBuyOutFees)
, ("otherApplianceFees", otherApplianceFees)
, ("otherCleaningFees", otherCleaningFees)
, ("otherMovingFees", otherMovingFees)
, ("otherInsuranceFees", otherInsuranceFees)
, ("otherPersonalPropertyTax", otherPersonalPropertyTax)
, ("otherFundingEscrow", otherFundingEscrow)
] <> otherAdditionalFees
finalizeOtherFees :: OtherFees 'Chatty -> Maybe (OtherFees 'NotChatty)
finalizeOtherFees OtherFees{..} = OtherFees
<$> getChattyValue otherInspectionFees
<*> getChattyValue otherLeaseBuyOutFees
<*> getChattyValue otherApplianceFees
<*> getChattyValue otherCleaningFees
<*> getChattyValue otherMovingFees
<*> getChattyValue otherInsuranceFees
<*> getChattyValue otherPersonalPropertyTax
<*> getChattyValue otherFundingEscrow
<*> getChattyValue otherAdditionalFees
readOtherFees :: PurchasePrice 'NotChatty -> IO (OtherFees 'Chatty)
readOtherFees PurchasePrice{..} = do
otherInspectionFees <- readChattyDefault defaultInspectionFees
otherLeaseBuyOutFees <- readChattyDefault defaultLeaseBuyOutFees
otherApplianceFees <- readChattyDefault defaultApplianceFees
otherCleaningFees <- readChattyDefault defaultCleaningFees
otherMovingFees <- readChattyDefault defaultMovingFees
otherInsuranceFees <- readChattyDefault defaultInsuranceFees
otherPersonalPropertyTax <- readChattyDefault defaultPersonalPropertyTax
let
defaultFundingEscrow = (justChattyValue otherPersonalPropertyTax / 3) + (justChattyValue otherInsuranceFees / 3)
otherFundingEscrow <- readChattyDefault defaultFundingEscrow
otherAdditionalFees <- readAnnotatedCosts
pure OtherFees{..}
where
defaultInspectionFees = 1600
defaultLeaseBuyOutFees = 1175 * 7
defaultApplianceFees = 0
defaultCleaningFees = 500
defaultMovingFees = 2500
defaultInsuranceFees = 3500
defaultPersonalPropertyTax = (purchaseHomeCost * 0.2) * 0.0225
data MortgageCalculation chatty = MortgageCalculation
{ purchasePrice :: PurchasePrice chatty
, interestRate :: MortgageRate chatty
, closingCosts :: ClosingCosts chatty
, otherFees :: OtherFees chatty
}
instance CostSummarySection (MortgageCalculation 'NotChatty) where
summarySectionName = const "Mortgage Up-Front Cost"
itemizedCosts MortgageCalculation{..} =
[ ("purchase price", costTotal purchasePrice)
, ("interest rate", costTotal interestRate)
, ("closing costs", costTotal closingCosts)
, ("other fees", costTotal otherFees)
]
getMortgageCalculation :: IO (MortgageCalculation 'NotChatty)
getMortgageCalculation = do
putStrLn "getting purchase price"
purchasePrice <- justOrFail "invalid price" . finalizePurchasePrice =<< readPurchasePrice
putStrLn "getting interest rate"
interestRate <- justOrFail "invalid interest rate" . finalizeMortgageRate =<< readMortgageRate
putStrLn "getting closing costs"
closingCosts <- justOrFail "invalid closing costs" . finalizeClosingCosts =<< readClosingCosts interestRate purchasePrice
putStrLn "getting other fees"
otherFees <- justOrFail "invalid other fees" . finalizeOtherFees =<< readOtherFees purchasePrice
pure MortgageCalculation{..}
where
justOrFail msg Nothing = ioError $ userError msg
justOrFail _msg (Just val) = pure val
printCostSummary :: forall a. CostSummarySection a => a -> IO ()
printCostSummary a = do
putStrLn $ summarySectionName (Proxy @a)
mapM_ (\(field, val) -> putStrLn $ printf "%s: $%.2f" field val) $ itemizedCosts a
putStrLn $ printf "Total: $%.2f" (costTotal a)
main :: IO ()
main = do
mortgage@MortgageCalculation{..} <- getMortgageCalculation
printCostSummary purchasePrice
putStrLn "-----------------------------------"
printCostSummary interestRate
putStrLn "-----------------------------------"
printCostSummary closingCosts
putStrLn "-----------------------------------"
printCostSummary otherFees
putStrLn "-----------------------------------"
printCostSummary mortgage
putStrLn "-----------------------------------"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment