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