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