]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Transaction.hs
Remove old Yesod scaffolding.
[comptalang.git] / lcc / Hcompta / LCC / Sym / Transaction.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Transaction'.
4 module Hcompta.LCC.Sym.Transaction where
5
6 import Data.Eq (Eq)
7 import Data.Function (($), (.))
8 import Data.Map.Strict (Map)
9 import Data.Maybe (Maybe(..))
10 import Data.Proxy
11 import Data.Type.Equality ((:~:)(Refl))
12 import Text.Show (Show(..))
13
14 import Hcompta.LCC.Account
15 import Hcompta.LCC.Posting (Posting, Date, unPostings)
16 import Hcompta.LCC.Transaction (Transaction)
17 import Hcompta.LCC.Sym.Account (tyAccount)
18 import Hcompta.LCC.Sym.Date (tyDate)
19 import Hcompta.LCC.Sym.Posting (tyPosting)
20 import Language.Symantic
21 import qualified Hcompta.LCC.Transaction as LCC
22 import Language.Symantic.Lib (tyMap, tyList)
23 import Language.Symantic ()
24
25 -- * Type 'Postings'
26 type Postings = Map Account [Posting]
27
28 tyPostings :: Source src => Inj_Len vs => Type src vs Postings
29 tyPostings = tyMap tyAccount (tyList tyPosting)
30
31 -- * Class 'Sym_Transaction'
32 type instance Sym (Proxy Transaction) = Sym_Transaction
33 class Sym_Transaction term where
34 transaction_date :: term Transaction -> term Date
35 transaction_postings :: term Transaction -> term Postings
36 default transaction_date :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Date
37 default transaction_postings :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Postings
38 transaction_date = trans1 transaction_date
39 transaction_postings = trans1 transaction_postings
40
41 instance Sym_Transaction Eval where
42 transaction_date = eval1 LCC.transaction_date
43 transaction_postings = eval1 $ unPostings . LCC.transaction_postings
44 instance Sym_Transaction View where
45 transaction_date = view1 "Transaction.date"
46 transaction_postings = view1 "Transaction.postings"
47 instance (Sym_Transaction r1, Sym_Transaction r2) => Sym_Transaction (Dup r1 r2) where
48 transaction_date = dup1 @Sym_Transaction transaction_date
49 transaction_postings = dup1 @Sym_Transaction transaction_postings
50 instance (Sym_Transaction term, Sym_Lambda term) => Sym_Transaction (BetaT term)
51
52 instance ClassInstancesFor Transaction where
53 proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
54 | Just HRefl <- proj_ConstKiTy @(K Transaction) @Transaction c
55 = case () of
56 _ | Just Refl <- proj_Const @Eq q -> Just Dict
57 | Just Refl <- proj_Const @Show q -> Just Dict
58 _ -> Nothing
59 proveConstraintFor _c _q = Nothing
60 instance TypeInstancesFor Transaction
61
62 instance Gram_Term_AtomsFor src ss g Transaction
63 instance (Source src, Inj_Sym ss Transaction) => ModuleFor src ss Transaction where
64 moduleFor = ["Transaction"] `moduleWhere`
65 [ "date" := teTransaction_date
66 , "postings" := teTransaction_postings
67 ]
68
69 tyTransaction :: Source src => Inj_Len vs => Type src vs Transaction
70 tyTransaction = tyConst @(K Transaction) @Transaction
71
72 teTransaction_date :: TermDef Transaction '[] (() #> (Transaction -> Date))
73 teTransaction_date = Term noConstraint (tyTransaction ~> tyDate) $ teSym @Transaction $ lam1 transaction_date
74
75 teTransaction_postings :: TermDef Transaction '[] (() #> (Transaction -> Postings))
76 teTransaction_postings = Term noConstraint (tyTransaction ~> tyPostings) $ teSym @Transaction $ lam1 transaction_postings