lib/Hcompta/Format/Ledger/Write.hs

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