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