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