1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE MagicHash #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 module Hcompta.Format.Ledger.Write where
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.Foldable
14 import qualified Data.List
15 import qualified Data.List.NonEmpty
16 import qualified Data.Map.Strict as Data.Map
17 import Data.Maybe (fromMaybe)
18 import qualified Data.Text.Lazy as TL
19 import qualified Data.Text as Text
20 import qualified Data.Time.Calendar as Time (toGregorian)
21 import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
22 import qualified Hcompta.Lib.Leijen as W
23 import Hcompta.Lib.Leijen (Doc, (<>))
24 import System.IO (Handle)
25 import qualified Text.Parsec as R hiding (satisfy, char)
26 import Text.Parsec (Stream, ParsecT)
27 import GHC.Exts (Int(..))
28 import GHC.Integer.Logarithms (integerLogBase#)
30 import qualified Hcompta.Model.Account as Account
31 import Hcompta.Model.Account (Account)
32 import qualified Hcompta.Model.Amount as Amount
33 import Hcompta.Model.Amount (Amount)
34 import qualified Hcompta.Model.Amount.Quantity as Quantity
35 import Hcompta.Model.Amount.Quantity (Quantity)
36 import qualified Hcompta.Model.Amount.Style as Amount.Style
37 import qualified Hcompta.Model.Amount.Unit as Unit
38 import Hcompta.Model.Amount.Unit (Unit)
39 import qualified Hcompta.Format.Ledger as Ledger
40 import Hcompta.Format.Ledger
43 , Posting(..), Posting_by_Account, Posting_Type(..)
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 import qualified Hcompta.Lib.Parsec as R
54 -- * Printing 'Account'
56 account :: Posting_Type -> Account -> Doc
59 Posting_Type_Regular -> account_
60 Posting_Type_Virtual -> \acct ->
61 W.char Read.posting_type_virtual_begin <> do
63 W.char Read.posting_type_virtual_end
64 Posting_Type_Virtual_Balanced -> \acct ->
65 W.char Read.posting_type_virtual_balanced_begin <> do
67 W.char Read.posting_type_virtual_balanced_end
69 account_ :: Account -> Doc
72 Data.List.NonEmpty.toList $
73 Data.List.NonEmpty.intersperse
74 (W.bold $ W.yellow $ W.char Read.account_name_sep)
75 (Data.List.NonEmpty.map account_name acct)
77 account_name :: Account.Name -> Doc
78 account_name = W.strict_text
80 -- ** Mesuring 'Account'
82 account_length :: Posting_Type -> Account -> Int
83 account_length type_ acct =
85 (\acc -> (1 +) . (acc +) . Text.length)
88 Posting_Type_Regular -> 0
89 Posting_Type_Virtual -> 2
90 Posting_Type_Virtual_Balanced -> 2
92 -- * Printing 'Amount'
94 amount :: Amount -> Doc
97 , Amount.style = sty@(Amount.Style.Style
98 { Amount.Style.unit_side
99 , Amount.Style.unit_spaced
104 Just Amount.Style.Side_Left ->
106 <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
110 (Just Amount.Style.Side_Right) ->
111 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
114 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
119 unit = W.yellow . W.strict_text . Unit.text
121 quantity :: Amount.Style -> Quantity -> Doc
122 quantity Amount.Style.Style
123 { Amount.Style.fractioning
124 , Amount.Style.grouping_integral
125 , Amount.Style.grouping_fractional
126 , Amount.Style.precision
128 let Decimal e n = Quantity.round precision qty
129 let num = Prelude.show $ abs $ n
130 let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
131 case e == 0 || precision == 0 of
132 True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
134 let num_len = length num
137 [ replicate (fromIntegral e + 1 - num_len) '0'
139 , replicate (fromIntegral precision - fromIntegral e) '0'
141 let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
142 let default_fractioning =
144 del_grouping_sep grouping_integral $
145 del_grouping_sep grouping_fractional $
149 W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
150 (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
151 W.text (TL.pack $ maybe id group grouping_fractional frac)
153 group :: Amount.Style.Grouping -> [Char] -> [Char]
154 group (Amount.Style.Grouping sep sizes_) =
155 Data.List.concat . reverse .
156 Data.List.map reverse . fst .
158 (flip (\digit -> \x -> case x of
159 ([], sizes) -> ([[digit]], sizes)
160 (digits:groups, []) -> ((digit:digits):groups, [])
161 (digits:groups, curr_sizes@(size:sizes)) ->
162 if length digits < size
163 then ( (digit:digits):groups, curr_sizes)
164 else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
167 del_grouping_sep grouping =
169 Just (Amount.Style.Grouping sep _) -> Data.List.delete sep
172 -- ** Mesuring 'Amount'
174 amount_length :: Amount -> Int
175 amount_length Amount.Amount
176 { Amount.quantity = qty
177 , Amount.style = sty@(Amount.Style.Style
178 { Amount.Style.unit_spaced
180 , Amount.unit = unit_
183 + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
184 + quantity_length sty qty
186 amounts_length :: Amount.By_Unit -> Int
187 amounts_length amts =
188 if Data.Map.null amts
192 (\n -> (3 +) . (+) (amount_length n))
195 quantity_length :: Amount.Style -> Quantity -> Int
196 quantity_length Amount.Style.Style
197 { Amount.Style.grouping_integral
198 , Amount.Style.grouping_fractional
199 , Amount.Style.precision
201 let Decimal e n = Quantity.round precision qty in
202 let sign_len = if n < 0 then 1 else 0 in
203 let fractioning_len = if e > 0 then 1 else 0 in
204 let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
205 let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in
206 let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
207 let padded_len = pad_left_len + num_len + pad_right_len in
208 let int_len = max 1 (num_len - fromIntegral precision) in
209 let frac_len = max 0 (padded_len - int_len) in
213 + maybe 0 (group int_len) grouping_integral
214 + maybe 0 (group frac_len) grouping_fractional
217 group :: Int -> Amount.Style.Grouping -> Int
218 group num_len (Amount.Style.Grouping _sep sizes_) =
221 else loop 0 num_len sizes_
223 loop :: Int -> Int -> [Int] -> Int
228 let l = len - size in
230 else loop (pad + 1) l sizes
232 let l = len - size in
234 else loop (pad + 1) l sizes
240 (Time.LocalTime day tod)
241 tz@(Time.TimeZone tz_min _ tz_name)) = do
242 let (y, mo, d) = Time.toGregorian day
243 (if y == 0 then W.empty else W.integer y <> sep '/') <> do
245 sep '/' <> int2 d <> do
247 Time.TimeOfDay 0 0 0 -> W.empty
248 Time.TimeOfDay h m s ->
249 W.space <> int2 h <> do
250 sep ':' <> int2 m <> do
254 (if s < 10 then W.char '0' else W.empty) <> do
255 W.strict_text $ Text.pack $ showFixed True s)) <> do
258 _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
259 _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
262 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
264 sep = W.bold . W.dullblack . W.char
266 -- * Printing 'Comment'
268 comment :: Comment -> Doc
271 W.char Read.comment_begin
272 <> (case Text.uncons com of
273 Just (c, _) | not $ Data.Char.isSpace c -> W.space
275 <> do W.if_color colorize (W.strict_text com)
280 pre <- R.many $ R.try $ do
281 ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
282 sh <- R.space_horizontal
284 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
286 Left _ -> W.strict_text com
288 tags :: Stream s m Char => ParsecT s u m Doc
291 xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
294 tag_sep :: Stream s m Char => ParsecT s u m Doc
296 s <- R.char Read.tag_sep
297 sh <- R.many R.space_horizontal
299 do W.bold $ W.dullblack $ W.char s
300 <> do W.text $ TL.pack sh
301 tag_ :: Stream s m Char => ParsecT s u m Doc
304 s <- R.char Read.tag_value_sep
307 (W.yellow $ W.strict_text n)
308 <> (W.bold $ W.dullblack $ W.char s)
309 <> (W.red $ W.strict_text v)
311 comments :: Doc -> [Comment] -> Doc
314 Data.List.intersperse W.line .
315 Data.List.map (\c -> prefix <> comment c)
321 (W.dullyellow $ W.strict_text n)
322 <> W.char Read.tag_value_sep
323 <> (W.dullred $ W.strict_text v)
325 -- * Printing 'Posting'
327 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
334 { posting_account=acct
336 , posting_comments=cmts
338 , posting_status=status_
343 case Data.Map.null posting_amounts of
344 True -> account type_ acct
346 W.fill (max_account_length) (account type_ acct) <> do
347 W.space <> W.space <> do
350 - (fromIntegral $ amounts_length posting_amounts) )) W.empty <> do
352 (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
353 amount posting_amounts
356 [c] -> W.space <> comment c
357 _ -> W.line <> do comments (W.text "\t ") cmts)
359 status :: Ledger.Status -> Doc
360 status = \x -> case x of
364 -- ** Mesuring 'Posting'
366 type Posting_Lengths = (Int, Int)
368 nil_Posting_Lengths :: Posting_Lengths
369 nil_Posting_Lengths = (0, 0)
371 postings_lengths :: Posting_Type -> Posting_by_Account -> Posting_Lengths -> Posting_Lengths
372 postings_lengths type_ =
373 flip $ Data.Map.foldl $ Data.List.foldl $
375 (max (account_length type_ (posting_account p)))
377 (max (amounts_length (posting_amounts p)))
379 -- * Printing 'Transaction'
381 transaction :: Transaction -> Doc
382 transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
384 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
385 transaction_with_lengths
388 { transaction_code=code_
389 , transaction_comments_before
390 , transaction_comments_after
391 , transaction_dates=(first_date, dates)
392 , transaction_description
393 , transaction_postings
394 , transaction_virtual_postings
395 , transaction_balanced_virtual_postings
396 , transaction_status=status_
397 -- , transaction_tags
399 (case transaction_comments_before of
401 _ -> comments W.space transaction_comments_before <> W.line) <> do
403 Data.List.intersperse
404 (W.char Read.date_sep)
405 (Data.List.map date (first_date:dates))) <> do
407 True -> W.space <> status status_
408 False -> W.empty) <> do
410 (case transaction_description of
412 _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
414 (case transaction_comments_after of
416 _ -> comments W.space transaction_comments_after <> W.line) <> do
417 W.vsep $ Data.List.map
420 (W.intercalate W.line
421 (W.vsep . Data.List.map
422 (posting posting_lengths_ type_)))
423 (Ledger.posting_by_Signs_and_Account ps))
424 [ (Posting_Type_Regular, transaction_postings)
425 , (Posting_Type_Virtual, transaction_virtual_postings)
426 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
429 code :: Ledger.Code -> Doc
430 code = \x -> case x of
432 t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
434 -- ** Mesuring 'Transaction'
436 type Transaction_Lengths = Posting_Lengths
438 nil_Transaction_Lengths :: Posting_Lengths
439 nil_Transaction_Lengths = nil_Posting_Lengths
441 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
444 { transaction_postings
445 , transaction_virtual_postings
446 , transaction_balanced_virtual_postings
447 } posting_lengths_ = do
449 (flip (\(type_, ps) -> postings_lengths type_ ps))
451 [ (Posting_Type_Regular, transaction_postings)
452 , (Posting_Type_Virtual, transaction_virtual_postings)
453 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
456 -- * Printing 'Journal'
458 journal :: Journal -> Doc
460 { journal_transactions
462 let transaction_lengths_ =
464 (flip (Data.List.foldr transaction_lengths))
465 nil_Transaction_Lengths
468 (flip (Data.List.foldr (\t doc ->
469 transaction_with_lengths transaction_lengths_ t <> W.line <>
470 (if W.is_empty doc then W.empty else W.line <> doc)
479 { style_align :: Bool
480 , style_color :: Bool
489 show :: Style -> Doc -> TL.Text
490 show Style{style_color, style_align} =
493 then W.renderPretty style_color 1.0 maxBound
494 else W.renderCompact style_color
496 put :: Style -> Handle -> Doc -> IO ()
497 put Style{style_color, style_align} handle =
500 then W.renderPretty style_color 1.0 maxBound
501 else W.renderCompact style_color