]> Git — Sourcephile - comptalang.git/blob - jcc/Hcompta/Format/JCC/Write.hs
Correction : Calculus.Lambda.Omega.Explicit.REPL : broutille administrative.
[comptalang.git] / jcc / Hcompta / Format / JCC / Write.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MagicHash #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8 module Hcompta.Format.JCC.Write where
9
10 import Data.Bool
11 import Data.Char (Char)
12 import qualified Data.Char as Char
13 import Data.Eq (Eq(..))
14 import Data.Maybe (Maybe(..), maybe, fromMaybe)
15 import Data.Foldable (Foldable(..))
16 import Data.Function (($), (.), flip, id)
17 import Data.Functor (Functor(..), (<$>))
18 import qualified Data.Functor.Compose
19 import qualified Data.List as List
20 import qualified Data.List.NonEmpty as NonEmpty
21 import Data.Map.Strict (Map)
22 import qualified Data.Map.Strict as Map
23 import Data.Monoid (Monoid(..))
24 import Data.Ord (Ord(..))
25 import Data.Tuple (fst)
26 import Data.Decimal
27 import qualified Data.Text as Text
28 import qualified Data.Text.Lazy as TL
29 import qualified Data.Time.LocalTime as Time
30 import GHC.Exts (Int(..))
31 import GHC.Integer.Logarithms (integerLogBase#)
32 import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
33 import System.IO (IO, Handle)
34
35
36 import Hcompta.Account (Account_Tag(..), Account_Tags(..), Account_Anchor(..))
37 import qualified Hcompta.Account as Account
38 import qualified Hcompta.Anchor as Anchor
39 import Hcompta.Anchor (Anchors(..))
40 import qualified Hcompta.Amount as Amount
41 import qualified Hcompta.Chart as Chart
42 import qualified Hcompta.Unit as Unit
43 import Hcompta.Date (Date)
44 import qualified Hcompta.Date as Date
45 import Hcompta.Lib.Leijen (Doc, (<>))
46 import qualified Hcompta.Lib.Leijen as W
47 import qualified Hcompta.Lib.TreeMap as TreeMap
48 import Hcompta.Tag (Tags(..))
49 import qualified Hcompta.Tag as Tag
50 import Hcompta.Transaction ( Transaction_Anchor(..)
51 , Transaction_Anchors(..)
52 , Transaction_Tag(..)
53 , Transaction_Tags(..)
54 )
55
56 import Hcompta.Format.JCC
57 import Hcompta.Format.JCC.Read
58
59 -- * Write 'Date'
60
61 write_date :: Date -> Doc
62 write_date dat = do
63 let (y, mo, d) = Date.gregorian dat
64 (if y == 0 then W.empty else W.integer y <> sep read_date_ymd_sep) <> do
65 int2 mo <> do
66 sep read_date_ymd_sep <> int2 d <> do
67 (case Date.tod dat of
68 Time.TimeOfDay 0 0 0 -> W.empty
69 Time.TimeOfDay h m s ->
70 sep '_' <> int2 h <> do
71 sep ':' <> int2 m <> do
72 (case s of
73 0 -> W.empty
74 _ -> sep ':' <> do
75 (if s < 10 then W.char '0' else W.empty) <> do
76 W.strict_text $ Text.pack $ show $ (truncate s::Integer)))
77 -- (case tz_min of
78 -- 0 -> W.empty
79 -- _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
80 -- _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
81 where
82 int2 :: Int -> Doc
83 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
84 sep :: Char -> Doc
85 sep = W.bold . W.dullblack . W.char
86
87 write_date_length :: Date -> Int
88 write_date_length dat = do
89 let (y, _, _) = Date.gregorian dat
90 (case y of
91 0 -> 0
92 _ ->
93 (if y < 0 then 1 else 0) -- sign
94 + (1 + (I# (integerLogBase# 10 (abs y)))) -- year
95 + 1) -- -
96 + 2 -- month
97 + 1 -- -
98 + 2 -- dom
99 + (case Date.tod dat of
100 Time.TimeOfDay 0 0 0 -> 0
101 Time.TimeOfDay _ _ s ->
102 1 -- _
103 + 2 -- hour
104 + 1 -- :
105 + 2 -- min
106 + (case s of
107 0 -> 0
108 _ -> 1 + 2 -- : sec
109 )
110 )
111
112 -- * Write 'Account'
113
114 write_account :: Account -> Doc
115 write_account =
116 foldMap $ \a ->
117 (W.bold $ W.dullblack $ W.char read_account_section_sep) <>
118 write_account_section a
119
120 write_account_section :: Account.Account_Section Account -> Doc
121 write_account_section = W.strict_text
122
123 write_account_length :: Account -> Int
124 write_account_length acct =
125 foldl
126 (\acc -> (1 +) . (acc +) . Text.length)
127 0 acct
128
129 -- ** Write 'Account_Anchor'
130
131 write_account_anchor :: Account_Anchor -> Doc
132 write_account_anchor (Account_Anchor anchor) =
133 W.hcat $
134 (:) (op $ W.char read_account_anchor_prefix) $
135 NonEmpty.toList $
136 NonEmpty.intersperse
137 (op $ W.char read_account_anchor_sep)
138 (W.strict_text <$> anchor)
139 where op = W.bold . W.dullyellow
140
141 write_account_anchor_length :: Account_Anchor -> Int
142 write_account_anchor_length (Account_Anchor anch) =
143 foldl
144 (\acc -> (1 +) . (acc +) . Text.length)
145 0 anch
146
147 -- ** Write 'Account_Tag'
148
149 write_account_tag :: Account_Tag -> Doc
150 write_account_tag (Account_Tag (path, value)) =
151 (W.hcat $
152 (:) (op $ W.char read_account_tag_prefix) $
153 NonEmpty.toList $
154 NonEmpty.intersperse
155 (op $ W.char read_account_tag_sep)
156 (W.strict_text <$> path)) <>
157 if Text.null value
158 then W.empty
159 else
160 (op $ W.char read_account_tag_value_prefix) <>
161 W.strict_text value
162 where op = W.bold . W.dullyellow
163
164 -- * Write 'Amount'
165
166 write_amount :: Amount_Styled Amount -> Doc
167 write_amount
168 ( sty@(Amount_Style
169 { amount_style_unit_side
170 , amount_style_unit_spaced
171 })
172 , amt ) =
173 let unt = Amount.amount_unit amt in
174 case amount_style_unit_side of
175 Just Amount_Style_Side_Left ->
176 write_unit unt <>
177 case amount_style_unit_spaced of
178 Just True | unt /= Unit.unit_empty -> W.space
179 _ -> W.empty
180 _ -> W.empty
181 <> write_quantity (sty, Amount.amount_quantity amt)
182 <> case amount_style_unit_side of
183 (Just Amount_Style_Side_Right) ->
184 (case amount_style_unit_spaced of
185 Just True | unt /= Unit.unit_empty -> W.space
186 _ -> W.empty) <>
187 write_unit unt
188 Nothing ->
189 (case amount_style_unit_spaced of
190 Just True | unt /= Unit.unit_empty -> W.space
191 _ -> W.empty) <>
192 write_unit unt
193 _ -> W.empty
194
195 write_amount_length :: Amount_Styled Amount -> Int
196 write_amount_length (sty@(Amount_Style { amount_style_unit_spaced }), amt) =
197 let unt = Amount.amount_unit amt in
198 write_unit_length unt
199 + (case amount_style_unit_spaced of
200 { Just True | unt /= Unit.unit_empty -> 1; _ -> 0 })
201 + write_quantity_length sty (Amount.amount_quantity amt)
202
203 -- ** Write 'Amount's
204
205 write_amounts :: Amount_Styles -> Map Unit Quantity -> Doc
206 write_amounts styles =
207 Map.foldlWithKey
208 (\doc unit qty ->
209 (if W.is_empty doc
210 then doc
211 else doc <> W.space <>
212 (W.bold $ W.yellow $ W.char read_amount_sep) <>
213 W.space) <>
214 (write_amount $
215 amount_styled styles $
216 Amount unit qty))
217 W.empty
218
219 write_amounts_length :: Amount_Styles -> Map Unit Quantity -> Int
220 write_amounts_length styles amts =
221 if Map.null amts
222 then 0
223 else
224 Map.foldrWithKey
225 (\unit qty -> (3 +) . (+)
226 (write_amount_length $
227 amount_styled styles $
228 Amount unit qty))
229 (-3) amts
230
231 -- * Write 'Unit'
232
233 write_unit :: Unit -> Doc
234 write_unit u =
235 let t = Unit.unit_text u in
236 W.yellow $
237 if Text.all
238 (\c -> case Char.generalCategory c of
239 Char.CurrencySymbol -> True
240 Char.LowercaseLetter -> True
241 Char.ModifierLetter -> True
242 Char.OtherLetter -> True
243 Char.TitlecaseLetter -> True
244 Char.UppercaseLetter -> True
245 _ -> False
246 ) t
247 then W.strict_text t
248 else W.hcat $ W.strict_text <$> ["\"", t, "\""]
249
250 write_unit_length :: Unit -> Int
251 write_unit_length u =
252 let t = Unit.unit_text u in
253 Text.length t +
254 if Text.all
255 (\c -> case Char.generalCategory c of
256 Char.CurrencySymbol -> True
257 Char.LowercaseLetter -> True
258 Char.ModifierLetter -> True
259 Char.OtherLetter -> True
260 Char.TitlecaseLetter -> True
261 Char.UppercaseLetter -> True
262 _ -> False) t
263 then 0
264 else 2
265
266 -- * Write 'Quantity'
267
268 write_quantity :: Amount_Styled Quantity -> Doc
269 write_quantity
270 ( Amount_Style
271 { amount_style_fractioning
272 , amount_style_grouping_integral
273 , amount_style_grouping_fractional
274 }
275 , qty ) = do
276 let Decimal e n = qty
277 let num = show $ abs $ n
278 let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
279 case e == 0 of
280 True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
281 False -> do
282 let num_len = List.length num
283 let padded =
284 List.concat
285 [ List.replicate (fromIntegral e + 1 - num_len) '0'
286 , num
287 -- , replicate (fromIntegral precision - fromIntegral e) '0'
288 ]
289 let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
290 let default_fractioning =
291 List.head $
292 del_grouping_sep amount_style_grouping_integral $
293 del_grouping_sep amount_style_grouping_fractional $
294 ['.', ',']
295 sign <> do
296 W.bold $ W.blue $ do
297 W.text (TL.pack $ maybe id
298 (\g -> List.reverse . group g . List.reverse)
299 amount_style_grouping_integral $ int) <> do
300 (W.yellow $ W.char (fromMaybe default_fractioning amount_style_fractioning)) <> do
301 W.text (TL.pack $ maybe id group amount_style_grouping_fractional frac)
302 where
303 group :: Amount_Style_Grouping -> [Char] -> [Char]
304 group (Amount_Style_Grouping sep sizes_) =
305 List.concat . List.reverse .
306 List.map List.reverse . fst .
307 List.foldl'
308 (flip (\digit x -> case x of
309 ([], sizes) -> ([[digit]], sizes)
310 (digits:groups, []) -> ((digit:digits):groups, [])
311 (digits:groups, curr_sizes@(size:sizes)) ->
312 if List.length digits < size
313 then ( (digit:digits):groups, curr_sizes)
314 else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
315 ))
316 ([], sizes_)
317 del_grouping_sep grouping =
318 case grouping of
319 Just (Amount_Style_Grouping sep _) -> List.delete sep
320 _ -> id
321
322 write_quantity_length :: Amount_Style -> Quantity -> Int
323 write_quantity_length Amount_Style
324 { amount_style_grouping_integral
325 , amount_style_grouping_fractional
326 } qty =
327 let Decimal e n = qty in
328 let sign_len = if n < 0 then 1 else 0 in
329 let fractioning_len = if e > 0 then 1 else 0 in
330 let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
331 let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in
332 -- let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
333 let padded_len = pad_left_len + num_len {-+ pad_right_len-} in
334 let int_len = max 1 (num_len - fromIntegral e) in
335 let frac_len = max 0 (padded_len - int_len) in
336 ( sign_len
337 + fractioning_len
338 + padded_len
339 + maybe 0 (group int_len) amount_style_grouping_integral
340 + maybe 0 (group frac_len) amount_style_grouping_fractional
341 )
342 where
343 group :: Int -> Amount_Style_Grouping -> Int
344 group num_len (Amount_Style_Grouping _sep sizes_) =
345 if num_len <= 0
346 then 0
347 else loop 0 num_len sizes_
348 where
349 loop :: Int -> Int -> [Int] -> Int
350 loop pad len =
351 \x -> case x of
352 [] -> 0
353 sizes@[size] ->
354 let l = len - size in
355 if l <= 0 then pad
356 else loop (pad + 1) l sizes
357 size:sizes ->
358 let l = len - size in
359 if l <= 0 then pad
360 else loop (pad + 1) l sizes
361
362 -- * Write 'Comment'
363
364 write_comment :: Comment -> Doc
365 write_comment com =
366 W.cyan $ do
367 W.char read_comment_prefix
368 <> (case Text.uncons com of
369 Just (c, _) | not $ Char.isSpace c -> W.space
370 _ -> W.empty)
371 <> W.strict_text com
372
373 write_comments :: Doc -> [Comment] -> Doc
374 write_comments prefix =
375 W.hcat .
376 List.intersperse W.line .
377 List.map (\c -> prefix <> write_comment c)
378
379 -- * Write 'Posting'
380
381 write_posting :: Amount_Styles -> Posting_Lengths -> Posting -> Doc
382 write_posting styles max_posting_length
383 Posting
384 { posting_account
385 , posting_account_anchor
386 , posting_amounts
387 , posting_comments=cmts
388 -- , posting_dates
389 -- , posting_tags
390 } =
391 W.string " " <> do
392 let (doc_acct, len_acct) =
393 case posting_account_anchor of
394 Nothing ->
395 ( write_account posting_account
396 , write_account_length posting_account )
397 Just (a, sa) ->
398 ( write_account_anchor a <> maybe W.empty write_account sa
399 , write_account_anchor_length a + maybe 0 write_account_length sa )
400 case Map.null posting_amounts of
401 True -> doc_acct
402 False ->
403 let len_amts = write_amounts_length styles posting_amounts in
404 doc_acct <>
405 W.fill (1 + max_posting_length - (len_acct + len_amts)) W.space <>
406 write_amounts styles posting_amounts
407 <> (case cmts of
408 [] -> W.empty
409 [c] -> W.space <> write_comment c
410 _ -> W.line <> do write_comments (W.text " ") cmts)
411
412 -- ** Type 'Posting_Lengths'
413
414 type Posting_Lengths = (Int)
415
416 write_postings_lengths
417 :: Amount_Styles
418 -> Map Account [Posting]
419 -> Posting_Lengths
420 -> Posting_Lengths
421 write_postings_lengths styles ps pl =
422 foldr (\p ->
423 max
424 ( write_account_length (posting_account p)
425 + write_amounts_length styles (posting_amounts p) )
426 ) pl
427 (Data.Functor.Compose.Compose ps)
428
429 -- * Write 'Transaction'
430
431 write_transaction :: Amount_Styles -> Transaction -> Doc
432 write_transaction styles t =
433 write_transaction_with_lengths
434 styles (write_transaction_lengths styles t 0) t
435
436 write_transactions :: Foldable j => Amount_Styles -> j Transaction -> Doc
437 write_transactions styles j = do
438 let transaction_lengths_ =
439 foldr (write_transaction_lengths styles) 0 j
440 foldr (\t doc ->
441 write_transaction_with_lengths styles transaction_lengths_ t <>
442 (if W.is_empty doc then W.empty else W.line <> doc)
443 ) W.empty j
444
445 write_transaction_with_lengths
446 :: Amount_Styles
447 -> Transaction_Lengths
448 -> Transaction -> Doc
449 write_transaction_with_lengths
450 styles
451 posting_lengths_
452 Transaction
453 { transaction_comments
454 , transaction_dates=(first_date, dates)
455 , transaction_wording
456 , transaction_postings
457 , transaction_anchors=Transaction_Anchors (Anchors anchors)
458 , transaction_tags=Transaction_Tags (Tags tags)
459 } = do
460 (W.hcat $
461 List.intersperse
462 (W.char read_transaction_date_sep)
463 (write_date <$> (first_date:dates))) <> do
464 (case transaction_wording of
465 "" -> W.empty
466 _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
467 W.line <> do
468 (case transaction_comments of
469 [] -> W.empty
470 _ -> write_comments W.space transaction_comments <> W.line) <> do
471 Map.foldrWithKey
472 (\path () -> ((W.string " " <>
473 write_transaction_anchor (Transaction_Anchor path) <> W.line) <>))
474 W.empty anchors <> do
475 Map.foldrWithKey
476 (\path -> flip $
477 foldr (\value -> (<>) (W.string " " <>
478 write_transaction_tag (Transaction_Tag (path, value)) <> W.line)))
479 W.empty tags <> do
480 W.intercalate W.line
481 (W.vsep . fmap (write_posting styles posting_lengths_))
482 transaction_postings <> W.line
483
484 -- ** Type 'Transaction_Lengths'
485
486 type Transaction_Lengths = Posting_Lengths
487
488 write_transaction_lengths
489 :: Amount_Styles
490 -> Transaction
491 -> Posting_Lengths
492 -> Posting_Lengths
493 write_transaction_lengths
494 styles
495 Transaction
496 { transaction_postings
497 } posting_lengths = do
498 List.foldl'
499 (flip $ write_postings_lengths styles)
500 posting_lengths
501 [ transaction_postings ]
502
503 -- ** Write 'Transaction_Tag'
504
505 write_transaction_tag :: Transaction_Tag -> Doc
506 write_transaction_tag (Transaction_Tag (path, value)) =
507 (W.hcat $
508 (:) (W.bold $ W.dullyellow $ W.char read_transaction_tag_prefix) $
509 NonEmpty.toList $
510 NonEmpty.intersperse
511 (op $ W.char read_transaction_tag_sep)
512 (write_transaction_tag_section <$> path)) <>
513 if Text.null value
514 then W.empty
515 else
516 (op $ W.char read_transaction_tag_value_prefix) <>
517 W.strict_text value
518 where
519 op = W.bold . W.yellow
520
521 write_transaction_tag_section :: Tag.Section -> Doc
522 write_transaction_tag_section = W.bold . W.strict_text
523
524 -- ** Write 'Transaction_Anchor'
525
526 write_transaction_anchor :: Transaction_Anchor -> Doc
527 write_transaction_anchor (Transaction_Anchor path) =
528 W.hcat $
529 (:) (op $ W.char read_transaction_anchor_prefix) $
530 NonEmpty.toList $
531 NonEmpty.intersperse
532 (op $ W.char read_transaction_anchor_sep)
533 (write_transaction_anchor_section <$> path)
534 where
535 op = W.bold . W.yellow
536
537 write_transaction_anchor_section :: Anchor.Section -> Doc
538 write_transaction_anchor_section = W.bold . W.strict_text
539
540 -- * Write 'Journal'
541
542 write_journal
543 :: ( Foldable j
544 , Monoid (j Transaction)
545 ) => Journal (j Transaction) -> Doc
546 write_journal Journal
547 { journal_amount_styles
548 , journal_content
549 } = write_transactions journal_amount_styles journal_content
550
551 -- * Write 'Chart'
552
553 write_chart :: Chart -> Doc
554 write_chart =
555 TreeMap.foldl_with_Path
556 (\doc acct (Account_Tags (Tags ca)) ->
557 doc <>
558 write_account acct <> W.line <>
559 Map.foldlWithKey
560 (\dd tn tvs ->
561 dd <>
562 foldl'
563 (\ddd tv ->
564 ddd <> W.string " " <>
565 write_account_tag (Account_Tag (tn, tv)) <>
566 W.line)
567 W.empty
568 tvs)
569 W.empty
570 ca
571 ) W.empty .
572 Chart.chart_accounts
573
574 -- * Type 'Write_Style'
575
576 data Write_Style
577 = Write_Style
578 { write_style_align :: Bool
579 , write_style_color :: Bool
580 }
581 write_style :: Write_Style
582 write_style =
583 Write_Style
584 { write_style_align = True
585 , write_style_color = True
586 }
587
588 -- * Write
589 write :: Write_Style -> Doc -> TL.Text
590 write Write_Style
591 { write_style_color
592 , write_style_align } =
593 W.displayT .
594 if write_style_align
595 then W.renderPretty write_style_color 1.0 maxBound
596 else W.renderCompact write_style_color
597
598 writeIO :: Write_Style -> Doc -> Handle -> IO ()
599 writeIO Write_Style
600 { write_style_color
601 , write_style_align
602 } doc handle =
603 W.displayIO handle $
604 if write_style_align
605 then W.renderPretty write_style_color 1.0 maxBound doc
606 else W.renderCompact write_style_color doc