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