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.Type.Equality ((:~:)(Refl))
  11 import Text.Show (Show(..))
  12
  13 import Language.Symantic
  14 import Language.Symantic.Lib (tyMap, tyList)
  15
  16 import Hcompta.LCC.Account
  17 import Hcompta.LCC.Posting (Posting, Date, unPostings)
  18 import Hcompta.LCC.Transaction (Transaction)
  19 import Hcompta.LCC.Sym.Account (tyAccount)
  20 import Hcompta.LCC.Sym.Date    (tyDate)
  21 import Hcompta.LCC.Sym.Posting (tyPosting)
  22 import qualified Hcompta.LCC.Transaction as LCC
  23
  24 -- * Type 'Postings'
  25 type Postings = Map Account [Posting]
  26
  27 tyPostings :: Source src => LenInj vs => Type src vs Postings
  28 tyPostings = tyMap tyAccount (tyList tyPosting)
  29
  30 -- * Class 'Sym_Transaction'
  31 type instance Sym Transaction = Sym_Transaction
  32 class Sym_Transaction term where
  33         transaction_date     :: term Transaction -> term Date
  34         transaction_postings :: term Transaction -> term Postings
  35         default transaction_date     :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Date
  36         default transaction_postings :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Postings
  37         transaction_date     = trans1 transaction_date
  38         transaction_postings = trans1 transaction_postings
  39
  40 instance Sym_Transaction Eval where
  41         transaction_date     = eval1 LCC.transaction_date
  42         transaction_postings = eval1 $ unPostings . LCC.transaction_postings
  43 instance Sym_Transaction View where
  44         transaction_date     = view1 "Transaction.date"
  45         transaction_postings = view1 "Transaction.postings"
  46 instance (Sym_Transaction r1, Sym_Transaction r2) => Sym_Transaction (Dup r1 r2) where
  47         transaction_date     = dup1 @Sym_Transaction transaction_date
  48         transaction_postings = dup1 @Sym_Transaction transaction_postings
  49 instance (Sym_Transaction term, Sym_Lambda term) => Sym_Transaction (BetaT term)
  50
  51 instance ClassInstancesFor Transaction where
  52         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  53          | Just HRefl <- proj_ConstKiTy @(K Transaction) @Transaction c
  54          = case () of
  55                  _ | Just Refl <- proj_Const @Eq q   -> Just Dict
  56                    | Just Refl <- proj_Const @Show q -> Just Dict
  57                  _ -> Nothing
  58         proveConstraintFor _c _q = Nothing
  59 instance TypeInstancesFor Transaction
  60
  61 instance Gram_Term_AtomsFor src ss g Transaction
  62 instance (Source src, SymInj ss Transaction) => ModuleFor src ss Transaction where
  63         moduleFor = ["Transaction"] `moduleWhere`
  64          [ "date"     := teTransaction_date
  65          , "postings" := teTransaction_postings
  66          ]
  67
  68 tyTransaction :: Source src => LenInj vs => Type src vs Transaction
  69 tyTransaction = tyConst @(K Transaction) @Transaction
  70
  71 teTransaction_date :: TermDef Transaction '[] (() #> (Transaction -> Date))
  72 teTransaction_date = Term noConstraint (tyTransaction ~> tyDate) $ teSym @Transaction $ lam1 transaction_date
  73
  74 teTransaction_postings :: TermDef Transaction '[] (() #> (Transaction -> Postings))
  75 teTransaction_postings = Term noConstraint (tyTransaction ~> tyPostings) $ teSym @Transaction $ lam1 transaction_postings