Domain Modelling with Haskell: Data Structures - from https://www.youtube.com/watch?v=pe6S5skZwNE

Database.hs

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]

Demo.hs

{-# 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

PrettyPrint.hs

{-# 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))

Project.hs

{-# 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)

Reporting.hs

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