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