]> Git — Sourcephile - haskell/literate-accounting.git/blob - src/Literate/Accounting/Journal.hs
wip
[haskell/literate-accounting.git] / src / Literate / Accounting / Journal.hs
1 {-# LANGUAGE StandaloneDeriving #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# LANGUAGE NoOverloadedLists #-}
4 {-# OPTIONS_GHC -Wno-name-shadowing #-}
5
6 module Literate.Accounting.Journal where
7
8 {-
9 import Control.Applicative (Applicative (..), liftA2)
10 import Control.Monad (Monad (..))
11 import Control.Monad.Trans.Writer qualified as MT
12 import Data.Bool
13 import Data.Function (($), (.))
14 import Data.Functor (Functor (..), (<$>))
15 import Data.Monoid (Monoid (..))
16 import Data.Ord (Ord (..))
17 import Data.Semigroup (Semigroup (..))
18 import GHC.Stack (HasCallStack)
19 import Literate.Accounting.Balance
20 import Text.Show (Show (..))
21 import Prelude (undefined)
22
23 import Literate.Accounting.Unit
24
25 import Debug.Trace
26
27 -- * Type 'JournalDo'
28 -- | This 'Monad' enables the 'do' syntax for entering 'move's and 'post's,
29 -- which is less verbose than the list syntax.
30 newtype JournalDo repr a = JournalDo { unJournalDo ::
31 MT.Writer (JournalGenerator repr) a
32 } deriving newtype (Functor, Applicative, Monad)
33 instance Unitable repr => Unitable (JournalDo repr) where
34 unit u = JournalDo . MT.mapWriter (go <$>) . unJournalDo
35 where
36 go JournalGenerator{..} = JournalGenerator
37 { moves = unit u moves
38 , posts = unit u posts
39 }
40
41 runJournalDo :: HasCallStack => JournalDo repr a -> repr [TyMove]
42 runJournalDo p =
43 let (_a, out) = MT.runWriter (unJournalDo p) in
44 moves out
45
46 -- ** Type 'JournalGenerator'
47 data JournalGenerator repr = JournalGenerator
48 { moves :: repr [TyMove]
49 , posts :: repr [TyPost]
50 }
51 instance Listable repr => Semigroup (JournalGenerator repr) where
52 x <> y = JournalGenerator
53 { moves = moves x `concat` moves y
54 , posts = posts x `concat` posts y
55 }
56 instance Listable repr => Monoid (JournalGenerator repr) where
57 mempty = JournalGenerator
58 { moves = nil
59 , posts = nil
60 }
61 instance
62 ( Negable (repr [TyMove])
63 , Negable (repr [TyPost])
64 ) => Negable (JournalGenerator repr) where
65 negate JournalGenerator{..} = JournalGenerator
66 { moves = negate moves
67 , posts = negate posts
68 }
69
70 data JournalRepr repr a where
71 JournalReprAny ::
72 Balanceable a ~ 'False =>
73 repr a -> JournalRepr repr a
74 JournalRepr ::
75 --Balanceable a ~ 'True =>
76 JournalDo repr a -> JournalRepr repr a
77
78 instance Functor (JournalRepr repr) where
79 fmap f = \case
80 JournalRepr fx -> JournalRepr (fmap f fx)
81 instance Listable repr => Applicative (JournalRepr repr) where
82 pure = JournalRepr . pure
83 JournalRepr fa <*> JournalRepr fb = JournalRepr (fa <*> fb)
84 instance Listable repr => Monad (JournalRepr repr) where
85 return = JournalRepr . return
86 JournalRepr ma >>= f = JournalRepr $ ma >>= \a ->
87 case f a of
88 JournalRepr mb -> mb
89
90 type instance Ty (JournalRepr repr) TyUnit = Ty repr TyUnit
91
92 runJournalRepr :: JournalRepr repr TyMove -> repr [TyMove]
93 runJournalRepr = \case
94 JournalRepr j -> runJournalDo j
95 instance
96 Unitable repr =>
97 Unitable (JournalRepr repr) where
98 unit u = \case
99 JournalReprAny x -> JournalReprAny (unit u x)
100 JournalRepr x -> JournalRepr (unit u x)
101 -}
102 {-
103 instance
104 ( Listable repr
105 , Monad m
106 ) => IsList (JournalRepr acct amt repr [a]) where
107 type Item (JournalRepr acct amt repr [a]) = JournalRepr acct amt repr a
108 fromList = Foldable.foldr cons nil
109 toList x = error "toList"
110 fromListN _len = fromList
111 -}
112 {-
113 instance Listable repr => Listable (JournalRepr repr) where
114 nil = JournalRepr $ return []
115 cons (JournalRepr x) (JournalRepr xs) = JournalRepr $ liftA2 (:) x xs
116 -- NOTE: those two should never be needed, but Balanceable can't rule them out
117 cons (JournalReprAny x) (JournalRepr xs) = JournalRepr $
118 liftA2 (:) (JournalDo (return undefined)) xs
119 concat (JournalRepr xs) (JournalRepr ys) = JournalRepr $ liftA2 (<>) xs ys
120 instance Zeroable (repr TyAmount) => Zeroable (JournalRepr repr TyAmount) where
121 zero = JournalReprAny zero
122 instance Addable (repr TyAmount) => Addable (JournalRepr repr TyAmount) where
123 JournalReprAny x + JournalReprAny y = JournalReprAny (x + y)
124 instance
125 ( Negable (repr [TyMove])
126 , Negable (repr [TyPost])
127 , Negable (repr a)
128 ) => Negable (JournalRepr repr a) where
129 negate (JournalReprAny x) = JournalReprAny (negate x)
130 negate (JournalRepr x) = JournalRepr $ JournalDo $
131 MT.mapWriter (negate <$>) $ unJournalDo x
132 instance
133 ( Listable repr
134 , FromInteger (repr TyAmount)
135 ) => FromInteger (JournalRepr repr TyAmount) where
136 fromInteger = JournalReprAny . fromInteger
137 instance
138 ( Listable repr
139 , FromInteger (repr TyAccount)
140 ) => FromInteger (JournalRepr repr TyAccount) where
141 fromInteger = JournalReprAny . fromInteger
142 instance
143 ( Listable repr
144 , Accountable repr
145 , Amountable repr
146 , Postable repr
147 , Zeroable (repr TyAmount)
148 , FromInteger (repr TyAccount)
149 ) => FromInteger (JournalRepr repr TyPost) where
150 fromInteger i = post (fromInteger i) zero
151 instance
152 ( Listable repr
153 , Accountable repr
154 , Amountable repr
155 , Postable repr
156 , Zeroable (repr TyAmount)
157 , FromInteger (repr TyAccount)
158 ) => FromInteger (JournalRepr repr [TyPost]) where
159 fromInteger i = post (fromInteger i) zero `cons` nil
160 -}
161 {-
162 instance
163 ( Postable repr
164 , FromInteger (JournalRepr repr acct)
165 , Listable repr
166 , Monad m
167 ) => FromInteger (JournalRepr repr [TyPost]) where
168 fromInteger i = cons (fromInteger i) nil
169 instance
170 ( Postable repr
171 , IsString (JournalRepr repr acct)
172 , Listable repr
173 , Monad m
174 ) => IsString (JournalRepr repr TyPost) where
175 fromString s = do
176 acct :: acct <- fromString s
177 post acct (Map.empty :: Map unit qty)
178 instance
179 ( Postable repr
180 , IsString (JournalRepr repr acct)
181 , Listable repr
182 , Monad m
183 ) => IsString (JournalRepr repr [TyPost]) where
184 fromString s = do
185 acct :: acct <- fromString s
186 cons (post acct (Map.empty :: Map unit qty)) nil
187 instance
188 ( FromRational qty
189 , Listable repr
190 , Monad m
191 ) => FromRational (JournalRepr repr qty) where
192 fromRational = JournalRepr . return . fromRational
193 type instance QuantityOf (Map unit qty) = qty
194 instance
195 ( IsString unit
196 , Monad m
197 ) => EURable (Map unit qty) (JournalRepr repr) where
198 eur = (Map.singleton "€" <$>)
199 -}
200
201 {-
202 instance EURable repr => EURable (JournalRepr repr) where
203 eur (JournalReprAny x) = JournalReprAny (eur x)
204 instance USDable repr => USDable (JournalRepr repr) where
205 usd (JournalReprAny x) = JournalReprAny (usd x)
206
207 instance
208 ( Listable repr
209 , Accountable repr
210 , Amountable repr
211 , Postable repr
212 ) => Postable (JournalRepr repr) where
213 post (JournalReprAny acct) (JournalReprAny amt) = JournalRepr $ JournalDo $
214 MT.writer (TyPost, mempty{posts = post acct amt `cons` nil})
215 instance
216 ( Addable (Ty repr TyQuantity)
217 , Listable repr
218 , Moveable repr
219 , Negable (Ty repr TyQuantity)
220 , Nullable (Ty repr TyQuantity)
221 , Ord (Ty repr TyAccountSection)
222 , Ord (Ty repr TyUnit)
223 , Postable repr
224 , Show (Ty repr TyAccountSection)
225 , Show (Ty repr TyQuantity)
226 , Show (Ty repr TyUnit)
227 ) => Moveable (JournalRepr repr) where
228 move (JournalRepr ps) = JournalRepr $ JournalDo $
229 (`MT.mapWriterT` unJournalDo ps) $ fmap $ \(_ps, out) ->
230 ( TyMove, out
231 { moves = move (posts out) `cons` moves out
232 , posts = nil
233 }
234 )
235 -}
236 {-
237 instance FromInteger (JournalRepr acct amt repr AccountCode) where
238 fromInteger i = JournalRepr do
239 env <- MT.ask
240 let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
241 case HashMap.lookup ac (accountByCode env) of
242 Just{} -> return ac
243 _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
244 -}
245 --instance FromInteger qty => FromInteger (JournalRepr acct amt repr qty) where
246 -- fromInteger = JournalRepr . return . fromInteger
247 {-
248 type instance AccountSectionOf (ChartPath section) = section
249 type instance UnitOf (Map unit qty) = unit
250 type instance AmountOf () = Map Unit Q
251 type instance AccountOf () = NonEmpty AccountSegment
252
253 type Account = AccountCode
254 type AccountPath = ChartPath AccountSegment
255 type Amount = Map Unit Q
256 type Q = Quantity (Flow Decimal)
257
258 instance FromInteger qty => FromInteger (Flow qty) where
259 fromInteger i | i <= 0 = Out (fromInteger i)
260 | otherwise = In (fromInteger i)
261
262 instance
263 Listable repr =>
264 IsString (JournalRepr acct amt repr (ChartPath AccountSegment)) where
265 fromString s = JournalRepr $ MT.ReaderT $ \env -> do
266 case nonEmpty (fromString s) of
267 Just acct | HashMap.member acct (accountByName env) -> MT.writer (acct, mempty)
268 Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
269 Nothing -> error "Invalid empty AccountPath"
270 instance
271 Listable repr =>
272 FromInteger (JournalRepr acct amt repr (ChartPath AccountSegment)) where
273 fromInteger i = JournalRepr $ MT.ReaderT $ \env -> do
274 let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
275 case HashMap.lookup ac (accountByCode env) of
276 Just (Just acct, _) -> MT.writer (acct, mempty)
277 _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
278 instance
279 Listable repr =>
280 IsString (JournalRepr acct amt repr AccountCode) where
281 fromString s = JournalRepr $ MT.ReaderT $ \env -> do
282 case nonEmpty (fromString s) of
283 Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> MT.writer (ac, mempty)
284 Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
285 Nothing -> error "Invalid empty AccountPath"
286
287 -- ** Type 'JournalEnv'
288 data JournalEnv unit = JournalEnv
289 { accountByCode :: HashMap.HashMap AccountCode (Maybe AccountPath, ChartNode)
290 , accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
291 , defaultUnit :: unit
292 }
293 journalEnv ch = JournalEnv
294 { accountByCode = HashMap.fromList byCode
295 , accountByName = HashMap.fromList byName
296 , defaultUnit = inject ""
297 } where
298 (byCode, byName) = goChart (AccountCode 0, []) ch
299 goChart p = Map.foldMapWithKey (goNode p) . unChart
300 goNode (AccountCode kc, kn) n (node, children) =
301 let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
302 let keyName = kn <> maybeToList (sectionName node) in
303 let (bc, bn) = goChart (keyCode, keyName) children in
304 ( (keyCode, (nonEmpty keyName, node)) : bc
305 , case nonEmpty keyName of
306 Just k -> (k, (keyCode, node)) : bn
307 Nothing -> bn
308 )
309 instance
310 ( FromInteger qty
311 , Listable repr
312 ) => FromInteger (JournalRepr acct (Map unit qty) repr (Map unit qty)) where
313 fromInteger i = JournalRepr $
314 --qty <- unJournalDo (fromInteger i :: JournalRepr acct (Map unit qty) repr qty)
315 MT.writer (Map.singleton (defaultUnit env) (fromInteger i), mempty)
316
317 -- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
318 digitNumber :: Natural -> Natural
319 digitNumber = go where
320 go n | n < 10 = 1
321 | otherwise = 1 Prelude.+ go (n`Prelude.div`10)
322
323 -}