-
Notifications
You must be signed in to change notification settings - Fork 1
/
Card.hs
103 lines (79 loc) · 3.29 KB
/
Card.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Model.Card (
CardId (..), Card, CardItem, ProductId(..), Quantity,
Error, Command(..), Event(..),
) where
import Aggregate
import Data.Aeson
import Data.Data
import Data.List
import Data.Text (Text)
import GHC.Generics
---------------------------- model ------------------------------------
newtype CardId = CardId Text deriving (Generic, Eq, Show, Data, ToJSON, FromJSON, Read)
newtype ProductId = ProductId Text deriving (Generic, Eq, Show, Data, ToJSON, FromJSON, Read)
type Quantity = Int
data Card =
Card { cardId :: CardId, products :: [CardItem] }
deriving (Show, Data)
data CardItem =
CardItem { productId :: ProductId, quantity :: Quantity }
deriving (Generic, Show, Data)
instance AggregateId CardId where
textAggregateId (CardId cid) = cid
--------------------------- aggregate ---------------------------------
instance Aggregate Card where
type Id Card = CardId
data Command Card = AddProduct ProductId
| RemoveProduct ProductId
| ClearCard
deriving (Show, Read)
data Event Card = ProductAdded { addedProductId :: ProductId }
| ProductRemoved { removedProductId :: ProductId }
| CardCleared
deriving (Generic, Show, Data, ToJSON, FromJSON)
data Error Card = NoProductInCard ProductId
| QuantityExceedsLimit ProductId Quantity
deriving (Show)
aggregateId = cardId
s `execute` AddProduct p = ProductAdded
<$> validate (withinLimit s 2) (QuantityExceedsLimit p 2) p
s `execute` RemoveProduct p = ProductRemoved
<$> validate (existsInCard s) (NoProductInCard p) p
_ `execute` ClearCard = Right CardCleared
s `apply` ProductAdded p = addProduct s p
s `apply` ProductRemoved p = removeProduct s p
s `apply` CardCleared = s { products = [] }
new aid = Card aid []
-------------------------- validation ---------------------------------
existsInCard :: Card -> ProductId -> Bool
existsInCard c p = any (hasId p) (products c)
withinLimit :: Card -> Quantity -> ProductId -> Bool
withinLimit c num p =
not $ any (\x -> productId x == p && quantity x >= num) (products c)
---------------------------- helpers ----------------------------------
updateQuantity :: (Int -> Int) -> CardItem -> CardItem
updateQuantity f item = item { quantity = max 0 (f $ quantity item) }
addProduct :: Card -> ProductId -> Card
addProduct c p =
let newProducts = addOrUpdate (hasId p) (updateQuantity succ) (CardItem p 1) (products c)
in c { products = newProducts }
removeProduct :: Card -> ProductId -> Card
removeProduct c p =
let newProducts = updateWhere (hasId p) (updateQuantity pred) (products c)
in c { products = filter ((>0) . quantity) newProducts }
hasId :: ProductId -> CardItem -> Bool
hasId p i = productId i == p
addOrUpdate :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
addOrUpdate f update create lst =
let (ok, nok) = partition f lst
in if null ok
then create : nok
else (update <$> ok) ++ nok
updateWhere :: (a -> Bool) -> (a -> a) -> [a] -> [a]
updateWhere f upd lst =
(\x -> if f x then upd x else x) <$> lst