]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/GL.hs
Ajout : Lib.TreeMap.Zipper : en prévision de collectes « à la XSLT » sur Chart.
[comptalang.git] / cli / Hcompta / CLI / Command / GL.hs
1 {-# LANGUAGE ExistentialQuantification #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE NamedFieldPuns #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE Rank2Types #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE TupleSections #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Hcompta.CLI.Command.GL where
13
14 import Control.Applicative (Const(..), (<$>))
15 import Control.Arrow (first, (+++))
16 import Control.Monad (Monad(..), liftM, mapM)
17 import Control.Monad.IO.Class (liftIO)
18 import Data.Bool
19 import Data.Decimal (Decimal)
20 import Data.Either (Either(..), partitionEithers)
21 import Data.Foldable (Foldable(..))
22 import Data.Function (($), (.), on, id, flip)
23 import Data.Functor (Functor(..))
24 import Data.List ((++), repeat)
25 import Data.Map.Strict (Map)
26 import qualified Data.Map.Strict as Map
27 import Data.Maybe (Maybe(..))
28 import Data.Monoid (Monoid(..))
29 import Data.Ord (Ord)
30 import qualified Data.Sequence as Seq
31 import qualified Data.Strict.Maybe as Strict
32 import Data.String (String)
33 import Data.Text (Text)
34 import Prelude (Bounded(..), unlines, zipWith)
35 import System.Console.GetOpt
36 ( ArgDescr(..)
37 , OptDescr(..)
38 , usageInfo
39 )
40 import System.Environment as Env (getProgName)
41 import System.Exit (exitSuccess)
42 import qualified System.IO as IO
43 import System.IO (FilePath, IO)
44
45 import qualified Hcompta.Account as Account
46 import qualified Hcompta.CLI.Args as Args
47 import qualified Hcompta.CLI.Context as C
48 import qualified Hcompta.CLI.Env as CLI.Env
49 import Hcompta.CLI.Format.Ledger ()
50 import Hcompta.CLI.Format.JCC ()
51 import qualified Hcompta.CLI.Lang as Lang
52 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
53 import qualified Hcompta.CLI.Write as Write
54 import qualified Hcompta.Chart as Chart
55 import Hcompta.Date (Date)
56 import qualified Hcompta.Filter as Filter
57 import qualified Hcompta.Filter.Read as Filter.Read
58 import qualified Hcompta.Format.JCC as JCC
59 import qualified Hcompta.Format.Ledger as Ledger
60 import qualified Hcompta.GL as GL
61 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
62 import qualified Hcompta.Lib.TreeMap as TreeMap
63 import Hcompta.Polarize (Polarized)
64 import qualified Hcompta.Polarize as Polarize
65 import qualified Hcompta.Posting as Posting
66 import qualified Hcompta.Filter.Amount as Filter.Amount
67 import Hcompta.CLI.Format (Format(..), Formats)
68 import qualified Hcompta.CLI.Format as Format
69 import qualified Hcompta.Lib.Leijen as W
70 import qualified Hcompta.Lib.Parsec as R
71 import qualified Hcompta.Unit as Unit
72 import qualified Hcompta.Quantity as Quantity
73
74 data Context
75 = Context
76 { ctx_filter_transaction :: forall t.
77 ( Filter.Transaction t
78 , Filter.Amount_Quantity
79 (Posting.Posting_Amount
80 (Filter.Transaction_Posting t))
81 ~ Filter.Amount.Quantity
82 ) => Filter.Simplified
83 (Filter.Filter_Bool
84 (Filter.Filter_Transaction t))
85 , ctx_filter_gl :: forall b.
86 ( Filter.GL b
87 , Filter.Amount_Quantity
88 (Filter.GL_Amount b)
89 ~ Filter.Amount.Quantity
90 ) => Filter.Simplified
91 (Filter.Filter_Bool
92 (Filter.Filter_GL b))
93 , ctx_input :: [FilePath]
94 , ctx_input_format :: Formats
95 , ctx_output :: [(Write.Mode, FilePath)]
96 , ctx_output_format :: Maybe Formats
97
98 -- , ctx_filter_gl :: Filter.Simplified
99 -- (Filter.Filter_Bool
100 -- (Filter.Filter_GL
101 -- ( (Account_Tags, Ledger.Account)
102 -- , Date
103 -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
104 -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
105 -- , ctx_filter_posting :: Filter.Simplified
106 -- (Filter.Filter_Bool
107 -- (Filter.Filter_Posting
108 -- (Ledger.Charted Ledger.Posting)))
109 , ctx_reduce_date :: Bool
110 } -- deriving (Show)
111
112 context :: Context
113 context =
114 Context
115 { ctx_filter_gl = Filter.Simplified $ Right True
116 -- , ctx_filter_posting = Filter.Simplified $ Right True
117 , ctx_filter_transaction = Filter.Simplified $ Right True
118 , ctx_input = []
119 , ctx_input_format = mempty
120 , ctx_output = []
121 , ctx_output_format = mempty
122 , ctx_reduce_date = True
123 }
124
125 usage :: C.Context -> IO String
126 usage c = do
127 bin <- Env.getProgName
128 return $ unlines $
129 [ C.translate c Lang.Section_Description
130 , " "++C.translate c Lang.Help_Command_General_Ledger
131 , ""
132 , C.translate c Lang.Section_Syntax
133 , " "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
134 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
135 , ""
136 , usageInfo (C.translate c Lang.Section_Options) (options c)
137 ]
138
139 options :: C.Context -> Args.Options Context
140 options c =
141 [ Option "g" ["filter-gl"]
142 (ReqArg (\s ctx -> do
143 filter <-
144 R.runParserT_with_Error
145 Filter.Read.filter_gl
146 Filter.Read.context "" s
147 case filter of
148 Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
149 Right flt ->
150 return $
151 ctx{ctx_filter_gl =
152 Filter.and (ctx_filter_gl ctx) $
153 (Filter.simplify $
154 Filter.Read.get_Forall_Filter_GL_Decimal <$> flt)
155 }) $
156 C.translate c Lang.Type_Filter_General_Ledger) $
157 C.translate c Lang.Help_Option_Filter_General_Ledger
158 {-, Option "p" ["filter-posting"]
159 (ReqArg (\s ctx -> do
160 ctx_filter_posting <-
161 liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
162 liftIO $ Filter.Read.read Filter.Read.filter_posting s
163 >>= \f -> case f of
164 Left ko -> Write.fatal c $ ko
165 Right ok -> return ok
166 return $ ctx{ctx_filter_posting}) $
167 C.translate c Lang.Type_Filter_Posting) $
168 C.translate c Lang.Help_Option_Filter_Posting
169 -}
170 , Option "t" ["filter-transaction"]
171 (ReqArg (\s ctx -> do
172 filter <-
173 R.runParserT_with_Error
174 Filter.Read.filter_transaction
175 Filter.Read.context "" s
176 case filter of
177 Left ko -> Write.fatal c ko
178 Right flt ->
179 return $
180 ctx{ctx_filter_transaction =
181 Filter.and (ctx_filter_transaction ctx) $
182 (Filter.simplify $
183 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
184 }) $
185 C.translate c Lang.Type_Filter_Transaction) $
186 C.translate c Lang.Help_Option_Filter_Transaction
187 , Option "h" ["help"]
188 (NoArg (\_ctx -> do
189 usage c >>= IO.hPutStr IO.stderr
190 exitSuccess)) $
191 C.translate c Lang.Help_Option_Help
192 , Option "i" ["input"]
193 (ReqArg (\s ctx -> do
194 return $ ctx{ctx_input=s:ctx_input ctx}) $
195 C.translate c Lang.Type_File_Journal) $
196 C.translate c Lang.Help_Option_Input
197 , Option "f" ["input-format"]
198 (OptArg (\arg ctx -> do
199 ctx_input_format <- case arg of
200 Nothing -> return $ Format_JCC ()
201 Just "jcc" -> return $ Format_JCC ()
202 Just "ledger" -> return $ Format_Ledger ()
203 Just _ -> Write.fatal c $
204 W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
205 return $ ctx{ctx_input_format})
206 "[jcc|ledger]")
207 "input format"
208 , Option "o" ["output"]
209 (ReqArg (\s ctx -> do
210 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
211 C.translate c Lang.Type_File) $
212 C.translate c Lang.Help_Option_Output
213 , Option "F" ["output-format"]
214 (ReqArg (\arg ctx -> do
215 ctx_output_format <- case arg of
216 "jcc" -> return $ Just $ Format_JCC ()
217 "ledger" -> return $ Just $ Format_Ledger ()
218 _ -> Write.fatal c $
219 W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
220 return $ ctx{ctx_output_format})
221 "[jcc|ledger]") $
222 "output format"
223 , Option "O" ["overwrite"]
224 (ReqArg (\s ctx -> do
225 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
226 C.translate c Lang.Type_File) $
227 C.translate c Lang.Help_Option_Overwrite
228 {- NOTE: not used so far.
229 , Option "" ["reduce-date"]
230 (OptArg (\arg c ctx -> do
231 ctx_reduce_date <- case arg of
232 Nothing -> return $ True
233 Just "yes" -> return $ True
234 Just "no" -> return $ False
235 Just _ -> Write.fatal c $
236 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
237 return $ ctx{ctx_reduce_date})
238 "[yes|no]")
239 "use advanced date reducer to speed up filtering"
240 -}
241 ]
242
243 run :: C.Context -> [String] -> IO ()
244 run c args = do
245 (ctx, inputs) <-
246 first (\x ->
247 case ctx_output x of
248 [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
249 _ -> x) <$>
250 Args.parse c usage options (context, args)
251 input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
252 read_journals <- mapM (liftIO . journal_read ctx) input_paths
253 case partitionEithers read_journals of
254 (errs@(_:_), _journals) -> Write.fatals c errs
255 ([], (journals::[Forall_Journal_GL])) -> do
256 let gl =
257 mconcat $
258 fmap Format.journal_flatten $
259 case ctx_output_format ctx of
260 Just f -> Format.journal_empty f:journals
261 Nothing -> journals
262 with_color <- Write.with_color c IO.stdout
263 W.displayIO IO.stdout $
264 W.renderPretty with_color 1.0 maxBound $
265 toDoc () $ Leijen.Table.table_of (c, ctx) gl
266 {-
267 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
268 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
269 Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
270 -}
271
272 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_GL where
273 table_of (c, ctx) gl =
274 let lang = C.lang c in
275 zipWith id
276 [ Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
277 , Leijen.Table.column (Lang.translate lang Lang.Title_Date) Leijen.Table.Align_Left
278 , Leijen.Table.column (Lang.translate lang Lang.Title_Debit) Leijen.Table.Align_Right
279 , Leijen.Table.column (Lang.translate lang Lang.Title_Credit) Leijen.Table.Align_Right
280 , Leijen.Table.column (Lang.translate lang Lang.Title_Running_debit) Leijen.Table.Align_Right
281 , Leijen.Table.column (Lang.translate lang Lang.Title_Running_credit) Leijen.Table.Align_Right
282 , Leijen.Table.column (Lang.translate lang Lang.Title_Running_balance) Leijen.Table.Align_Right
283 , Leijen.Table.column (Lang.translate lang Lang.Title_Description) Leijen.Table.Align_Left
284 ] $
285 Format.journal_leijen_table_cells
286 (Format.journal_filter ctx $
287 (Const::x -> Const x ()) gl) $
288 repeat []
289
290
291 -- * 'GL.GL'
292
293 -- ** Type 'Format_GL'
294
295 type Format_Journal_GL
296 = Format
297 ( JCC.Journal GL_JCC)
298 (Ledger.Journal GL_Ledger)
299
300 -- JCC
301 type GL_JCC
302 = GL.GL (JCC.Charted JCC.Transaction)
303 -- = GL.GL JCC.Transaction
304 instance Format.Journal (JCC.Journal GL_JCC) where
305 type Journal_Format (JCC.Journal GL_JCC)
306 = Format_Journal_GL
307 journal_format = Format_JCC
308
309 -- Ledger
310 type GL_Ledger
311 -- = GL.GL Ledger.Transaction
312 = GL.GL (Ledger.Charted Ledger.Transaction)
313 instance Format.Journal (Ledger.Journal GL_Ledger) where
314 type Journal_Format (Ledger.Journal GL_Ledger)
315 = Format_Journal_GL
316 journal_format = Format_Ledger
317
318 -- ** Class 'Journal'
319
320 class
321 ( Format.Journal_Read j
322 , Ord (Account.Account_Section (Format.Journal_Account j))
323 , Leijen.Table.Cell_of_forall_param j
324 (TreeMap.Path (Account.Account_Section
325 (GL.Posting_Account (Format.Journal_Posting j))))
326 , Leijen.Table.Cell_of_forall_param j
327 (Format.Journal_Unit j, Format.Journal_Quantity j)
328 , Leijen.Table.Cell_of_forall_param j
329 (TreeMap.Path (Account.Account_Section (GL.Posting_Account
330 (Chart.Charted (Format.Journal_Account j)
331 (Format.Journal_Posting j)))))
332 , Polarize.Polarizable (Format.Journal_Quantity j)
333 ) => Journal j
334 where
335 journal_transaction_wording
336 :: forall m. j m
337 -> Format.Journal_Transaction j
338 -> Text
339 journal_posting_amounts
340 :: forall m. j m
341 -> Format.Journal_Posting j
342 -> Map (Format.Journal_Unit j)
343 (Format.Journal_Quantity j)
344 journal_posting_amounts_set
345 :: forall m. j m
346 -> Map (Format.Journal_Unit j)
347 (Format.Journal_Quantity j)
348 -> Format.Journal_Posting j
349 -> Format.Journal_Posting j
350
351 instance Journal JCC.Journal
352 where
353 journal_transaction_wording _j = JCC.transaction_wording
354 journal_posting_amounts _j = JCC.posting_amounts
355 journal_posting_amounts_set _j posting_amounts p =
356 p { JCC.posting_amounts }
357 instance Journal Ledger.Journal
358 where
359 journal_transaction_wording _j = Ledger.transaction_wording
360 journal_posting_amounts _j = Ledger.posting_amounts
361 journal_posting_amounts_set _j posting_amounts p =
362 p { Ledger.posting_amounts }
363
364 -- ** Class 'Journal_GL'
365
366 class
367 ( Format.Journal (j m)
368 , Format.Journal_Format (j m) ~ Format_Journal_GL
369 , Format.Journal_Read j
370 , Format.Journal_Monoid (j m)
371 , Format.Journal_Leijen_Table_Cells j m
372 , Format.Journal_Filter Context j m
373 ) => Journal_GL j m
374
375 instance Journal_GL JCC.Journal GL_JCC
376 instance Journal_GL Ledger.Journal GL_Ledger
377
378 -- ** Type 'Forall_Journal_GL'
379
380 data Forall_Journal_GL
381 = forall j m. Journal_GL j m
382 => Forall_Journal_GL (j m)
383
384 instance Format.Journal Forall_Journal_GL where
385 type Journal_Format Forall_Journal_GL = Format_Journal_GL
386 journal_format
387 (Forall_Journal_GL j) =
388 Format.journal_format j
389 instance Format.Journal_Empty Forall_Journal_GL where
390 journal_empty f =
391 case f of
392 Format_JCC () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
393 Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
394 instance Format.Journal_Monoid Forall_Journal_GL where
395 journal_flatten
396 (Forall_Journal_GL j) =
397 Forall_Journal_GL $
398 Format.journal_flatten j
399 journal_fold f (Forall_Journal_GL j) =
400 Format.journal_fold (f . Forall_Journal_GL) j
401 instance Monoid Forall_Journal_GL where
402 mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
403 mappend x y =
404 case (mappend `on` Format.journal_format) x y of
405 Format_JCC j -> Forall_Journal_GL j
406 Format_Ledger j -> Forall_Journal_GL j
407 mconcat js =
408 case js of
409 [] -> mempty
410 j:jn -> foldl' mappend j jn
411
412
413 -- *** 'journal_read'
414
415 type Journal_Filter_Simplified transaction
416 = Filter.Simplified
417 (Filter.Filter_Bool
418 (Filter.Filter_Transaction transaction))
419 type Journal_Read_Cons txn
420 = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
421 journal_read
422 :: Context -> FilePath
423 -> IO (Either (Format.Message W.Doc) Forall_Journal_GL)
424 journal_read ctx =
425 case ctx_input_format ctx of
426 Format_JCC () ->
427 let wrap (j::JCC.Journal GL_JCC)
428 = Forall_Journal_GL j in
429 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
430 = Filter.Filtered (ctx_filter_transaction ctx) in
431 liftM ((+++) Format.Message wrap) .
432 Format.journal_read cons
433 Format_Ledger () ->
434 let wrap (j::Ledger.Journal GL_Ledger)
435 = Forall_Journal_GL j in
436 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
437 = Filter.Filtered (ctx_filter_transaction ctx) in
438 liftM ((+++) Format.Message wrap) .
439 Format.journal_read cons
440
441
442 -- Instances 'Format.Journal_Filter'
443
444 instance
445 ( Functor j
446 , Format.Journal_Chart j
447 , Journal j
448 , Journal_GL j (GL.GL t)
449 , GL.Transaction t
450 , Format.Journal_Account_Section j ~ Text
451 , GL.Transaction_Posting t
452 ~ Chart.Charted (Format.Journal_Account j)
453 (Format.Journal_Posting j)
454 , GL.Posting_Quantity (GL.Transaction_Posting t)
455 ~ Map (Format.Journal_Unit j)
456 (Polarized (Format.Journal_Quantity j))
457 , Format.Journal_Quantity j ~ Decimal
458 , Format.Journal_Account_Section j
459 ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
460 , Ord (Format.Journal_Unit j)
461 , Unit.Unit (Format.Journal_Unit j)
462 ) => Format.Journal_Filter Context j (GL.GL t) where
463 journal_filter ctx j =
464 GL.GL .
465 TreeMap.map_Maybe_with_Path
466 (\acct expanded_lines ->
467 let chart = Format.journal_chart j in
468 case Map.mapMaybeWithKey
469 (\date seq_lines ->
470 case foldMap
471 (\line@GL.GL_Line
472 { GL.gl_line_transaction = _t
473 , GL.gl_line_posting = p
474 , GL.gl_line_sum = s
475 } ->
476 Map.foldlWithKey
477 (\acc unit qty ->
478 let sqty = (Map.!) s unit in
479 if Filter.test (ctx_filter_gl ctx)
480 ( (Chart.account_tags acct chart, acct)
481 , date
482 , (unit, Polarize.polarize qty)
483 , (unit, sqty)
484 )
485 then (Seq.|>) acc line
486 { GL.gl_line_posting =
487 journal_posting_amounts_set j
488 (Map.singleton unit qty) <$> p
489 , GL.gl_line_sum = Map.singleton unit sqty
490 }
491 else acc
492 )
493 Seq.empty
494 (journal_posting_amounts j $ Chart.charted p)
495 ) seq_lines
496 of
497 m | Seq.null m -> Nothing
498 m -> Just m
499 )
500 (GL.inclusive expanded_lines)
501 of
502 m | Map.null m -> Strict.Nothing
503 m -> Strict.Just m
504 ) .
505 (\(GL.Expanded gl) -> gl) .
506 GL.expanded <$> j
507 instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
508 journal_filter ctx
509 (Const (Forall_Journal_GL j)) =
510 Const $ Forall_Journal_GL $
511 Format.journal_filter ctx j
512
513 -- Instances 'Format.Journal_Leijen_Table_Cells'
514
515 instance
516 ( Format.Journal_Content j
517 , Journal j
518
519 , Quantity.Addable (Format.Journal_Quantity j)
520 , GL.Transaction_Posting t
521 ~ Chart.Charted (Format.Journal_Account j)
522 (Format.Journal_Posting j)
523 , Format.Journal_Transaction j ~ GL.Transaction_Line t
524 , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
525 (Format.Journal_Posting j))
526 ~ Map (Format.Journal_Unit j)
527 (Polarized (Format.Journal_Quantity j))
528 , GL.Posting_Quantity (Format.Journal_Posting j)
529 ~ Map (Format.Journal_Unit j)
530 (Polarized (Format.Journal_Quantity j))
531 -- , GL.Posting_Account t ~ Format.Journal_Account j
532 -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
533 , Leijen.Table.Cell_of_forall_param j Date
534 , Leijen.Table.Cell_of_forall_param j Text
535 , Ord (Format.Journal_Unit j)
536 , GL.Transaction t
537 ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
538 journal_leijen_table_cells jnl =
539 flip (TreeMap.foldr_with_Path
540 (\account ->
541 flip $ Map.foldrWithKey
542 (\date ->
543 flip $ foldr
544 (\GL.GL_Line
545 { GL.gl_line_transaction = t
546 , GL.gl_line_posting = p
547 , GL.gl_line_sum = s
548 } ->
549 flip (Map.foldrWithKey
550 (\unit qty ->
551 let ms = Map.lookup unit s in
552 zipWith (:)
553 [ cell_of account
554 , cell_of date
555 , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
556 , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
557 , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
558 , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
559 , cell_of $ (unit,) . Polarize.depolarize <$> ms
560 , cell_of $ journal_transaction_wording jnl t
561 ]
562 ))
563 (journal_posting_amounts jnl $ Chart.charted p)
564 )
565 )
566 )) $
567 (\(GL.GL x) -> x)
568 (Format.journal_content jnl)
569 where
570 cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
571 cell_of = Leijen.Table.cell_of_forall_param jnl
572
573 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_GL) () where
574 journal_leijen_table_cells
575 (Const (Forall_Journal_GL j)) =
576 Format.journal_leijen_table_cells j
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601 {-
602 -- Instances GL.GL -> GL.Expanded
603
604 instance
605 ( Functor j
606 , Journal_GL_Expanded j (GL.Expanded t)
607
608 -- NOTE: constraint from GL.expanded
609 , GL.Transaction t
610 ) => Format.Journal_Wrap (j (GL.GL t))
611 Forall_Journal_GL_Expanded where
612 journal_wrap =
613 Forall_Journal_GL_Expanded .
614 fmap GL.expanded
615
616 instance Format.Journal_Wrap Forall_Journal_GL
617 Forall_Journal_GL_Expanded where
618 journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
619 -}
620 {-
621 -- * 'GL.GL_Expanded'
622
623 -- ** Type 'Format_GL_Expanded'
624
625 type Format_Journal_GL_Expanded
626 = Format
627 ( JCC.Journal GL_Expanded_JCC)
628 (Ledger.Journal GL_Expanded_Ledger)
629
630 -- JCC
631 type GL_Expanded_JCC
632 = GL.Expanded (JCC.Charted JCC.Transaction)
633 instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
634 type Journal_Format (JCC.Journal GL_Expanded_JCC)
635 = Format_Journal_GL_Expanded
636 journal_format = Format_JCC
637
638 -- Ledger
639 type GL_Expanded_Ledger
640 = GL.Expanded (Ledger.Charted Ledger.Transaction)
641 instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
642 type Journal_Format (Ledger.Journal GL_Expanded_Ledger)
643 = Format_Journal_GL_Expanded
644 journal_format = Format_Ledger
645
646 -- ** Class 'Journal_GL_Expanded'
647
648 class
649 ( Format.Journal (j m)
650 , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
651 -- , Format.Journal_Leijen_Table_Cells j m
652 , Format.Journal_Filter Context j m
653 ) => Journal_GL_Expanded j m where
654 journal_posting_amounts
655 :: j m
656 -> Format.Journal_Posting j
657 -> Map (Format.Journal_Unit j)
658 (Format.Journal_Quantity j)
659 journal_posting_amounts_set
660 :: j m
661 -> Map (Format.Journal_Unit j)
662 (Format.Journal_Quantity j)
663 -> Format.Journal_Posting j
664 -> Format.Journal_Posting j
665
666 instance Journal_GL_Expanded JCC.Journal GL_Expanded_JCC
667 where
668 journal_posting_amounts _j = JCC.posting_amounts
669 journal_posting_amounts_set _j posting_amounts p =
670 p { JCC.posting_amounts }
671 instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
672 where
673 journal_posting_amounts _j = Ledger.posting_amounts
674 journal_posting_amounts_set _j posting_amounts p =
675 p { Ledger.posting_amounts }
676
677 -- ** Type 'Forall_Journal_GL_Expanded'
678
679 data Forall_Journal_GL_Expanded
680 = forall j m. Journal_GL_Expanded j m
681 => Forall_Journal_GL_Expanded (j m)
682
683 instance Format.Journal Forall_Journal_GL_Expanded where
684 type Journal_Format Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
685 journal_format
686 (Forall_Journal_GL_Expanded j) =
687 Format.journal_format j
688
689 -- Instances 'Format.Journal_Filter'
690
691 instance
692 ( Functor j
693 , Format.Journal_Chart j
694 , Journal_GL_Expanded j (GL.Expanded t)
695 , GL.Transaction t
696 , Format.Journal_Account_Section j ~ Text
697 , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
698 , GL.Posting_Quantity (GL.Transaction_Posting t)
699 ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
700 , Format.Journal_Quantity j ~ Decimal
701 , Format.Journal_Account_Section j
702 ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
703 , Ord (Format.Journal_Unit j)
704 , Unit.Unit (Format.Journal_Unit j)
705 ) => Format.Journal_Filter Context j (GL.Expanded t) where
706 journal_filter ctx j =
707 GL.Expanded .
708 TreeMap.map_Maybe_with_Path
709 (\acct expanded_lines ->
710 let chart = Format.journal_chart j in
711 case Map.mapMaybeWithKey
712 (\date seq_lines ->
713 case foldMap
714 (\line@GL.GL_Line
715 { GL.gl_line_transaction = _t
716 , GL.gl_line_posting = Chart.Charted ch p
717 , GL.gl_line_sum = s
718 } ->
719 Map.foldlWithKey
720 (\acc unit qty ->
721 let sqty = (Map.!) s unit in
722 if Filter.test (ctx_filter_gl ctx)
723 ( (Chart.account_tags acct chart, acct)
724 , date
725 , (unit, Polarize.polarize qty)
726 , (unit, sqty)
727 )
728 then (Seq.|>) acc line
729 { GL.gl_line_posting =
730 Chart.Charted ch $
731 journal_posting_amounts_set j
732 (Map.singleton unit qty) p
733 , GL.gl_line_sum = Map.singleton unit sqty
734 }
735 else acc
736 )
737 Seq.empty
738 (journal_posting_amounts j p)
739 ) seq_lines
740 of
741 m | Seq.null m -> Nothing
742 m -> Just m
743 )
744 (GL.inclusive expanded_lines)
745 of
746 m | Map.null m -> Strict.Nothing
747 m -> Strict.Just $ expanded_lines { GL.inclusive=m }
748 ) .
749 (\(GL.Expanded gl) -> gl) <$> j
750
751 instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
752 journal_filter ctx
753 (Const (Forall_Journal_GL_Expanded j)) =
754 Const $ Forall_Journal_GL_Expanded $
755 Format.journal_filter ctx j
756 -}
757
758 {-
759 run :: C.Context -> [String] -> IO ()
760 run c args = do
761 (ctx, inputs) <-
762 first (\x ->
763 case ctx_output x of
764 [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
765 _ -> x) <$>
766 Args.parse c usage options (context, args)
767 read_journals <-
768 liftM partitionEithers $ do
769 CLI.Env.paths c $ ctx_input ctx ++ inputs
770 >>= do
771 mapM $ \path -> do
772 liftIO $ runExceptT $ Ledger.Read.file
773 (Ledger.Read.context ( ctx_filter_transaction ctx
774 , ctx_filter_posting ctx )
775 Ledger.journal)
776 path
777 >>= \x -> case x of
778 Left ko -> return $ Left (path, ko)
779 Right ok -> return $ Right ok
780 case read_journals of
781 (errs@(_:_), _journals) ->
782 forM_ errs $ \(_path, err) -> do
783 Write.fatal c $ err
784 ([], journals) -> do
785 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
786 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
787 Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
788 let (amount_styles, gl) = ledger_gl ctx journals
789 let lang = C.lang c
790 Write.write c Write.style (ctx_output ctx) $ do
791 toDoc () $ do
792 zipWith id
793 [ Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left
794 , Table.column (Lang.translate lang Lang.Title_Date) Table.Align_Left
795 , Table.column (Lang.translate lang Lang.Title_Debit) Table.Align_Right
796 , Table.column (Lang.translate lang Lang.Title_Credit) Table.Align_Right
797 , Table.column (Lang.translate lang Lang.Title_Running_debit) Table.Align_Right
798 , Table.column (Lang.translate lang Lang.Title_Running_credit) Table.Align_Right
799 , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
800 , Table.column (Lang.translate lang Lang.Title_Description) Table.Align_Left
801 ] $ do
802 write_gl amount_styles gl (repeat [])
803 -}
804
805 {-
806 ledger_gl
807 :: Context
808 -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
809 -> ( Ledger.Amount.Styles
810 , GL (Ledger.Charted Ledger.Transaction)
811 )
812 ledger_gl ctx journals =
813 let (_chart, amount_styles, gl) =
814 foldl'
815 (flip (\j ->
816 flip mappend $
817 ( Ledger.journal_chart j
818 , Ledger.journal_amount_styles j
819 , ) $
820 Ledger.Journal.fold
821 (\Ledger.Journal
822 { Ledger.journal_sections=g
823 } -> mappend g
824 ) j mempty
825 ))
826 mempty journals in
827 (amount_styles,) $
828 GL.GL $
829 TreeMap.map_Maybe_with_Path
830 (\acct expanded_lines ->
831 case Map.mapMaybeWithKey
832 (\date seq_lines ->
833 case foldMap
834 (\line@GL.GL_Line
835 { GL.gl_line_transaction = _t
836 , GL.gl_line_posting = Ledger.Charted c p
837 , GL.gl_line_sum = s
838 } ->
839 Map.foldlWithKey
840 (\acc unit qty ->
841 let sqty = (Map.!) s unit in
842 if Filter.test (ctx_filter_gl ctx)
843 ( (Chart.account_tags acct c, acct)
844 , date
845 , (unit, Polarize.polarize qty)
846 , (unit, sqty)
847 )
848 then (Seq.|>) acc line
849 { GL.gl_line_posting = Ledger.Charted c p
850 { Ledger.posting_amounts = Map.singleton unit qty }
851 , GL.gl_line_sum = Map.singleton unit sqty
852 }
853 else acc
854 )
855 Seq.empty
856 (Ledger.posting_amounts p)
857 ) seq_lines of
858 m | Seq.null m -> Nothing
859 m -> Just m
860 )
861 (GL.inclusive expanded_lines) of
862 m | Map.null m -> Strict.Nothing
863 m -> Strict.Just m
864 ) $
865 GL.expanded gl
866
867 write_gl
868 :: Ledger.Amount.Styles
869 -> GL (Ledger.Charted Ledger.Transaction)
870 -> [[Table.Cell]]
871 -> [[Table.Cell]]
872 write_gl amount_styles (GL gl) =
873 flip (TreeMap.foldr_with_Path
874 (\acct ->
875 flip $ Map.foldrWithKey
876 (\date ->
877 flip (foldr
878 (\GL.GL_Line
879 { GL.gl_line_transaction = Ledger.Charted _ t
880 , GL.gl_line_posting = Ledger.Charted _ p
881 , GL.gl_line_sum = s
882 } ->
883 flip (Map.foldrWithKey
884 (\unit qty ->
885 let ms = Map.lookup unit s in
886 zipWith (:)
887 [ let ptype = Ledger.Posting_Type_Regular in
888 Table.cell
889 { Table.cell_content = Ledger.Write.account ptype acct
890 , Table.cell_width = Ledger.Write.account_length ptype acct
891 }
892 , Table.cell
893 { Table.cell_content = Date.Write.date date
894 , Table.cell_width = Date.Write.date_length date
895 }
896 , cell_amount unit (Polarize.polarizable_positive qty)
897 , cell_amount unit (Polarize.polarizable_negative qty)
898 , cell_amount unit (ms >>= Polarize.polarized_positive)
899 , cell_amount unit (ms >>= Polarize.polarized_negative)
900 , cell_amount unit (liftM Polarize.depolarize ms)
901 , let descr = Ledger.transaction_wording t in
902 Table.cell
903 { Table.cell_content = toDoc () descr
904 , Table.cell_width = Text.length descr
905 }
906 ]
907 ))
908 (Ledger.posting_amounts p)
909 ))
910 )
911 ))
912 gl
913 where
914 cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
915 cell_amount unit mq =
916 case mq of
917 Nothing -> Table.cell
918 Just q ->
919 let a = Ledger.Amount.Amount unit q in
920 let sa = Ledger.Amount.style amount_styles a in
921 Table.cell
922 { Table.cell_content = Amount.Write.amount sa
923 , Table.cell_width = Amount.Write.amount_length sa
924 }
925 -}