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