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.Balance (Balance)
  18 import Hcompta.LCC.Posting (Posting, Date, unPostings)
  19 import Hcompta.LCC.Sym.Account (tyAccount)
  20 import Hcompta.LCC.Sym.Date    (tyDate)
  21 import Hcompta.LCC.Sym.Posting (tyPosting)
  22 import Hcompta.LCC.Transaction (Transaction)
  23 import qualified Hcompta as H
  24 import qualified Hcompta.LCC.Transaction as LCC
  25
  26 -- * Type 'Postings'
  27 type Postings = Map Account [Posting]
  28
  29 tyPostings :: Source src => LenInj vs => Type src vs Postings
  30 tyPostings = tyMap tyAccount (tyList tyPosting)
  31
  32 -- * Class 'Sym_Transaction'
  33 type instance Sym Transaction = Sym_Transaction
  34 class Sym_Transaction term where
  35         transaction_date     :: term Transaction -> term Date
  36         transaction_postings :: term Transaction -> term Postings
  37         default transaction_date     :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Date
  38         default transaction_postings :: Sym_Transaction (UnT term) => Trans term => term Transaction -> term Postings
  39         transaction_date     = trans1 transaction_date
  40         transaction_postings = trans1 transaction_postings
  41
  42 instance Sym_Transaction Eval where
  43         transaction_date     = eval1 LCC.transaction_date
  44         transaction_postings = eval1 $ unPostings . LCC.transaction_postings
  45 instance Sym_Transaction View where
  46         transaction_date     = view1 "Transaction.date"
  47         transaction_postings = view1 "Transaction.postings"
  48 instance (Sym_Transaction r1, Sym_Transaction r2) => Sym_Transaction (Dup r1 r2) where
  49         transaction_date     = dup1 @Sym_Transaction transaction_date
  50         transaction_postings = dup1 @Sym_Transaction transaction_postings
  51 instance (Sym_Transaction term, Sym_Lambda term) => Sym_Transaction (BetaT term)
  52
  53 instance NameTyOf Transaction where
  54         nameTyOf _c = ["LCC"] `Mod` "Transaction"
  55 instance ClassInstancesFor Transaction where
  56         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  57          | Just HRefl <- proj_ConstKiTy @(K Transaction) @Transaction c
  58          = case () of
  59                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
  60                    | Just Refl <- proj_Const @Show q -> Just Dict
  61                  _ -> Nothing
  62         proveConstraintFor _ (TyApp _ (TyApp _ (TyConst _ _ q) b) a)
  63          -- Sumable Balance a
  64          | Just HRefl <- proj_ConstKi   @_ @H.Sumable q
  65          , Just HRefl <- proj_ConstKiTy @_ @Balance b
  66          = case a of
  67                  TyApp _ l t
  68                   -- [Transaction]
  69                   | Just HRefl <- proj_ConstKiTy @_ @[] l
  70                   , Just HRefl <- proj_ConstKiTy @_ @Transaction t
  71                   -> Just Dict
  72                  -- Map Date [Transaction]
  73                  TyApp _ (TyApp _ m d) (TyApp _ l t)
  74                   | Just HRefl <- proj_ConstKiTy @_ @Map m
  75                   , Just HRefl <- proj_ConstKiTy @_ @Date d
  76                   , Just HRefl <- proj_ConstKiTy @_ @[] l
  77                   , Just HRefl <- proj_ConstKiTy @_ @Transaction t
  78                   -> Just Dict
  79                  _ -> Nothing
  80         proveConstraintFor _c _q = Nothing
  81 instance TypeInstancesFor Transaction
  82
  83 instance Gram_Term_AtomsFor src ss g Transaction
  84 instance (Source src, SymInj ss Transaction) => ModuleFor src ss Transaction where
  85         moduleFor = ["LCC"] `moduleWhere`
  86          [ "date"     := teTransaction_date
  87          , "postings" := teTransaction_postings
  88          ]
  89
  90 tyTransaction :: Source src => LenInj vs => Type src vs Transaction
  91 tyTransaction = tyConst @(K Transaction) @Transaction
  92
  93 teTransaction_date :: TermDef Transaction '[] (() #> (Transaction -> Date))
  94 teTransaction_date = Term noConstraint (tyTransaction ~> tyDate) $ teSym @Transaction $ lam1 transaction_date
  95
  96 teTransaction_postings :: TermDef Transaction '[] (() #> (Transaction -> Postings))
  97 teTransaction_postings = Term noConstraint (tyTransaction ~> tyPostings) $ teSym @Transaction $ lam1 transaction_postings