]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Write/Balance.hs
Commit old WIP.
[comptalang.git] / lcc / Hcompta / LCC / Write / Balance.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Hcompta.LCC.Write.Balance where
7
8 import Control.Monad (Monad(..))
9 import Data.Bool
10 import Data.Char (Char)
11 import Data.Decimal
12 import Data.Eq (Eq(..))
13 -- import Data.Foldable (Foldable(..))
14 import Data.Function (($), (.), flip, id)
15 import Data.Functor ((<$>))
16 import Data.Functor.Compose (Compose(..))
17 import Data.Proxy (Proxy(..))
18 import Data.Map.Strict (Map)
19 import Data.Maybe (Maybe(..), fromMaybe, maybe)
20 import Data.Monoid (Monoid(..))
21 import Data.Ord (Ord(..))
22 import Data.Semigroup (Semigroup(..))
23 import Data.Text (Text)
24 import Data.Tuple (fst)
25 import GHC.Exts (Int(..))
26 import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
27 import System.IO (IO)
28 import qualified Data.ByteString as BS
29 import qualified Data.Char as Char
30 import qualified Data.List as L
31 import qualified Data.Map.Strict as Map
32 import qualified Data.MonoTraversable as MT
33 import qualified Data.NonNull as NonNull
34 import qualified Data.Strict as S
35 import qualified Data.Text as Text
36 import qualified Data.Text.Encoding as Enc
37 import qualified Data.TreeMap.Strict as TM
38
39 import qualified Language.Symantic.Document as D
40
41 import qualified Hcompta as H
42
43 import Hcompta.LCC.Account
44 import Hcompta.LCC.Amount
45 import Hcompta.LCC.Chart
46 import Hcompta.LCC.Compta
47 import Hcompta.LCC.IO
48 import Hcompta.LCC.Journal
49 import Hcompta.LCC.Name
50 import Hcompta.LCC.Posting
51 import Hcompta.LCC.Tag
52 import Hcompta.LCC.Transaction
53 import Hcompta.LCC.Balance
54 import Hcompta.LCC.Write.Compta
55 import Hcompta.LCC.Write.Table
56 import qualified Hcompta.LCC.Read.Compta as G
57 import qualified Hcompta.Lib.Strict as S
58
59
60 -- * Class 'Msg_Title'
61 class Msg_Title lang d where
62 msg_Title_Debit :: d
63 msg_Title_Credit :: d
64 msg_Title_Balance :: d
65 msg_Title_Account :: d
66
67 -- * Type 'FR'
68 data FR
69 instance D.Doc_Text d => Msg_Title FR d where
70 msg_Title_Debit = D.textH "Débit"
71 msg_Title_Credit = D.textH "Crédit"
72 msg_Title_Balance = D.textH "Solde"
73 msg_Title_Account = D.textH "Compte"
74
75 -- * Type 'Config_Balance'
76 data Config_Balance
77 = Config_Balance
78 { config_balance_heritage :: Bool
79 , config_balance_total_by_unit :: Bool
80 }
81
82 instance Writeable (Style_Amount, Amount) d =>
83 CellPlainOf (Style_Amount, Amount) d
84 instance Writeable Date d => CellPlainOf Date d
85 instance Writeable Account d => CellPlainOf Account d
86 instance ( CellPlainOf () d
87 , CellPlainOf (Style_Amount, Amount) d
88 ) => CellPlainOf (Maybe (Style_Amount, Amount)) d where
89 cellPlainOf = cellPlainOf () `maybe` cellPlainOf
90
91 -- instance D.Doc_Text d => CellPlainOf Wording d
92
93 -- * Type 'RowsPlain'
94 type RowsPlain d = [[CellPlain d]] -> [[CellPlain d]]
95
96 -- * Class 'RowsPlainOf'
97 class RowsPlainOf a d where
98 rowsPlainOf :: a -> RowsPlain d
99
100 instance ( CellPlainOf () d
101 , CellPlainOf Account d
102 , CellPlainOf (Style_Amount, Amount) d
103 ) => RowsPlainOf (Style_Amount, BalByAccount) d where
104 rowsPlainOf (sty, bal) =
105 flip (TM.foldrWithPath
106 (\acct sum rows ->
107 Map.foldrWithKey
108 (\unit qty ->
109 L.zipWith (:)
110 [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
111 , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
112 , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
113 , cellPlainOf $ Account acct
114 ]
115 )
116 rows sum
117 )) bal
118 instance ( CellPlainOf () d
119 , CellPlainOf Account d
120 , CellPlainOf (Style_Amount, Amount) d
121 ) => RowsPlainOf (Style_Amount, ClusiveBalByAccount) d where
122 rowsPlainOf (sty, bal) =
123 flip (TM.foldrWithPath
124 (\acct S.Clusive{S.inclusive=sum} rows ->
125 Map.foldrWithKey
126 (\unit qty ->
127 L.zipWith (:)
128 [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
129 , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
130 , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
131 , cellPlainOf $ Account acct
132 ]
133 )
134 rows sum
135 )) bal
136 instance ( CellPlainOf () d
137 , CellPlainOf Account d
138 , CellPlainOf (Style_Amount, Amount) d
139 ) => RowsPlainOf (Style_Amount, BalByUnit) d where
140 rowsPlainOf (sty, bal) =
141 flip (Map.foldrWithKey
142 (\unit H.SumByUnit{H.sumByUnit_quantity=qty} ->
143 L.zipWith (:)
144 [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
145 , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
146 , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
147 , cellPlainOf ()
148 ]
149 )) bal
150 instance ( Monoid d
151 , D.Doc_Text d
152 , D.Doc_Color d
153 , D.Doc_Decoration d
154 , Msg_Title lang Text
155 ) => TablePlainOf (Proxy lang, Style_Amount, BalByAccount, BalByUnit) d where
156 tablePlainOf (_lang, sty, ba, bu) =
157 L.zipWith id
158 [ columnPlain (msg_Title_Debit @lang) AlignPlainR
159 , columnPlain (msg_Title_Credit @lang) AlignPlainR
160 , columnPlain (msg_Title_Balance @lang) AlignPlainR
161 , columnPlain (msg_Title_Account @lang) AlignPlainL
162 ] $
163 rowsPlainOf (sty, ba) $
164 rowsPlainOf (sty, bu) $
165 L.repeat []
166
167 {-
168 instance Writeable (Proxy lang, Balance) d where
169 write (lang, H.Balance)
170
171 instance Writeable (Proxy lang, Compta src ss Balance) d where
172 write (lang, Compta{compta_journals=js, compta_style_amounts=sty}) =
173 tablePlainOf (lang, sty, )
174
175 instance ( CellPlainOf () d
176 , CellPlainOf Account d
177 , CellPlainOf (Style_Amount, Amount) d
178 ) => RowsPlainOf (Style_Amount, BalByAccount, H.BalByUnit) d where
179 rowsPlainOf (sty, bal) =
180
181 instance TablePlainOf (Style_Amount, H.BalByUnit NameAccount Unit (H.Polarized Quantity)) where
182 tablePlainOf conf balByAccount =
183 let (rowsByAccount, rowsByUnit) =
184 case config_balance_heritage conf of
185 True -> rowsOfBalByUnit $ H.clusiveBalByAccount balByAccount
186 False -> rowsOfBalByUnit balByAccount in
187 zipWith id
188 [ tColumn (msg_Title_Debit @lang) AlignR
189 , tColumn (msg_Title_Credit @lang) AlignR
190 , tColumn (msg_Title_Balance @lang) AlignR
191 , tColumn (msg_Title_Account @lang) AlignL
192 ] $
193 rowsByAccount $
194 (if config_balance_total_by_unit conf
195 then zipWith (:)
196 [ tCellLine '=' 0
197 , tCellLine '=' 0
198 , tCellLine '=' 0
199 , tCellLine ' ' 0
200 ] . rowsByUnit
201 else id) $
202 L.repeat []
203 where
204 expand :: Forall_Journal_Balance_by_Account ->
205 Forall_Journal_Balance_by_Account_Expanded
206 expand = Format.journal_wrap
207 rowsOfBalByUnit ::
208 ( Format.Journal_Filter Context (Const BalByAccount) ()
209 , Format.Journal_Wrap BalByAccount Forall_Journal_Balance_by_Unit
210 , Format.Journal_Leijen_Table_Cells (Const BalByAccount) ()
211 ) =>
212 BalByAccount ->
213 ( [[CellPlain d]] -> [[CellPlain d]]
214 , [[CellPlain d]] -> [[CellPlain d]] )
215 rowsOfBalByUnit =
216 (***) tCellsOfBalByAccount tCellsOfBalByUnit .
217 (&&&) id sum_by_unit .
218 Format.journal_filter ctx .
219 Const
220 where
221 sum_by_unit ::
222 Format.Journal_Wrap BalByAccount Forall_Journal_Balance_by_Unit =>
223 Const BalByAccount () ->
224 Const Forall_Journal_Balance_by_Unit ()
225 sum_by_unit = Const . Format.journal_wrap . getConst
226
227 {-
228 ttableOf :: forall lang d.
229 D.Doc_Text d =>
230 D.Doc_Color d =>
231 BalByAccount -> TTable d
232
233
234 -}
235
236
237
238
239 {-
240 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
241 -}
242
243
244
245
246
247
248
249
250
251
252 {-
253 -- * 'H.Balance_by_Account'
254
255 -- ** Type 'Format_Balance_by_Account'
256
257 type Format_Journal_Balance_by_Account
258 = Format
259 ( JCC.Journal Balance_by_Account_JCC)
260 (Ledger.Journal Balance_by_Account_Ledger)
261
262 -- JCC
263 type Balance_by_Account_JCC
264 = H.Balance_by_Account JCC.Account_Section
265 JCC.Unit
266 (H.Polarized JCC.Quantity)
267 instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
268 type Journal_Format (JCC.Journal Balance_by_Account_JCC)
269 = Format_Journal_Balance_by_Account
270 journal_format = Format_JCC
271
272 -- Ledger
273 type Balance_by_Account_Ledger
274 = H.Balance_by_Account Ledger.Account_Section
275 Ledger.Unit
276 (H.Polarized Ledger.Quantity)
277 instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
278 type Journal_Format (Ledger.Journal Balance_by_Account_Ledger)
279 = Format_Journal_Balance_by_Account
280 journal_format = Format_Ledger
281
282 -- ** Class 'Journal_Balance_by_Account'
283
284 class
285 ( Format.Journal (j m)
286 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
287 , Format.Journal_Read j
288 , Format.Journal_Monoid (j m)
289 , Format.Journal_Leijen_Table_Cells j m
290 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
291 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
292 , Format.Journal_Filter Context j m
293 , Journal_Equilibrium_Transaction j m
294 ) => Journal_Balance_by_Account j m
295
296 instance Journal_Balance_by_Account JCC.Journal Balance_by_Account_JCC
297 instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
298
299 -- ** Type 'Forall_Journal_Balance_by_Account'
300
301 data Forall_Journal_Balance_by_Account
302 = forall j m. Journal_Balance_by_Account j m
303 => Forall_Journal_Balance_by_Account (j m)
304
305 instance Format.Journal Forall_Journal_Balance_by_Account where
306 type Journal_Format Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
307 journal_format
308 (Forall_Journal_Balance_by_Account j) =
309 Format.journal_format j
310 instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
311 journal_empty f =
312 case f of
313 Format_JCC () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
314 Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
315 instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
316 journal_flatten
317 (Forall_Journal_Balance_by_Account j) =
318 Forall_Journal_Balance_by_Account $
319 Format.journal_flatten j
320 journal_fold f (Forall_Journal_Balance_by_Account j) =
321 Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
322 instance Monoid Forall_Journal_Balance_by_Account where
323 mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
324 mappend x y =
325 case (mappend `on` Format.journal_format) x y of
326 Format_JCC j -> Forall_Journal_Balance_by_Account j
327 Format_Ledger j -> Forall_Journal_Balance_by_Account j
328 mconcat js =
329 case js of
330 [] -> mempty
331 j:jn -> List.foldl' mappend j jn
332
333 -- ** 'journal_read'
334
335 type Journal_Filter_Simplified transaction
336 = Filter.Simplified
337 (Filter.Filter_Bool
338 (Filter.Filter_Transaction transaction))
339 type Journal_Read_Cons txn
340 = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
341 journal_read
342 :: Context -> FilePath
343 -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
344 journal_read ctx =
345 case ctx_input_format ctx of
346 Format_JCC () ->
347 let wrap (j::JCC.Journal Balance_by_Account_JCC)
348 = Forall_Journal_Balance_by_Account j in
349 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
350 = Filter.Filtered (ctx_filter_transaction ctx) in
351 liftM ((+++) Format.Message wrap) .
352 Format.journal_read cons
353 Format_Ledger () ->
354 let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
355 = Forall_Journal_Balance_by_Account j in
356 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
357 = Filter.Filtered (ctx_filter_transaction ctx) in
358 liftM ((+++) Format.Message wrap) .
359 Format.journal_read cons
360
361 {-
362 -- ** Type family 'Balance_by_Account'
363
364 type family Balance_by_Account (j:: * -> *) m
365 type instance Balance_by_Account
366 j (Balance.Expanded as u (Polarized q))
367 = j (Balance.Balance_by_Account as u (Polarized q))
368 type instance Balance_by_Account
369 (Const Forall_Journal_Balance_by_Account_Expanded) ()
370 = (Const Forall_Journal_Balance_by_Account ) ()
371 -}
372
373 -- Instances 'Format.Journal_Filter'
374
375 instance
376 ( Functor j
377 , Format.Journal_Chart j
378
379 , as ~ Format.Journal_Account_Section j
380 , Data as
381 {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
382 , NFData as
383 , Ord as
384 , Show as
385
386 , q ~ Format.Journal_Quantity j
387 , Format.Journal_Quantity j ~ Decimal
388 , H.Addable q
389 , H.Zero q
390
391 , H.Unit u
392 ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
393 journal_filter ctx j =
394 case Filter.simplified $ ctx_filter_balance ctx of
395 Right True | ctx_redundant ctx -> j
396 Right True ->
397 TreeMap.filter_with_Path_and_Node
398 (\n _p -> is_worth n) <$> j
399 Right False -> const mempty <$> j
400 Left flt ->
401 (<$> j) $
402 TreeMap.map_Maybe_with_Path_and_Node
403 (\node account (H.Balance_by_Account_Sum bal) ->
404 (if is_worth node bal then id else const Strict.Nothing) $
405 case Map.mapMaybeWithKey
406 (\unit qty ->
407 if Filter.test flt
408 ( (H.chart_account_tags account (Format.journal_chart j), account)
409 , (unit, qty)
410 )
411 then Just qty
412 else Nothing
413 ) bal of
414 m | Map.null m -> Strict.Nothing
415 m -> Strict.Just $ H.Balance_by_Account_Sum m
416 )
417 where
418 is_worth
419 :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
420 => TreeMap.Node k0 x0
421 -> t0 (H.Polarized a0)
422 -> Bool
423 is_worth _node bal =
424 ctx_redundant ctx
425 -- NOTE: worth if no descendant
426 -- but Account's exclusive
427 -- has at least a non-zero Amount
428 || Foldable.any
429 (not . H.quantity_null . H.depolarize)
430 bal
431 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
432 journal_filter ctx
433 (Const (Forall_Journal_Balance_by_Account j)) =
434 Const $ Forall_Journal_Balance_by_Account $
435 Format.journal_filter ctx j
436
437 -- Instances 'Format.Journal_Leijen_Table_Cells'
438
439 instance
440 ( Format.Journal_Content j
441 , Journal j
442
443 , as ~ Format.Journal_Account_Section j
444 , Ord as
445 , H.Addable (Format.Journal_Quantity j)
446
447 , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
448
449 , Balance_by_Account_Sum amt
450 , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
451 , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
452 ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
453 journal_leijen_table_cells jnl =
454 flip (TreeMap.foldr_with_Path
455 (\account balance rows ->
456 let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
457 Map.foldrWithKey
458 (\unit qty ->
459 zipWith (:)
460 [ cell_of $ (unit,) <$> H.polarized_positive qty
461 , cell_of $ (unit,) <$> H.polarized_negative qty
462 , cell_of (unit, H.depolarize qty)
463 , cell_of account
464 ]
465 )
466 rows bal
467 ))
468 (Format.journal_content jnl)
469 where
470 cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
471 cell_of = Leijen.Table.cell_of_forall_param jnl
472 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
473 journal_leijen_table_cells
474 (Const (Forall_Journal_Balance_by_Account j)) =
475 Format.journal_leijen_table_cells j
476
477 -- ** Class 'Balance_by_Account_Sum'
478
479 -- | A class to get a 'H.Balance_Account_Sum'
480 -- when operating on 'H.Balance_by_Account'
481 -- or 'H.Balance_Expanded' 'Strict.inclusive' field.
482 class Balance_by_Account_Sum amt where
483 type Balance_by_Account_Sum_Unit amt
484 type Balance_by_Account_Sum_Quantity amt
485 balance_by_account_sum
486 :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
487 (Balance_by_Account_Sum_Quantity amt)
488 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
489 type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum u q) = u
490 type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
491 balance_by_account_sum = id
492 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
493 type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum_Expanded u q) = u
494 type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
495 balance_by_account_sum = Strict.inclusive
496
497 -- * 'H.Balance_Expanded'
498
499 -- ** Type 'Format_Journal_Balance_by_Account_Expanded'
500
501 type Format_Journal_Balance_by_Account_Expanded
502 = Format
503 ( JCC.Journal Balance_by_Account_Expanded_JCC)
504 (Ledger.Journal Balance_by_Account_Expanded_Ledger)
505
506 -- JCC
507 type Balance_by_Account_Expanded_JCC
508 = H.Balance_Expanded JCC.Account_Section
509 JCC.Unit
510 (H.Polarized JCC.Quantity)
511 instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
512 type Journal_Format (JCC.Journal Balance_by_Account_Expanded_JCC)
513 = Format_Journal_Balance_by_Account_Expanded
514 journal_format = Format_JCC
515
516 -- Ledger
517 type Balance_by_Account_Expanded_Ledger
518 = H.Balance_Expanded Ledger.Account_Section
519 Ledger.Unit
520 (H.Polarized Ledger.Quantity)
521 instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
522 type Journal_Format (Ledger.Journal Balance_by_Account_Expanded_Ledger)
523 = Format_Journal_Balance_by_Account_Expanded
524 journal_format = Format_Ledger
525
526 -- ** Class 'Journal_Balance_by_Account_Expanded'
527
528 class
529 ( Format.Journal (j m)
530 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
531 , Format.Journal_Leijen_Table_Cells j m
532 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
533 , Format.Journal_Filter Context j m
534 ) => Journal_Balance_by_Account_Expanded j m
535
536 instance Journal_Balance_by_Account_Expanded JCC.Journal Balance_by_Account_Expanded_JCC
537 instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
538
539 -- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
540
541 data Forall_Journal_Balance_by_Account_Expanded
542 = forall j m. Journal_Balance_by_Account_Expanded j m
543 => Forall_Journal_Balance_by_Account_Expanded (j m)
544
545 instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
546 type Journal_Format Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
547 journal_format
548 (Forall_Journal_Balance_by_Account_Expanded j) =
549 Format.journal_format j
550
551 -- Instances 'Format.Journal_Filter'
552
553 instance
554 ( Functor j
555 , Format.Journal_Chart j
556 , as ~ Format.Journal_Account_Section j
557 , Data as
558 {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
559 , NFData as
560 , Ord as
561 , Show as
562 , q ~ Format.Journal_Quantity j
563 , Format.Journal_Quantity j ~ Decimal
564 , H.Addable q
565 , H.Zero q
566 , H.Unit u
567 ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
568 journal_filter ctx j =
569 case Filter.simplified $ ctx_filter_balance ctx of
570 Right True | ctx_redundant ctx -> j
571 Right True ->
572 TreeMap.filter_with_Path_and_Node
573 (const . is_worth) <$> j
574 Right False -> const mempty <$> j
575 Left flt ->
576 (<$> j) $
577 TreeMap.map_Maybe_with_Path_and_Node
578 (\node account bal ->
579 (if is_worth node bal then id else const Strict.Nothing) $
580 case Map.mapMaybeWithKey
581 (\unit qty ->
582 if Filter.test flt
583 ( (H.chart_account_tags account (Format.journal_chart j), account)
584 , (unit, qty)
585 )
586 then Just qty
587 else Nothing
588 ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
589 m | Map.null m -> Strict.Nothing
590 m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
591 )
592 where
593 is_worth node bal =
594 let descendants = TreeMap.nodes
595 (TreeMap.node_descendants node) in
596 ctx_redundant ctx
597 -- NOTE: worth if no descendant
598 -- but Account's inclusive
599 -- has at least a non-zero Amount
600 || (Map.null descendants &&
601 Foldable.any
602 (not . H.quantity_null . H.depolarize)
603 (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
604 -- NOTE: worth if Account's exclusive
605 -- has at least a non-zero Amount
606 || (Foldable.any
607 (not . H.quantity_null . H.depolarize)
608 (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
609 -- NOTE: worth if Account has at least more than
610 -- one descendant Account whose inclusive
611 -- has at least a non-zero Amount
612 || Map.size
613 ( Map.filter
614 ( Strict.maybe False
615 ( Foldable.any
616 (not . H.quantity_null . H.depolarize)
617 . H.unBalance_by_Account_Sum
618 . Strict.inclusive )
619 . TreeMap.node_value )
620 descendants
621 ) > 1
622 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
623 journal_filter ctx
624 (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
625 Const $ Forall_Journal_Balance_by_Account_Expanded $
626 Format.journal_filter ctx j
627
628 -- Instances 'Format.Journal_Leijen_Table_Cells'
629
630 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
631 journal_leijen_table_cells
632 (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
633 Format.journal_leijen_table_cells j
634
635 -- Instances H.Balance_by_Account -> H.Balance_Expanded
636
637 instance
638 ( Functor j
639 , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
640
641 -- NOTE: constraints from H.balance_expanded
642 , Ord as
643 , Ord u
644 , H.Addable q
645 ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
646 Forall_Journal_Balance_by_Account_Expanded where
647 journal_wrap =
648 Forall_Journal_Balance_by_Account_Expanded .
649 fmap H.balance_expanded
650
651 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
652 Forall_Journal_Balance_by_Account_Expanded where
653 journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
654
655
656
657
658
659
660
661
662
663
664
665 -- * 'H.Balance_by_Unit'
666
667 type Format_Journal_Balance_by_Unit
668 = Format
669 ( JCC.Journal Balance_by_Unit_JCC)
670 (Ledger.Journal Balance_by_Unit_Ledger)
671
672 -- JCC
673 type Balance_by_Unit_JCC
674 = H.Balance_by_Unit JCC.Account
675 JCC.Unit
676 (H.Polarized JCC.Quantity)
677 instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
678 type Journal_Format (JCC.Journal Balance_by_Unit_JCC)
679 = Format_Journal_Balance_by_Unit
680 journal_format = Format_JCC
681
682 -- Ledger
683 type Balance_by_Unit_Ledger
684 = H.Balance_by_Unit Ledger.Account
685 Ledger.Unit
686 (H.Polarized Ledger.Quantity)
687 instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
688 type Journal_Format (Ledger.Journal Balance_by_Unit_Ledger)
689 = Format_Journal_Balance_by_Unit
690 journal_format = Format_Ledger
691
692 -- ** Class 'Journal_Balance_by_Unit'
693
694 class
695 ( Format.Journal (j m)
696 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
697 , Format.Journal_Leijen_Table_Cells j m
698 -- , Journal_Equilibrium_Postings j m
699 )
700 => Journal_Balance_by_Unit j m
701
702 instance Journal_Balance_by_Unit JCC.Journal Balance_by_Unit_JCC
703 instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
704
705 -- ** Type 'Forall_Journal_Balance_by_Unit'
706
707 data Forall_Journal_Balance_by_Unit
708 = forall j m. Journal_Balance_by_Unit j m
709 => Forall_Journal_Balance_by_Unit (j m)
710
711 instance Format.Journal Forall_Journal_Balance_by_Unit where
712 type Journal_Format Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
713 journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
714
715 -- Instances H.Balance_by_Account -> H.Balance_by_Unit
716
717 instance
718 ( Functor j
719 , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
720
721 -- NOTE: constraints from H.balance_by_unit_of_by_account
722 , H.Account (H.Account_Path as)
723 , Ord as
724 , Ord u
725 , H.Addable q
726 ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
727 Forall_Journal_Balance_by_Unit where
728 journal_wrap =
729 Forall_Journal_Balance_by_Unit .
730 fmap (flip H.balance_by_unit_of_by_account mempty)
731
732 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
733 Forall_Journal_Balance_by_Unit where
734 journal_wrap
735 (Forall_Journal_Balance_by_Account j) =
736 Format.journal_wrap j
737
738 -- Instances H.Balance_Expanded -> H.Balance_by_Unit
739
740 instance
741 ( Functor j
742 , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
743
744 -- NOTE: constraints from H.balance_by_unit_of_expanded
745 , H.Account (H.Account_Path as)
746 , Ord as
747 , Ord u
748 , H.Addable q
749 ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
750 Forall_Journal_Balance_by_Unit where
751 journal_wrap =
752 Forall_Journal_Balance_by_Unit .
753 fmap (flip H.balance_by_unit_of_expanded mempty)
754
755 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
756 Forall_Journal_Balance_by_Unit where
757 journal_wrap
758 (Forall_Journal_Balance_by_Account_Expanded j) =
759 Format.journal_wrap j
760
761 -- Instances 'Format.Journal_Leijen_Table_Cells'
762
763 instance
764 ( Format.Journal_Content j
765 , Journal j
766
767 , a ~ Format.Journal_Account j
768 , H.Account a
769 , u ~ Format.Journal_Unit j
770 , Ord u
771 , q ~ Format.Journal_Quantity j
772 , H.Addable (Format.Journal_Quantity j)
773 ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
774 journal_leijen_table_cells jnl acc =
775 let H.Balance_by_Unit bal = Format.journal_content jnl in
776 Map.foldrWithKey
777 (\unit amt ->
778 let qty = H.balance_by_unit_sum_quantity amt in
779 zipWith (:)
780 [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
781 , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
782 , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
783 , Leijen.Table.cell
784 ]
785 ) acc bal
786 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
787 journal_leijen_table_cells
788 (Const (Forall_Journal_Balance_by_Unit j)) =
789 Format.journal_leijen_table_cells j
790
791
792
793
794
795
796
797
798
799 -- * Class 'Journal'
800
801 class
802 ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
803 , W.ToDoc1 j [Format.Journal_Transaction j]
804 ) => Journal (j:: * -> *) where
805 journal_posting
806 :: forall m. j m
807 -> H.Account_Path (Format.Journal_Account_Section j)
808 -> Map (Format.Journal_Unit j)
809 (Format.Journal_Quantity j)
810 -> [Text] -- ^ Comments
811 -> Format.Journal_Posting j
812 journal_transaction
813 :: forall m. j m
814 -> Text -- ^ Wording
815 -> (H.Date, [H.Date])
816 -> Map (H.Account_Path (Format.Journal_Account_Section j))
817 [Format.Journal_Posting j]
818 -> Format.Journal_Transaction j
819
820 instance Journal JCC.Journal where
821 journal_posting _j acct
822 posting_amounts
823 posting_comments =
824 (JCC.posting acct)
825 { JCC.posting_amounts
826 , JCC.posting_comments
827 }
828 journal_transaction _j
829 transaction_wording
830 transaction_dates
831 transaction_postings =
832 JCC.transaction
833 { JCC.transaction_wording
834 , JCC.transaction_dates
835 , JCC.transaction_postings
836 }
837 instance Journal Ledger.Journal where
838 journal_posting _j acct
839 posting_amounts
840 posting_comments =
841 (Ledger.posting acct)
842 { Ledger.posting_amounts
843 , Ledger.posting_comments
844 }
845 journal_transaction _j
846 transaction_wording
847 transaction_dates
848 transaction_postings =
849 Ledger.transaction
850 { Ledger.transaction_wording
851 , Ledger.transaction_dates
852 , Ledger.transaction_postings
853 }
854
855
856
857
858
859
860
861
862
863
864
865
866
867 -- * Class 'Journal_Equilibrium_Transaction'
868
869 class Journal_Equilibrium_Transaction j m where
870 journal_equilibrium_transaction
871 :: j m
872 -> C.Context
873 -> Context
874 -> Lang.Exercise_OC
875 -> H.Date
876 -> W.Doc
877
878 instance
879 ( Format.Journal_Content j
880 , Journal j
881
882 , as ~ Format.Journal_Account_Section j
883 , Format.Journal_Account_Section j ~ Text
884 , Format.Journal_Account j ~ TreeMap.Path Text
885 , Num quantity
886 , quantity ~ Format.Journal_Quantity j
887 , Ord unit
888 , Ord quantity
889 , H.Zero (Format.Journal_Quantity j)
890 , H.Addable (Format.Journal_Quantity j)
891 , unit ~ Format.Journal_Unit j
892 ) => Journal_Equilibrium_Transaction
893 j (H.Balance_by_Account as unit (H.Polarized quantity)) where
894 journal_equilibrium_transaction
895 j c ctx oc now =
896 let bal_by_account = Format.journal_content j in
897 let H.Balance_by_Unit bal_by_unit =
898 H.balance_by_unit_of_by_account bal_by_account mempty in
899 let postings =
900 Map.foldlWithKey
901 (\acc unit H.Balance_by_Unit_Sum{..} ->
902 let qty =
903 (case oc of
904 Lang.Exercise_Closing -> id
905 Lang.Exercise_Opening -> negate) $
906 H.depolarize balance_by_unit_sum_quantity in
907 case H.quantity_sign qty of
908 LT ->
909 let account = snd $ ctx_account_equilibrium ctx in
910 Map.insertWith mappend account
911 [journal_posting j account
912 (Map.singleton unit qty)
913 [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
914 acc
915 EQ -> acc
916 GT ->
917 let account = fst $ ctx_account_equilibrium ctx in
918 Map.insertWith mappend account
919 [journal_posting j account
920 (Map.singleton unit qty)
921 [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
922 acc
923 )
924 Map.empty
925 bal_by_unit
926 in
927 W.toDoc1 j [
928 journal_transaction j
929 (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
930 (now{Time.utctDayTime=0}, []) $
931 Map.unionWith mappend postings $
932 TreeMap.flatten_with_Path
933 (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
934 [ journal_posting j posting_account
935 (flip fmap amount_by_unit $
936 (case oc of
937 Lang.Exercise_Closing -> negate
938 Lang.Exercise_Opening -> id)
939 . H.depolarize)
940 []
941 ]
942 )
943 bal_by_account
944 ]
945
946 instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
947 journal_equilibrium_transaction
948 (Const (Forall_Journal_Balance_by_Account j)) =
949 journal_equilibrium_transaction j
950
951 -}
952
953 {-
954 instance
955 ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
956 ( Forall_Journal_Balance_by_Account
957 , Forall_Journal_Balance_by_Unit ) where
958 toDoc c
959 ( Forall_Journal_Balance_by_Account bal_by_account
960 , Forall_Journal_Balance_by_Unit bal_by_unit
961 ) =
962 toDoc c (bal_by_account, bal_by_unit)
963 -}
964
965 -}