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 "-----------------------------------"