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.Foldable
  15 import           Data.Foldable (Foldable)
  16 import qualified Data.List
  17 import qualified Data.List.NonEmpty
  18 import qualified Data.Map.Strict as Data.Map
  19 import           Data.Maybe (fromMaybe)
  20 import qualified Data.Text.Lazy as TL
  21 import qualified Data.Text as Text
  22 import qualified Data.Time.Calendar  as Time (toGregorian)
  23 import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
  24 import qualified Hcompta.Lib.Leijen as W
  25 import           Hcompta.Lib.Leijen (Doc, (<>))
  26 import           System.IO (Handle)
  27 import qualified Text.Parsec as R hiding (satisfy, char)
  28 import           Text.Parsec (Stream, ParsecT)
  29 import           GHC.Exts (Int(..))
  30 import           GHC.Integer.Logarithms (integerLogBase#)
  31
  32 import qualified Hcompta.Model.Account as Account
  33 import           Hcompta.Model.Account (Account)
  34 import qualified Hcompta.Model.Amount as Amount
  35 import           Hcompta.Model.Amount (Amount)
  36 import qualified Hcompta.Model.Amount.Quantity as Quantity
  37 import           Hcompta.Model.Amount.Quantity (Quantity)
  38 import qualified Hcompta.Model.Amount.Style as Amount.Style
  39 import qualified Hcompta.Model.Amount.Unit as Unit
  40 import           Hcompta.Model.Amount.Unit (Unit)
  41 import qualified Hcompta.Format.Ledger as Ledger
  42 import           Hcompta.Format.Ledger
  43                   ( Comment
  44                   , Journal(..)
  45                   , Posting(..), Posting_by_Account, Posting_Type(..)
  46                   , Tag
  47                   , Transaction(..)
  48                   )
  49 -- import qualified Hcompta.Model.Date as Date
  50 import           Hcompta.Model.Date (Date)
  51 -- import           Hcompta.Format.Ledger.Journal as Journal
  52 import qualified Hcompta.Format.Ledger.Read as Read
  53 import qualified Hcompta.Lib.Parsec as R
  54 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  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          (Lib.Foldable.Composition 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 (Lib.Foldable.Composition 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