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