]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Compta.hs
stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Compta.hs
1 {-# LANGUAGE ExistentialQuantification #-}
2 module Hcompta.LCC.Compta where
3
4 import Control.Monad (Monad(..))
5 import Data.Bool (Bool(..))
6 import Data.Either (either)
7 import Data.Eq (Eq)
8 import Data.Function (($), (.), id)
9 import Data.Functor ((<$>))
10 import Data.Functor.Identity (Identity(..))
11 import Prelude (error)
12 import Text.Show (Show(..))
13 import qualified Control.Monad.Classes as MC
14 import qualified Control.Monad.Trans.State.Strict as SS
15 import qualified Hcompta.LCC.Lib.Strict as S
16
17 import Hcompta.LCC.Amount
18 import Hcompta.LCC.Balance
19 import Hcompta.LCC.Chart
20 import Hcompta.LCC.Journal
21 import Hcompta.LCC.IO
22 import Hcompta.LCC.Transaction
23 import Language.Symantic as Sym
24 import qualified Hcompta as H
25
26 -- * Type 'LCC'
27 data LCC src
28 = LCC
29 { lcc_chart :: !Chart
30 , lcc_journals :: !(Journals src (Transactions src))
31 , lcc_style :: !Style_Amounts
32 , lcc_base :: !CanonFile
33 } deriving (Eq, Show)
34 instance H.Get Style_Amounts (LCC src) where
35 get = lcc_style
36 instance H.Sumable Balance (LCC src) where
37 b += l = b H.+= lcc_journals l
38
39 -- ** Type 'State_Sym'
40 data State_Sym src ss
41 = State_Sym
42 { state_sym_types :: !(Sym.Imports Sym.NameTy, Sym.ModulesTy src)
43 , state_sym_terms :: !(Sym.Imports Sym.NameTe, Sym.Modules src ss)
44 } deriving (Eq, Show)
45
46 state_sym ::
47 forall src ss.
48 Sym.Source src =>
49 Sym.ImportTypes ss =>
50 Sym.ModulesInj src ss =>
51 Sym.ModulesTyInj ss =>
52 State_Sym src ss
53 state_sym =
54 let mods = either (error . show) id Sym.modulesInj in
55 State_Sym
56 { state_sym_types = (Sym.importTypes @ss [], Sym.modulesTyInj @ss)
57 , state_sym_terms = (Sym.importModules [] mods, mods)
58 }
59
60 -- State_Sym src ss
61 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (State_Sym src ss)) = 'True
62 instance Monad m => MC.MonadStateN 'MC.Zero (State_Sym src ss) (S.StateT (State_Sym src ss) m) where
63 stateN _px = S.StateT . SS.state
64
65 -- (Sym.Imports Sym.NameTe, Sym.Modules src ss)
66 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTe, Sym.Modules src ss)) = 'True
67 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTe, Sym.Modules src ss) (S.StateT (State_Sym src ss) m) where
68 stateN _px f = S.StateT $ SS.state $ \st ->
69 (\a -> st{state_sym_terms=a}) <$> f (state_sym_terms st)
70
71 -- (Sym.Imports Sym.NameTy, Sym.ModulesTy src)
72 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)) = 'True
73 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (S.StateT (State_Sym src ss) m) where
74 stateN _px f = S.StateT $ SS.state $ \st ->
75 (\a -> st{state_sym_types=a}) <$> f (state_sym_types st)
76
77 -- * Type 'Database'
78 newtype Database db a = Database (S.StateT db Identity a)
79
80 -- * Type 'Query'
81 newtype Query db a = Query { runQuery :: db -> a }
82
83 -- * Type 'Queryable'
84 class Queryable db a where
85 query :: Query db a
86 instance Queryable (LCC src) Balance where
87 query = Query $ H.sum . lcc_journals
88
89 {-
90 -- * Type 'Base'
91 data Base =
92 forall db.
93 Typeable db =>
94 Base (Type src vs db) db
95
96 -- * Type 'DataBase'
97 data DataBase = forall db. Typeable db => DataBase db
98
99 -- * Type 'Code'
100 newtype Code src ss m a
101 = Code (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) m a)
102 deriving (Functor, Applicative, Monad, Typeable)
103 -}
104
105 {-
106 -- * Class 'Balanceable'
107 class Balanceable a where
108 balance :: a -> Balance
109 instance Balanceable (LCC src) where
110 balance = H.sum . lcc_journals @src
111 -}
112
113 -- LCC src
114 type instance MC.CanDo (S.StateT (LCC src) m) (MC.EffState (LCC src)) = 'True
115 instance Monad m => MC.MonadStateN 'MC.Zero (LCC src) (S.StateT (LCC src) m) where
116 stateN _px = S.StateT . SS.state
117
118
119
120
121
122 {-
123 main :: (Compta a -> b) -> FilePath -> b
124
125 main :: (Compta a -> b) -> FilePath -> IO b
126
127 (ComptaM a -> ComptaM b) -> ComptaM a -> ComptaM b
128 (a -> b) -> (a -> b)
129
130 a -> b
131
132 balance :: Compta Journals -> Compta Balance
133 balance :: Balanceable f => Compta f Balance
134
135 fp :: Compta a
136
137 balance ./toto
138
139 ./toto :: IO (Context a)
140 balance :: Context LCC Balance
141
142 readLCC :: Context LCC ()
143 readLedger :: Context Ledger ()
144 readSQL :: Context SQL ()
145
146 write :: Context Ledger ()
147
148 init :: Context ()
149
150 journals :: Context LCC Journals
151 chart :: Context LCC Chart
152 styles :: Context LCC styles
153 stats :: Context LCC stats
154
155 do
156 load ./toto
157 bal <- balance
158
159 load ./toto >>= \() ->
160 balance >>= \bal ->
161 -}
162
163 {-
164 data Context src ss fmt a
165 = Context
166 { state_sym :: !(State_Sym src ss)
167 , context_return :: fmt a
168 }
169 instance Functor (Context src ss fmt)
170 instance Applicative (Context src ss fmt)
171 pure = context_return
172 f <*> a =
173 instance Monad (Context src ss fmt) where
174 return = context_return
175 c >>= f = f (context_return c)
176 -}
177
178 {-
179 instance Functor LCC where
180 fmap f c = c{lcc_return = f (lcc_return c)}
181 instance Applicative LCC where
182 pure a = LCC
183 { lcc_chart = mempty
184 , lcc_journals = mempty
185 , lcc_style = mempty
186 , lcc_return = a
187 }
188 f <*> a =
189 LCC
190 { lcc_chart = lcc_chart f <> lcc_chart a
191 , lcc_journals = lcc_journals f <> lcc_journals a
192 , lcc_style = lcc_style f <> lcc_style a
193 , lcc_return = lcc_return f (lcc_return a)
194 }
195 instance Monad LCC where
196 return = pure
197 c >>= f =
198 let c' = f (lcc_return c) in
199 c'
200 { lcc_chart = lcc_chart c <> lcc_chart c'
201 , lcc_journals = lcc_journals c <> lcc_journals c'
202 , lcc_style = lcc_style c <> lcc_style c'
203 }
204 -}
205
206 {-
207 instance Balanceable LCC where
208 balance f = f{lcc_data = H.sum $ lcc_compta f}
209 data LCC_IO a
210 = LCC_IO
211 { lcc_io_data :: Set FilePath
212 , lcc_calc :: IO a
213 }
214
215 class Backend a where
216 instance Backend (IO a) where
217 instance Backend () where
218 instance Backend (SQL a)
219
220 class Journalable a where
221 journal_fold :: (Transaction -> j -> j) -> a -> j
222
223
224 -- * Type 'ComptaT'
225 type ComptaS src ss = SS.State (State_Compta src ss)
226 -- type ComptaIO src ss = ComptaT src ss IO
227
228 runComptaS :: ComptaS src ss a -> State_Compta src ss -> (a, State_Compta src ss)
229 runComptaS = SS.runState
230
231 -- ** Type 'State_Compta'
232 data State_Compta src ss
233 = forall js. Journalable js
234 => State_Compta
235 { state_compta_sty :: !Style_Amounts
236 , state_compta_sym :: !(State_Sym src ss)
237 , state_compta_jnl :: !js
238 } deriving (Eq, Show)
239
240 compta ::
241 forall src ss.
242 Sym.Source src =>
243 Sym.ImportTypes ss =>
244 Sym.ModulesInj src ss =>
245 Sym.ModulesTyInj ss =>
246 State_Compta src ss
247 compta = State_Compta
248 { compta_sym = state_sym
249 , compta_data = mempty
250 }
251 -}