1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TypeFamilies #-}
11 module Hcompta.CLI.Format where
13 import Control.Applicative (Const(..))
14 import Control.Monad.Trans.Except (runExceptT)
15 import Data.Bool (Bool(..), not)
16 import qualified Data.Char as Char
17 import Data.Decimal (Decimal)
18 import Data.Either (Either(..))
19 import Data.Function (($), (.), id)
20 import Data.Functor (Functor(..), (<$>))
21 import qualified Data.List as List
22 import Data.List.NonEmpty (NonEmpty(..))
23 import qualified Data.Map.Strict as Map
24 import Data.Map.Strict (Map)
25 import Data.Maybe (Maybe(..))
26 import Data.Monoid (Monoid(..))
27 import Data.Ord (Ord(..))
28 import Data.Sequence (Seq)
29 import qualified Data.Text as Text
30 import Data.Text (Text)
31 import System.IO (FilePath, IO)
32 import Text.Show (Show)
34 import qualified Hcompta.CLI.Lang as Lang
35 import qualified Hcompta.Lib.Leijen as W
36 import qualified Hcompta.Lib.TreeMap as TreeMap
37 import Hcompta.Lib.TreeMap (TreeMap)
38 import qualified Hcompta.Journal as Journal
39 import qualified Hcompta.Tag as Tag
40 import qualified Hcompta.Balance as Balance
41 import qualified Hcompta.GL as GL
42 import qualified Hcompta.Stats as Stats
43 import qualified Hcompta.Chart as Chart
44 import qualified Hcompta.Account as Account
45 import qualified Hcompta.Posting as Posting
46 import qualified Hcompta.Transaction as Transaction
47 -- import qualified Hcompta.Filter.Read as Filter.Read
48 import Hcompta.Date (Date)
49 import qualified Hcompta.Polarize as Polarize
50 import qualified Hcompta.Format.JCC as JCC
51 import qualified Hcompta.Format.JCC.Journal as JCC.Journal
52 import qualified Hcompta.Format.JCC.Read as JCC.Read
53 import qualified Hcompta.Format.JCC.Amount.Style as JCC.Amount.Style
54 import qualified Hcompta.Format.Ledger as Ledger
55 import qualified Hcompta.Format.Ledger.Read as Ledger
56 import qualified Hcompta.Lib.Parsec as R
57 import Hcompta.Lib.Consable (Consable)
58 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
62 data Format jcc ledger
64 | Format_Ledger ledger
66 type Formats = Format () ()
73 ) => Monoid (Format jcc ledger) where
74 mempty = Format_JCC mempty
80 Format_JCC yj -> mappend xj yj
81 Format_Ledger yj -> mappend xj (convert yj)
85 Format_JCC yj -> mappend xj (convert yj)
86 Format_Ledger yj -> mappend xj yj
89 format = Format_JCC ()
91 -- * Type family 'Journal_Account'
92 type family Journal_Account (j:: * -> *)
93 type instance Journal_Account JCC.Journal = JCC.Account
94 type instance Journal_Account Ledger.Journal = Ledger.Account
96 -- * Type family 'Journal_Account_Section'
97 type family Journal_Account_Section (j:: * -> *)
98 type instance Journal_Account_Section JCC.Journal = JCC.Account_Section
99 type instance Journal_Account_Section Ledger.Journal = Ledger.Account_Section
101 -- * Type family 'Journal_Charted'
102 type family Journal_Charted (j:: * -> *) :: * -> *
103 type instance Journal_Charted JCC.Journal = JCC.Charted
104 type instance Journal_Charted Ledger.Journal = Ledger.Charted
106 -- * Type family 'Journal_Quantity'
107 type family Journal_Quantity (j:: * -> *)
108 type instance Journal_Quantity JCC.Journal = JCC.Quantity
109 type instance Journal_Quantity Ledger.Journal = Ledger.Quantity
111 -- * Type family 'Journal_Unit'
112 type family Journal_Unit (j:: * -> *)
113 type instance Journal_Unit JCC.Journal = JCC.Unit
114 type instance Journal_Unit Ledger.Journal = Ledger.Unit
116 -- * Type family 'Journal_Posting'
117 type family Journal_Posting (j:: * -> *)
118 type instance Journal_Posting JCC.Journal = JCC.Posting
119 type instance Journal_Posting Ledger.Journal = Ledger.Posting
121 -- * Type family 'Journal_Transaction'
122 type family Journal_Transaction (j:: * -> *)
123 type instance Journal_Transaction JCC.Journal = JCC.Transaction
124 type instance Journal_Transaction Ledger.Journal = Ledger.Transaction
128 class Journal j where
129 type Journal_Format j
131 :: j -> Journal_Format j
133 -- * Class 'Journal_Empty'
135 class Journal_Empty j where
136 journal_empty :: Formats -> j
138 -- * Class 'Journal_Files'
140 class Journal_Files j where
141 journal_files :: forall m. j m -> [FilePath]
142 instance Journal_Files JCC.Journal where
143 journal_files j = [JCC.journal_file j] -- FIXME: JCC.journal_files
144 instance Journal_Files Ledger.Journal where
145 journal_files = Ledger.journal_files
147 -- * Class 'Journal_Read'
149 class Journal_Read (j:: * -> *) where
150 type Journal_Read_Error j
151 type Journal_Read_Transaction j
153 :: forall c m. (Monoid m, Consable c m)
154 => (Journal_Read_Transaction j -> c)
156 -> IO (Either (Journal_Read_Error j) (j m))
157 instance Journal_Read JCC.Journal where
158 type Journal_Read_Error JCC.Journal
159 = [R.Error JCC.Read.Error]
160 type Journal_Read_Transaction JCC.Journal
161 = JCC.Charted JCC.Transaction
163 runExceptT . JCC.Read.file
164 (JCC.Read.context cons JCC.journal)
165 instance Journal_Read Ledger.Journal where
166 type Journal_Read_Error Ledger.Journal
167 = [R.Error Ledger.Read_Error]
168 type Journal_Read_Transaction Ledger.Journal
169 = Ledger.Charted Ledger.Transaction
171 runExceptT . Ledger.read
172 (Ledger.read_context cons Ledger.journal)
174 -- * Class 'Journal_Chart'
176 class Journal_Chart (j:: * -> *) where
179 -> Chart.Chart (NonEmpty (Journal_Account_Section j))
180 instance Journal_Chart JCC.Journal where
181 journal_chart = JCC.journal_chart
182 instance Journal_Chart Ledger.Journal where
183 journal_chart = Ledger.journal_chart
185 -- * Class 'Journal_Monoid'
187 class Journal_Monoid j where
188 journal_flatten :: j -> j
189 journal_fold :: (j -> a -> a) -> j -> a -> a
190 instance Monoid m => Journal_Monoid (JCC.Journal m) where
191 journal_flatten = JCC.Journal.flatten
192 journal_fold = JCC.Journal.fold
193 instance Monoid m => Journal_Monoid (Ledger.Journal m) where
194 journal_flatten = Ledger.journal_flatten
195 journal_fold = Ledger.journal_fold
197 -- * Class 'Journal_Filter'
199 class Functor j => Journal_Filter context j m where
201 :: context -> j m -> j m
203 -- * Class 'Journal_Functor'
205 class Journal_Functor x y where
206 journal_functor_map :: x -> y
207 journal_fmap :: forall j. Functor j => j x -> j y
208 journal_fmap = fmap journal_functor_map
210 -- * Class 'Journal_Table'
212 -- | A class to render a journal
213 -- into 'Leijen.Table.Cell's.
214 class Journal_Leijen_Table_Cells j m where
215 journal_leijen_table_cells
217 -> [[Leijen.Table.Cell]]
218 -> [[Leijen.Table.Cell]]
221 -- * Class 'Journal_Wrap'
223 -- | A class dedicated to transform a journal
224 -- to another one using existential quantification
225 -- to gather multiple journals under a single type,
226 -- by writing instances between fully monomorphic types,
227 -- which ease a lot meeting the requirements
228 -- of the constraints in the wrap type.
229 class Journal_Wrap j wrap where
230 journal_wrap :: j -> wrap
232 class Journal_Content j where
233 journal_content :: forall m. j m -> m
234 instance Journal_Content JCC.Journal where
235 journal_content = JCC.journal_content
236 instance Journal_Content Ledger.Journal where
237 journal_content = Ledger.journal_content
241 -- data Journal jnl m = forall j. jnl j => Journal (j m)
242 data Message w = forall msg. Lang.Translate msg w => Message msg
243 instance Lang.Translate (Message W.Doc) W.Doc where
244 translate lang (Message x) = Lang.translate lang x
248 -- | Generic class dedicated to transform any type
249 -- into another one encoding more or less
251 class Convert from to where
252 convert :: from -> to
254 instance Convert () () where
263 => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
264 convert Ledger.Journal
265 { Ledger.journal_amount_styles
266 , Ledger.journal_chart = chart
267 , Ledger.journal_files=jf
268 , Ledger.journal_includes
269 , Ledger.journal_last_read_time
270 , Ledger.journal_content = content
272 { JCC.journal_amount_styles = convert journal_amount_styles
273 , JCC.journal_chart = chart
274 , JCC.journal_file = List.head jf -- FIXME: JCC.journal_files
275 , JCC.journal_includes = fmap convert $ journal_includes
276 , JCC.journal_last_read_time
277 , JCC.journal_content = convert content
284 => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
286 { JCC.journal_amount_styles
287 , JCC.journal_chart = chart
289 , JCC.journal_includes
290 , JCC.journal_last_read_time
291 , JCC.journal_content = content
293 { Ledger.journal_amount_styles = convert journal_amount_styles
294 , Ledger.journal_chart = chart
295 , Ledger.journal_files = [journal_file] -- FIXME: JCC.journal_files
296 , Ledger.journal_includes = fmap convert $ journal_includes
297 , Ledger.journal_last_read_time
298 , Ledger.journal_content = convert content
300 instance Convert ledger jcc
302 (Journal.Journal ledger)
303 (Journal.Journal jcc)
305 convert (Journal.Journal j) =
308 Map.mapKeysMonotonic convert j
311 instance Convert Ledger.Unit JCC.Unit where
312 convert (Ledger.Unit u) =
315 (\c -> case Char.generalCategory c of
316 Char.CurrencySymbol -> c
317 Char.LowercaseLetter -> c
318 Char.ModifierLetter -> c
319 Char.OtherLetter -> c
320 Char.TitlecaseLetter -> c
321 Char.UppercaseLetter -> c
323 instance Convert JCC.Unit Ledger.Unit where
324 convert (JCC.Unit u) =
328 instance Convert Account.Account_Anchor Account.Account_Anchor where
330 instance Convert Account.Account_Tags Account.Account_Tags where
334 instance Convert Ledger.Amount_Styles JCC.Styles where
335 convert (Ledger.Amount_Styles sty) =
336 JCC.Amount.Style.Styles $ convert sty
337 instance Convert JCC.Styles Ledger.Amount_Styles where
338 convert (JCC.Amount.Style.Styles sty) =
339 Ledger.Amount_Styles $ convert sty
340 instance Convert Ledger.Amount_Style JCC.Style where
341 convert Ledger.Amount_Style
342 { Ledger.amount_style_fractioning=f
343 , Ledger.amount_style_grouping_integral=gi
344 , Ledger.amount_style_grouping_fractional=gf
345 , Ledger.amount_style_unit_side=unit_side
346 , Ledger.amount_style_unit_spaced=unit_spaced
347 } = JCC.Amount.Style.Style
348 { JCC.Amount.Style.fractioning=f
349 , JCC.Amount.Style.grouping_integral =
350 fmap (\(Ledger.Amount_Style_Grouping c l) ->
351 JCC.Amount.Style.Grouping c l) gi
352 , JCC.Amount.Style.grouping_fractional =
353 fmap (\(Ledger.Amount_Style_Grouping c l) ->
354 JCC.Amount.Style.Grouping c l) gf
355 , JCC.Amount.Style.unit_side =
358 Ledger.Amount_Style_Side_Left -> JCC.Amount.Style.Side_Left
359 Ledger.Amount_Style_Side_Right -> JCC.Amount.Style.Side_Right
361 , JCC.Amount.Style.unit_spaced
363 instance Convert JCC.Style Ledger.Amount_Style where
364 convert JCC.Amount.Style.Style
365 { JCC.Amount.Style.fractioning=f
366 , JCC.Amount.Style.grouping_integral=gi
367 , JCC.Amount.Style.grouping_fractional=gf
368 , JCC.Amount.Style.unit_side=unit_side
369 , JCC.Amount.Style.unit_spaced=unit_spaced
370 } = Ledger.Amount_Style
371 { Ledger.amount_style_fractioning=f
372 , Ledger.amount_style_grouping_integral =
373 fmap (\(JCC.Amount.Style.Grouping c l) ->
374 Ledger.Amount_Style_Grouping c l) gi
375 , Ledger.amount_style_grouping_fractional =
376 fmap (\(JCC.Amount.Style.Grouping c l) ->
377 Ledger.Amount_Style_Grouping c l) gf
378 , Ledger.amount_style_unit_side =
382 JCC.Amount.Style.Side_Left -> Ledger.Amount_Style_Side_Left
383 JCC.Amount.Style.Side_Right -> Ledger.Amount_Style_Side_Right
385 , Ledger.amount_style_unit_spaced=unit_spaced
389 instance Convert Ledger.Transaction JCC.Transaction where
390 convert Ledger.Transaction
391 { Ledger.transaction_code
392 , Ledger.transaction_comments_after
393 , Ledger.transaction_comments_before
394 , Ledger.transaction_dates
395 , Ledger.transaction_postings
396 , Ledger.transaction_sourcepos
397 , Ledger.transaction_status
398 , Ledger.transaction_tags
399 , Ledger.transaction_wording
401 { JCC.transaction_anchors = mempty
402 , JCC.transaction_comments =
403 List.filter (not . Text.all Char.isSpace) $
404 Ledger.comments_without_tags $
406 transaction_comments_before
407 transaction_comments_after
408 , JCC.transaction_dates
409 , JCC.transaction_postings = fmap (fmap convert) transaction_postings
410 , JCC.transaction_sourcepos
411 , JCC.transaction_tags =
412 (case transaction_code of
413 t | Text.null t -> id
414 t -> Transaction.tag_cons (Transaction.tag ("Code":|[]) t)
416 case transaction_status of
417 True -> Transaction.tag_cons
418 (Transaction.tag ("Status":|[]) "")
420 False -> transaction_tags
421 , JCC.transaction_wording
423 instance Convert JCC.Transaction Ledger.Transaction where
424 convert JCC.Transaction
425 { JCC.transaction_anchors=_transaction_anchors
426 , JCC.transaction_comments
427 , JCC.transaction_dates
428 , JCC.transaction_postings
429 , JCC.transaction_sourcepos
430 , JCC.transaction_tags = Transaction.Transaction_Tags (Tag.Tags tags)
431 , JCC.transaction_wording
432 } = Ledger.Transaction
433 { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
434 , Ledger.transaction_comments_after = mempty
435 , Ledger.transaction_comments_before = transaction_comments
436 , Ledger.transaction_dates
437 , Ledger.transaction_postings = fmap (fmap convert) transaction_postings
438 , Ledger.transaction_sourcepos
439 , Ledger.transaction_status =
440 case Map.lookup ("Status":|[]) tags of
443 , Ledger.transaction_tags =
444 Transaction.Transaction_Tags $ Tag.Tags $
445 Map.delete ("Code":|[]) $
446 Map.delete ("Status":|[]) $
448 , Ledger.transaction_wording
452 instance Convert Ledger.Posting JCC.Posting where
453 convert Ledger.Posting
454 { Ledger.posting_account
455 , Ledger.posting_amounts
456 , Ledger.posting_comments
457 , Ledger.posting_dates
458 , Ledger.posting_status
459 , Ledger.posting_sourcepos
460 , Ledger.posting_tags
462 { JCC.posting_account
463 , JCC.posting_account_anchor = Nothing
464 , JCC.posting_amounts =
466 Map.mapKeysMonotonic convert $
468 , JCC.posting_anchors = mempty
469 , JCC.posting_comments =
470 List.filter (not . Text.all Char.isSpace) $
471 Ledger.comments_without_tags posting_comments
473 , JCC.posting_sourcepos
475 case posting_status of
476 True -> Posting.tag_cons
477 (Posting.tag ("Status":|[]) "")
479 False -> posting_tags
481 instance Convert JCC.Posting Ledger.Posting where
483 { JCC.posting_account
484 , JCC.posting_account_anchor=_
485 , JCC.posting_amounts
486 , JCC.posting_anchors = _posting_anchors
487 , JCC.posting_comments
489 , JCC.posting_sourcepos
490 , JCC.posting_tags = Posting.Posting_Tags (Tag.Tags tags)
492 { Ledger.posting_account
493 , Ledger.posting_amounts =
495 Map.mapKeysMonotonic convert $
497 , Ledger.posting_comments
498 , Ledger.posting_dates
499 , Ledger.posting_status =
500 case Map.lookup ("Status":|[]) tags of
503 , Ledger.posting_sourcepos
504 , Ledger.posting_tags =
505 Posting.Posting_Tags $ Tag.Tags $
506 Map.delete ("Status":|[]) $
511 instance Convert (Chart.Chart x) (Chart.Chart x) where
514 instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
516 { Chart.chart_accounts
517 , Chart.chart_anchors
520 { Chart.chart_accounts = convert chart_accounts
521 , Chart.chart_anchors = convert chart_anchors
526 ( Convert (Chart.Chart a0) (Chart.Chart a1)
528 ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
529 convert (Chart.Charted a x) =
530 Chart.Charted (convert a) (convert x)
535 , Convert quantity quantity_
536 ) => Convert (Balance.Account_Sum unit quantity)
537 (Balance.Account_Sum unit_ quantity_) where
538 convert (Balance.Account_Sum m) =
539 Balance.Account_Sum $
541 Map.mapKeysMonotonic convert m
547 ( Convert (Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting x)))
548 (Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting y)))
550 instance GL JCC.Transaction Ledger.Transaction
551 instance GL Ledger.Transaction JCC.Transaction
553 instance GL ( JCC.Charted JCC.Transaction)
554 (Ledger.Charted Ledger.Transaction)
555 instance GL (Ledger.Charted Ledger.Transaction)
556 (JCC.Charted JCC.Transaction)
564 ) => Convert (GL.GL x)
567 = GL.GL $ TreeMap.map_monotonic convert (fmap convert) m
568 -- NOTE: Date does not need to be converted,
569 -- thus avoid a useless Map.mapKeysMonotonic
570 -- from the Convert instance on Map.
572 -- *** Class 'GL_Line'
575 ( Convert (GL.Transaction_Line x)
576 (GL.Transaction_Line y)
577 , Convert (GL.Transaction_Posting x)
578 (GL.Transaction_Posting y)
579 , Convert (GL.Posting_Quantity (GL.Transaction_Posting x))
580 (GL.Posting_Quantity (GL.Transaction_Posting y))
582 instance GL_Line JCC.Transaction Ledger.Transaction
583 instance GL_Line Ledger.Transaction JCC.Transaction
585 instance GL_Line ( JCC.Charted JCC.Transaction)
586 (Ledger.Charted Ledger.Transaction)
587 instance GL_Line (Ledger.Charted Ledger.Transaction)
588 (JCC.Charted JCC.Transaction)
595 ) => Convert (GL.GL_Line x)
598 { GL.gl_line_transaction
602 { GL.gl_line_transaction = convert gl_line_transaction
603 , GL.gl_line_posting = convert gl_line_posting
604 , GL.gl_line_sum = convert gl_line_sum
607 -- Class 'GL_Expanded'
615 ) => Convert (GL.Expanded x)
616 (GL.Expanded y) where
617 convert (GL.Expanded m)
618 = GL.Expanded $ convert m
620 -- Class 'GL_Line_Expanded'
627 ) => Convert (GL.GL_Line_Expanded x)
628 (GL.GL_Line_Expanded y) where
629 convert GL.GL_Line_Expanded
632 } = GL.GL_Line_Expanded
633 { GL.exclusive = convert <$> exclusive
634 , GL.inclusive = convert <$> inclusive
639 => Convert (Const x w) (Const y w_) where
640 convert (Const x) = Const $ convert x
644 => Convert (Polarize.Polarized x)
645 (Polarize.Polarized y) where
646 convert = fmap convert
649 instance Convert Date Date where
653 instance Convert Decimal Decimal where
657 instance Convert Text Text where
661 instance Convert x y => Convert [x] [y] where
662 convert = fmap convert
663 instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
664 convert = fmap convert
668 instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
669 => Convert (TreeMap kx x) (TreeMap ky y) where
670 convert = TreeMap.map_monotonic convert convert
673 instance (Convert kx ky, Convert x y, Ord kx)
674 => Convert (Map kx x) (Map ky y) where
675 convert = Map.mapKeysMonotonic convert . fmap convert
678 instance Convert x y => Convert (Seq x) (Seq y) where
679 convert = fmap convert
685 ( Convert (Stats.Posting_Account (Stats.Transaction_Posting x))
686 (Stats.Posting_Account (Stats.Transaction_Posting y))
687 , Convert (Stats.Posting_Unit (Stats.Transaction_Posting x))
688 (Stats.Posting_Unit (Stats.Transaction_Posting y))
691 instance Stats JCC.Transaction Ledger.Transaction
692 instance Stats Ledger.Transaction JCC.Transaction
694 instance Stats ( JCC.Charted JCC.Transaction)
695 (Ledger.Charted Ledger.Transaction)
696 instance Stats (Ledger.Charted Ledger.Transaction)
697 (JCC.Charted JCC.Transaction)
701 , Stats.Transaction x
702 , Stats.Transaction y
703 ) => Convert (Stats.Stats x) (Stats.Stats y) where
704 convert s@Stats.Stats
705 { Stats.stats_accounts
708 { Stats.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
709 , Stats.stats_units = Map.mapKeysMonotonic convert stats_units