Skip to content

Instantly share code, notes, and snippets.

@gustavofranke
Last active Feb 6, 2020
Embed
What would you like to do?
Domain Modelling with Haskell: Data Structures - from https://www.youtube.com/watch?v=pe6S5skZwNE
module Database where
import System.Random (getStdRandom, randomR)
import Project
getBudget :: ProjectId -> IO Budget
getBudget _ = do
income <- Money <$> getStdRandom (randomR (0, 10000))
expenditure <- Money <$> getStdRandom (randomR (0, 10000))
pure Budget { budgetIncome = income, budgetExpenditure = expenditure}
getTransactions :: ProjectId -> IO [Transaction]
getTransactions _ = do
sale <- Sale . Money <$> getStdRandom (randomR (0, 4000))
purchase <- Purchase . Money <$> getStdRandom (randomR (0, 4000))
pure [sale, purchase]
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE OverloadedStrings #-}
module Demo where
import Project
import Reporting
import PrettyPrint
someProject :: Project
someProject = ProjectGroup "Sweden" [stockholm, gothenburg, malmo]
where
stockholm = Project 1 "Stockholm"
gothenburg = Project 2 "Gothenburg"
malmo = ProjectGroup "Malmo" [city, limhamn]
city = Project 3 "Malmo City"
limhamn = Project 4 "Limhamn"
-- Prelude> :l Demo
-- [1 of 2] Compiling Project ( Project.hs, interpreted )
-- [2 of 2] Compiling Demo ( Demo.hs, interpreted )
-- Ok, modules loaded: Demo, Project.
-- *Demo> someProject
-- ProjectGroup "Sweden" [Project (ProjectId {unProjectId = 1}) "Stockholm",Project (ProjectId {unProjectId = 2}) "Gothemburg",ProjectGroup "Malmo" [Project (ProjectId {unProjectId = 3}) "Malmo City",Project (ProjectId {unProjectId = 4}) "Limhamn"]]
-- *Demo> :l Demo
-- [1 of 5] Compiling Project ( Project.hs, interpreted )
-- [2 of 5] Compiling Database ( Database.hs, interpreted )
-- [3 of 5] Compiling Reporting ( Reporting.hs, interpreted )
-- [4 of 5] Compiling PrettyPrint ( PrettyPrint.hs, interpreted )
-- [5 of 5] Compiling Demo ( Demo.hs, interpreted )
-- Ok, modules loaded: Database, Demo, PrettyPrint, Project, Reporting.
-- *Demo> someProject
-- ProjectGroup "Sweden" [Project (ProjectId {unProjectId = 1}) "Stockholm",Project (ProjectId {unProjectId = 2}) "Gothenburg",ProjectGroup "Malmo" [Project (ProjectId {unProjectId = 3}) "Malmo City",Project (ProjectId {unProjectId = 4}) "Limhamn"]]
-- *Demo> putStrLn (prettyProject someProject)
-- Sweden
-- |
-- +- Stockholm (1)
-- |
-- +- Gothenburg (2)
-- |
-- `- Malmo
-- |
-- +- Malmo City (3)
-- |
-- `- Limhamn (4)
-- *Demo> pr <- calculateProjectReport someProject
-- *Demo> putStrLn (prettyReport pr)
-- Budget: -17532.38, Net: -6708.88, Difference: +10823.50
-- *Demo> putStrLn (prettyReport pr)
-- Budget: -17532.38, Net: -6708.88, Difference: +10823.50
-- *Demo> putStrLn (prettyReport pr)
-- Budget: -17532.38, Net: -6708.88, Difference: +10823.50
-- *Demo> pr <- calculateProjectReport someProject
-- *Demo> putStrLn (prettyReport pr)
-- Budget: 4112.21, Net: 2733.90, Difference: -1378.31
-- *Demo> pr <- calculateProjectReport someProject
-- *Demo> putStrLn (prettyReport pr)
-- Budget: -8191.39, Net: -8289.97, Difference: -98.57
{-# LANGUAGE OverloadedStrings #-}
module PrettyPrint where
import qualified Data.Text as Text
import Data.Tree
import Text.Printf
import Project
import Reporting
asTree :: Project -> Tree String
asTree project =
case project of
Project (ProjectId p) name -> Node (printf "%s (%d)" name p) []
ProjectGroup name projects -> Node (Text.unpack name) (map asTree projects)
prettyProject :: Project -> String
prettyProject = drawTree . asTree
prettyReport :: Report -> String
prettyReport r =
printf
"Budget: %.2f, Net: %.2f, Difference: %+.2f"
(unMoney (budgetProfit r))
(unMoney (netProfit r))
(unMoney (difference r))
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Project where
import Data.Text (Text)
newtype Money = Money
{ unMoney :: Double
} deriving (Show, Eq, Num)
newtype ProjectId = ProjectId
{ unProjectId :: Int
} deriving (Show, Eq, Num)
data Project
= Project ProjectId Text
| ProjectGroup Text [Project]
deriving (Show, Eq)
data Budget = Budget
{ budgetIncome :: Money
, budgetExpenditure :: Money
} deriving (Show, Eq)
data Transaction
= Sale Money
| Purchase Money
deriving (Show, Eq)
module Reporting where
import Data.Monoid (getSum)
import qualified Database as DB
import Project
data Report = Report
{ budgetProfit :: Money
, netProfit :: Money
, difference :: Money
} deriving (Show, Eq)
instance Monoid Report where
mempty = Report 0 0 0
mappend (Report b1 n1 d1) (Report b2 n2 d2) =
Report (b1 + b2) (n1 + n2) (d1 +d2)
calculateReport :: Budget -> [Transaction] -> Report
calculateReport budget transactions =
Report
{ budgetProfit = budgetProfit'
, netProfit = netProfit'
, difference = netProfit' - budgetProfit'
}
where
budgetProfit' = budgetIncome budget - budgetExpenditure budget
netProfit' = getSum (foldMap asProfit transactions)
asProfit (Sale m) = pure m
asProfit (Purchase m) = pure (negate m)
calculateProjectReport :: Project -> IO Report
calculateProjectReport = calc
where
calc (Project p _) =
calculateReport <$> DB.getBudget p <*> DB.getTransactions p
calc (ProjectGroup _ projects) = foldMap calc projects
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment