]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Write.hs
Modif : CLI.Lang : utilise la classe ToDoc pour gérer les traductions.
[comptalang.git] / lib / Hcompta / Format / Ledger / Write.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MagicHash #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 module Hcompta.Format.Ledger.Write where
8
9 import Control.Applicative ((<$>), (<*))
10 -- import Control.Arrow ((***))
11 import Data.Decimal (DecimalRaw(..))
12 import qualified Data.Char (isSpace)
13 import Data.Fixed (showFixed)
14 import qualified Data.Functor.Compose
15 import qualified Data.Foldable
16 import Data.Foldable (Foldable)
17 import qualified Data.List
18 import qualified Data.List.NonEmpty
19 import qualified Data.Map.Strict as Data.Map
20 import Data.Maybe (fromMaybe)
21 import qualified Data.Text.Lazy as TL
22 import qualified Data.Text as Text
23 import qualified Data.Time.Calendar as Time (toGregorian)
24 import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
25 import qualified Hcompta.Lib.Leijen as W
26 import Hcompta.Lib.Leijen (Doc, (<>))
27 import System.IO (Handle)
28 import qualified Text.Parsec as R hiding (satisfy, char)
29 import Text.Parsec (Stream, ParsecT)
30 import GHC.Exts (Int(..))
31 import GHC.Integer.Logarithms (integerLogBase#)
32
33 import qualified Hcompta.Model.Account as Account
34 import Hcompta.Model.Account (Account)
35 import qualified Hcompta.Model.Amount as Amount
36 import Hcompta.Model.Amount (Amount)
37 import qualified Hcompta.Model.Amount.Quantity as Quantity
38 import Hcompta.Model.Amount.Quantity (Quantity)
39 import qualified Hcompta.Model.Amount.Style as Amount.Style
40 import qualified Hcompta.Model.Amount.Unit as Unit
41 import Hcompta.Model.Amount.Unit (Unit)
42 import qualified Hcompta.Format.Ledger as Ledger
43 import Hcompta.Format.Ledger
44 ( Comment
45 , Journal(..)
46 , Posting(..), Posting_by_Account, Posting_Type(..)
47 , Tag
48 , Transaction(..)
49 )
50 -- import qualified Hcompta.Model.Date as Date
51 import Hcompta.Model.Date (Date)
52 -- import Hcompta.Format.Ledger.Journal as Journal
53 import qualified Hcompta.Format.Ledger.Read as Read
54 import qualified Hcompta.Lib.Parsec as R
55
56
57 -- * Printing 'Account'
58
59 account :: Posting_Type -> Account -> Doc
60 account type_ =
61 case type_ of
62 Posting_Type_Regular -> account_
63 Posting_Type_Virtual -> \acct ->
64 W.char Read.posting_type_virtual_begin <> do
65 account_ acct <> do
66 W.char Read.posting_type_virtual_end
67 Posting_Type_Virtual_Balanced -> \acct ->
68 W.char Read.posting_type_virtual_balanced_begin <> do
69 account_ acct <> do
70 W.char Read.posting_type_virtual_balanced_end
71 where
72 account_ :: Account -> Doc
73 account_ acct =
74 W.align $ W.hcat $
75 Data.List.NonEmpty.toList $
76 Data.List.NonEmpty.intersperse
77 (W.bold $ W.yellow $ W.char Read.account_name_sep)
78 (Data.List.NonEmpty.map account_name acct)
79
80 account_name :: Account.Name -> Doc
81 account_name = W.strict_text
82
83 -- ** Mesuring 'Account'
84
85 account_length :: Posting_Type -> Account -> Int
86 account_length type_ acct =
87 Data.Foldable.foldl
88 (\acc -> (1 +) . (acc +) . Text.length)
89 (- 1) acct +
90 case type_ of
91 Posting_Type_Regular -> 0
92 Posting_Type_Virtual -> 2
93 Posting_Type_Virtual_Balanced -> 2
94
95 -- * Printing 'Amount'
96
97 amount :: Amount -> Doc
98 amount Amount.Amount
99 { Amount.quantity=qty
100 , Amount.style = sty@(Amount.Style.Style
101 { Amount.Style.unit_side
102 , Amount.Style.unit_spaced
103 })
104 , Amount.unit=unit_
105 } = do
106 case unit_side of
107 Just Amount.Style.Side_Left ->
108 (unit unit_)
109 <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
110 _ -> W.empty
111 <> quantity sty qty
112 <> case unit_side of
113 (Just Amount.Style.Side_Right) ->
114 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
115 <> unit unit_
116 Nothing ->
117 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
118 <> unit unit_
119 _ -> W.empty
120
121 unit :: Unit -> Doc
122 unit = W.yellow . W.strict_text . Unit.text
123
124 quantity :: Amount.Style -> Quantity -> Doc
125 quantity Amount.Style.Style
126 { Amount.Style.fractioning
127 , Amount.Style.grouping_integral
128 , Amount.Style.grouping_fractional
129 , Amount.Style.precision
130 } qty = do
131 let Decimal e n = Quantity.round precision qty
132 let num = Prelude.show $ abs $ n
133 let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
134 case e == 0 || precision == 0 of
135 True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
136 False -> do
137 let num_len = length num
138 let padded =
139 Data.List.concat
140 [ replicate (fromIntegral e + 1 - num_len) '0'
141 , num
142 , replicate (fromIntegral precision - fromIntegral e) '0'
143 ]
144 let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
145 let default_fractioning =
146 Data.List.head $
147 del_grouping_sep grouping_integral $
148 del_grouping_sep grouping_fractional $
149 ['.', ',']
150 sign <> do
151 W.bold $ W.blue $ do
152 W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
153 (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
154 W.text (TL.pack $ maybe id group grouping_fractional frac)
155 where
156 group :: Amount.Style.Grouping -> [Char] -> [Char]
157 group (Amount.Style.Grouping sep sizes_) =
158 Data.List.concat . reverse .
159 Data.List.map reverse . fst .
160 Data.List.foldl
161 (flip (\digit -> \x -> case x of
162 ([], sizes) -> ([[digit]], sizes)
163 (digits:groups, []) -> ((digit:digits):groups, [])
164 (digits:groups, curr_sizes@(size:sizes)) ->
165 if length digits < size
166 then ( (digit:digits):groups, curr_sizes)
167 else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
168 ))
169 ([], sizes_)
170 del_grouping_sep grouping =
171 case grouping of
172 Just (Amount.Style.Grouping sep _) -> Data.List.delete sep
173 _ -> id
174
175 -- ** Mesuring 'Amount'
176
177 amount_length :: Amount -> Int
178 amount_length Amount.Amount
179 { Amount.quantity = qty
180 , Amount.style = sty@(Amount.Style.Style
181 { Amount.Style.unit_spaced
182 })
183 , Amount.unit = unit_
184 } = do
185 Unit.length unit_
186 + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
187 + quantity_length sty qty
188
189 amounts_length :: Amount.By_Unit -> Int
190 amounts_length amts =
191 if Data.Map.null amts
192 then 0
193 else
194 Data.Map.foldr
195 (\n -> (3 +) . (+) (amount_length n))
196 (-3) amts
197
198 quantity_length :: Amount.Style -> Quantity -> Int
199 quantity_length Amount.Style.Style
200 { Amount.Style.grouping_integral
201 , Amount.Style.grouping_fractional
202 , Amount.Style.precision
203 } qty =
204 let Decimal e n = Quantity.round precision qty in
205 let sign_len = if n < 0 then 1 else 0 in
206 let fractioning_len = if e > 0 then 1 else 0 in
207 let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
208 let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in
209 let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
210 let padded_len = pad_left_len + num_len + pad_right_len in
211 let int_len = max 1 (num_len - fromIntegral precision) in
212 let frac_len = max 0 (padded_len - int_len) in
213 ( sign_len
214 + fractioning_len
215 + padded_len
216 + maybe 0 (group int_len) grouping_integral
217 + maybe 0 (group frac_len) grouping_fractional
218 )
219 where
220 group :: Int -> Amount.Style.Grouping -> Int
221 group num_len (Amount.Style.Grouping _sep sizes_) =
222 if num_len <= 0
223 then 0
224 else loop 0 num_len sizes_
225 where
226 loop :: Int -> Int -> [Int] -> Int
227 loop pad len =
228 \x -> case x of
229 [] -> 0
230 sizes@[size] ->
231 let l = len - size in
232 if l <= 0 then pad
233 else loop (pad + 1) l sizes
234 size:sizes ->
235 let l = len - size in
236 if l <= 0 then pad
237 else loop (pad + 1) l sizes
238
239 -- * Printing 'Date'
240
241 date :: Date -> Doc
242 date (Time.ZonedTime
243 (Time.LocalTime day tod)
244 tz@(Time.TimeZone tz_min _ tz_name)) = do
245 let (y, mo, d) = Time.toGregorian day
246 (if y == 0 then W.empty else W.integer y <> sep '/') <> do
247 int2 mo <> do
248 sep '/' <> int2 d <> do
249 (case tod of
250 Time.TimeOfDay 0 0 0 -> W.empty
251 Time.TimeOfDay h m s ->
252 W.space <> int2 h <> do
253 sep ':' <> int2 m <> do
254 (case s of
255 0 -> W.empty
256 _ -> sep ':' <> do
257 (if s < 10 then W.char '0' else W.empty) <> do
258 W.strict_text $ Text.pack $ showFixed True s)) <> do
259 (case tz_min of
260 0 -> W.empty
261 _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
262 _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
263 where
264 int2 :: Int -> Doc
265 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
266 sep :: Char -> Doc
267 sep = W.bold . W.dullblack . W.char
268
269 -- * Printing 'Comment'
270
271 comment :: Comment -> Doc
272 comment com =
273 W.cyan $ do
274 W.char Read.comment_begin
275 <> (case Text.uncons com of
276 Just (c, _) | not $ Data.Char.isSpace c -> W.space
277 _ -> W.empty)
278 <> do W.if_color colorize (W.strict_text com)
279 where
280 colorize :: Doc
281 colorize =
282 case R.runParser (do
283 pre <- R.many $ R.try $ do
284 ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
285 sh <- R.space_horizontal
286 return (ns ++ [sh])
287 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
288 () "" com of
289 Left _ -> W.strict_text com
290 Right doc -> doc
291 tags :: Stream s m Char => ParsecT s u m Doc
292 tags = do
293 x <- tag_
294 xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
295 return $ x <> xs
296 where
297 tag_sep :: Stream s m Char => ParsecT s u m Doc
298 tag_sep = do
299 s <- R.char Read.tag_sep
300 sh <- R.many R.space_horizontal
301 return $
302 do W.bold $ W.dullblack $ W.char s
303 <> do W.text $ TL.pack sh
304 tag_ :: Stream s m Char => ParsecT s u m Doc
305 tag_ = do
306 n <- Read.tag_name
307 s <- R.char Read.tag_value_sep
308 v <- Read.tag_value
309 return $
310 (W.yellow $ W.strict_text n)
311 <> (W.bold $ W.dullblack $ W.char s)
312 <> (W.red $ W.strict_text v)
313
314 comments :: Doc -> [Comment] -> Doc
315 comments prefix =
316 W.hcat .
317 Data.List.intersperse W.line .
318 Data.List.map (\c -> prefix <> comment c)
319
320 -- * Printing 'Tag'
321
322 tag :: Tag -> Doc
323 tag (n, v) =
324 (W.dullyellow $ W.strict_text n)
325 <> W.char Read.tag_value_sep
326 <> (W.dullred $ W.strict_text v)
327
328 -- * Printing 'Posting'
329
330 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
331 posting max_posting_length type_
332 Posting
333 { posting_account=acct
334 , posting_amounts
335 , posting_comments=cmts
336 -- , posting_dates
337 , posting_status=status_
338 -- , posting_tags
339 } =
340 W.char '\t' <> do
341 status status_ <> do
342 case Data.Map.null posting_amounts of
343 True -> account type_ acct
344 False ->
345 let len_acct = account_length type_ acct in
346 let len_amts = amounts_length posting_amounts in
347 account type_ acct <> do
348 W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
349 W.intercalate
350 (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
351 amount posting_amounts
352 <> (case cmts of
353 [] -> W.empty
354 [c] -> W.space <> comment c
355 _ -> W.line <> do comments (W.text "\t ") cmts)
356
357 status :: Ledger.Status -> Doc
358 status = \x -> case x of
359 True -> W.char '!'
360 False -> W.empty
361
362 -- ** Mesuring 'Posting'
363
364 type Posting_Lengths = (Int)
365
366 postings_lengths
367 :: Posting_Type
368 -> Posting_by_Account
369 -> Posting_Lengths
370 -> Posting_Lengths
371 postings_lengths type_ ps pl =
372 Data.Foldable.foldr
373 (\p ->
374 max
375 ( account_length type_ (posting_account p)
376 + amounts_length (posting_amounts p) )
377 ) pl
378 (Data.Functor.Compose.Compose ps)
379
380 -- * Printing 'Transaction'
381
382 transaction :: Transaction -> Doc
383 transaction t = transaction_with_lengths (transaction_lengths t 0) t
384
385 transactions :: Foldable f => f Transaction -> Doc
386 transactions ts = do
387 let transaction_lengths_ =
388 Data.Foldable.foldr transaction_lengths 0 ts
389 Data.Foldable.foldr
390 (\t doc ->
391 transaction_with_lengths transaction_lengths_ t <> W.line <>
392 (if W.is_empty doc then W.empty else W.line <> doc)
393 )
394 W.empty
395 ts
396
397 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
398 transaction_with_lengths
399 posting_lengths_
400 Transaction
401 { transaction_code=code_
402 , transaction_comments_before
403 , transaction_comments_after
404 , transaction_dates=(first_date, dates)
405 , transaction_description
406 , transaction_postings
407 , transaction_virtual_postings
408 , transaction_balanced_virtual_postings
409 , transaction_status=status_
410 -- , transaction_tags
411 } = do
412 (case transaction_comments_before of
413 [] -> W.empty
414 _ -> comments W.space transaction_comments_before <> W.line) <> do
415 (W.hcat $
416 Data.List.intersperse
417 (W.char Read.date_sep)
418 (Data.List.map date (first_date:dates))) <> do
419 (case status_ of
420 True -> W.space <> status status_
421 False -> W.empty) <> do
422 code code_ <> do
423 (case transaction_description of
424 "" -> W.empty
425 _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
426 W.line <> do
427 (case transaction_comments_after of
428 [] -> W.empty
429 _ -> comments W.space transaction_comments_after <> W.line) <> do
430 W.vsep $ Data.List.map
431 (\(type_, ps) ->
432 W.intercalate W.line
433 (W.intercalate W.line
434 (W.vsep . Data.List.map
435 (posting posting_lengths_ type_)))
436 (Ledger.posting_by_Signs_and_Account ps))
437 [ (Posting_Type_Regular, transaction_postings)
438 , (Posting_Type_Virtual, transaction_virtual_postings)
439 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
440 ]
441
442 code :: Ledger.Code -> Doc
443 code = \x -> case x of
444 "" -> W.empty
445 t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
446
447 -- ** Mesuring 'Transaction'
448
449 type Transaction_Lengths = Posting_Lengths
450
451 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
452 transaction_lengths
453 Transaction
454 { transaction_postings
455 , transaction_virtual_postings
456 , transaction_balanced_virtual_postings
457 } posting_lengths_ = do
458 Data.List.foldl
459 (flip (\(type_, ps) -> postings_lengths type_ ps))
460 posting_lengths_
461 [ (Posting_Type_Regular, transaction_postings)
462 , (Posting_Type_Virtual, transaction_virtual_postings)
463 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
464 ]
465
466 -- * Printing 'Journal'
467
468 journal :: Journal -> Doc
469 journal Journal { journal_transactions } =
470 transactions (Data.Functor.Compose.Compose journal_transactions)
471
472 -- * Rendering
473
474 data Style
475 = Style
476 { style_align :: Bool
477 , style_color :: Bool
478 }
479 style :: Style
480 style =
481 Style
482 { style_align = True
483 , style_color = True
484 }
485
486 show :: Style -> Doc -> TL.Text
487 show Style{style_color, style_align} =
488 W.displayT .
489 if style_align
490 then W.renderPretty style_color 1.0 maxBound
491 else W.renderCompact style_color
492
493 put :: Style -> Handle -> Doc -> IO ()
494 put Style{style_color, style_align} handle =
495 W.displayIO handle .
496 if style_align
497 then W.renderPretty style_color 1.0 maxBound
498 else W.renderCompact style_color