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 NameTyOf Transaction where
  52         nameTyOf _c = ["LCC"] `Mod` "Transaction"
  53 instance ClassInstancesFor Transaction where
  54         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  55          | Just HRefl <- proj_ConstKiTy @(K Transaction) @Transaction c
  56          = case () of
  57                  _ | Just Refl <- proj_Const @Eq q   -> Just Dict
  58                    | Just Refl <- proj_Const @Show q -> Just Dict
  59                  _ -> Nothing
  60         proveConstraintFor _c _q = Nothing
  61 instance TypeInstancesFor Transaction
  62
  63 instance Gram_Term_AtomsFor src ss g Transaction
  64 instance (Source src, SymInj ss Transaction) => ModuleFor src ss Transaction where
  65         moduleFor = ["LCC"] `moduleWhere`
  66          [ "date"     := teTransaction_date
  67          , "postings" := teTransaction_postings
  68          ]
  69
  70 tyTransaction :: Source src => LenInj vs => Type src vs Transaction
  71 tyTransaction = tyConst @(K Transaction) @Transaction
  72
  73 teTransaction_date :: TermDef Transaction '[] (() #> (Transaction -> Date))
  74 teTransaction_date = Term noConstraint (tyTransaction ~> tyDate) $ teSym @Transaction $ lam1 transaction_date
  75
  76 teTransaction_postings :: TermDef Transaction '[] (() #> (Transaction -> Postings))
  77 teTransaction_postings = Term noConstraint (tyTransaction ~> tyPostings) $ teSym @Transaction $ lam1 transaction_postings