]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Compta.hs
Add Sym.Balance.
[comptalang.git] / lcc / Hcompta / LCC / Sym / Compta.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Compta'.
4 module Hcompta.LCC.Sym.Compta where
5
6 import Data.Eq (Eq)
7 import Data.Function (($), (.))
8 import Data.Maybe (Maybe(..))
9 import Text.Show (Show(..))
10 import qualified Prelude ()
11 import Data.Typeable (Typeable)
12 import Data.Map.Strict (Map)
13 import System.IO (IO)
14
15 import Hcompta.LCC.Balance (Balance)
16 import Hcompta.LCC.Chart (Chart(..))
17 import Hcompta.LCC.Compta (Compta)
18 import Hcompta.LCC.IO (PathFile(..), FromFile)
19 import Hcompta.LCC.Journal (Journal)
20 import Hcompta.LCC.Posting (Date)
21 import Hcompta.LCC.Read (ComptaT, Comptable)
22 import Hcompta.LCC.Transaction (Transaction)
23 import Hcompta.LCC.Sym.Chart (tyChart)
24 import Hcompta.LCC.Sym.Date (tyDate)
25 import Hcompta.LCC.Sym.FileSystem (tyPathFile)
26 import Hcompta.LCC.Sym.IO (tyFromFile, fromFile, Sym_FromFile)
27 import Hcompta.LCC.Sym.Transaction (tyTransaction)
28 import qualified Hcompta as H
29 import qualified Hcompta.LCC.Journal as LCC
30 import qualified Hcompta.LCC.Compta as LCC
31
32 import Language.Symantic
33 import Language.Symantic.Grammar
34 import Language.Symantic.Lib (a0, tyMap, tyList, tyIO)
35
36 -- * Class 'Sym_Compta'
37 type instance Sym (Compta src ss) = Sym_Compta
38 class Sym_FromFile term => Sym_Compta term where
39 compta :: Compta src ss j -> term (Compta src ss j)
40 compta_chart :: term (Compta src ss j) -> term Chart
41 default compta :: Sym_Compta (UnT term) => Trans term => Compta src ss j -> term (Compta src ss j)
42 default compta_chart :: Sym_Compta (UnT term) => Trans term => term (Compta src ss j) -> term Chart
43 compta = trans . compta
44 compta_chart = trans1 compta_chart
45
46 instance Sym_Compta Eval where
47 compta = Eval
48 compta_chart = eval1 LCC.compta_chart
49 instance Sym_Compta View where
50 compta _ = View $ \_v _p -> "Compta.compta"
51 compta_chart = view1 "Chart.compta_chart"
52 instance (Sym_Compta r1, Sym_Compta r2) => Sym_Compta (Dup r1 r2) where
53 compta j = compta j `Dup` compta j
54 compta_chart = dup1 @Sym_Compta compta_chart
55 instance (Sym_Compta term, Sym_Lambda term) => Sym_Compta (BetaT term)
56
57 instance (Typeable src, Typeable ss) => NameTyOf (Compta src ss) where
58 nameTyOf _c = ["LCC"] `Mod` "Compta"
59 instance FixityOf (Compta src ss)
60 instance Comptable src ss =>
61 ClassInstancesFor (Compta src ss) where
62 proveConstraintFor _ (TyApp _ tq@(TyConst _ _ q) (TyApp _ c j))
63 | Just HRefl <- proj_ConstKiTy @(K (Compta src ss)) @(Compta src ss) c
64 = case () of
65 _ | Just Refl <- proj_Const @Eq q
66 , Just Dict <- proveConstraint (tq `tyApp` j) -> Just Dict
67 | Just Refl <- proj_Const @Show q
68 , Just Dict <- proveConstraint (tq `tyApp` j) -> Just Dict
69 _ -> Nothing
70 proveConstraintFor _ (TyApp _ (TyApp _ tq@(TyConst _ _ q) b) (TyApp _ c a))
71 -- Sumable Balance (Compta src ss a)
72 | Just HRefl <- proj_ConstKi @_ @H.Sumable q
73 , Just HRefl <- proj_ConstKiTy @_ @Balance b
74 , Just HRefl <- proj_ConstKiTy @_ @(Compta src ss) c
75 , Just Dict <- proveConstraint (tq `tyApp` b `tyApp` a)
76 = Just Dict
77 proveConstraintFor _ (TyApp _ (TyConst _ _ q) (TyApp _ c a))
78 -- FromFile (Compta src ss a)
79 | Just HRefl <- proj_ConstKi @_ @FromFile q
80 , Just HRefl <- proj_ConstKiTy @_ @(Compta src ss) c
81 = case a of
82 -- Map Date [Transaction]
83 TyApp _ (TyApp _ m d) (TyApp _ l t)
84 | Just HRefl <- proj_ConstKiTy @_ @Map m
85 , Just HRefl <- proj_ConstKiTy @_ @Date d
86 , Just HRefl <- proj_ConstKiTy @_ @[] l
87 , Just HRefl <- proj_ConstKiTy @_ @Transaction t
88 -> Just Dict
89 _ -> Nothing
90 proveConstraintFor _c _q = Nothing
91 instance TypeInstancesFor (Compta src ss)
92
93 instance Gram_Term_AtomsFor src (Proxy (Compta src ss) ': ss) g (Compta src ss)
94 instance
95 ( Source src
96 , Typeable src
97 , Typeable ss
98 , Comptable src ss
99 , SymInj (Proxy (Compta src ss) ': ss) (Compta src ss)
100 ) => ModuleFor src (Proxy (Compta src ss) ': ss) (Compta src ss) where
101 moduleFor = ["LCC"] `moduleWhere`
102 [ "chart" := teCompta_chart
103 , "readCompta" := teCompta_readCompta
104 ]
105
106 tyCompta :: forall src ss vs a.
107 Typeable src =>
108 Typeable ss =>
109 Comptable src ss =>
110 Source src => LenInj vs => Type src vs a -> Type src vs (Compta src ss a)
111 tyCompta a = tyConstLen @(K (Compta src ss)) @(Compta src ss) (lenVars a) `tyApp` a
112
113 teCompta_chart ::
114 forall src ss ts a.
115 Typeable src =>
116 Typeable ss =>
117 Comptable src ss =>
118 Source src =>
119 Term src (Proxy (Compta src ss) ': ss) ts '[Proxy a] (() #> ((Compta src ss) a -> Chart))
120 teCompta_chart = Term noConstraint (tyCompta @src @ss a0 ~> tyChart) $ teSym @(Compta src ss) $ lam1 compta_chart
121
122 teCompta_readCompta ::
123 forall src ss ts.
124 Typeable src =>
125 Typeable ss =>
126 Comptable src ss =>
127 Source src =>
128 Term src (Proxy (Compta src ss) ': ss) ts '[] (() #> (PathFile -> IO (Compta src ss (Map Date [Transaction]))))
129 teCompta_readCompta = Term noConstraint (tyPathFile ~> tyIO (tyCompta @src @ss (tyMap tyDate (tyList tyTransaction)))) $ teSym @(Compta src ss) $ lam1 fromFile
130
131 {-
132 tyJournal :: Source src => LenInj vs => Type src vs a -> Type src vs (Journal a)
133 tyJournal a = tyConstLen @(K Journal) @Journal (lenVars a) `tyApp` a
134
135 teJournal :: Source src => SymInj ss Journal => Journal a -> Term src ss ts '[Proxy a] (() #> Journal a)
136 teJournal j = Term noConstraint (tyJournal a0) $ teSym @Journal $ journal j
137
138 teJournal_file :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> PathFile))
139 teJournal_file = Term noConstraint (tyJournal a0 ~> tyPathFile) $ teSym @Journal $ lam1 journal_file
140
141 teJournal_last_read_time :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> Date))
142 teJournal_last_read_time = Term noConstraint (tyJournal a0 ~> tyDate) $ teSym @Journal $ lam1 journal_last_read_time
143
144 teJournal_content :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> a))
145 teJournal_content = Term noConstraint (tyJournal a0 ~> a0) $ teSym @Journal $ lam1 journal_content
146 -}