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
  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.Account as Account
  34 import           Hcompta.Account (Account)
  35 import qualified Hcompta.Amount as Amount
  36 import           Hcompta.Amount (Amount)
  37 import qualified Hcompta.Amount.Quantity as Quantity
  38 import           Hcompta.Amount.Quantity (Quantity)
  39 import qualified Hcompta.Amount.Style as Amount.Style
  40 import qualified Hcompta.Amount.Unit as Unit
  41 import           Hcompta.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.Date as Date
  51 import           Hcompta.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
  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 utc = do
 243         let (y, mo, d) = Time.toGregorian day
 244         (if y == 0 then W.empty else W.integer y <> sep '/') <> do
 245         int2 mo <> do
 246         sep '/' <> int2 d <> do
 247         (case tod of
 248          Time.TimeOfDay 0 0 0 -> W.empty
 249          Time.TimeOfDay h m s ->
 250                 W.space <> int2 h <> do
 251                 sep ':' <> int2 m <> do
 252                 (case s of
 253                  0 -> W.empty
 254                  _ -> sep ':' <> do
 255                         (if s < 10 then W.char '0' else W.empty) <> do
 256                         W.strict_text $ Text.pack $ showFixed True s)) <> do
 257         (case tz_min of
 258          0 -> W.empty
 259          _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
 260          _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
 261         where
 262                 Time.ZonedTime
 263                  (Time.LocalTime day tod)
 264                  tz@(Time.TimeZone tz_min _ tz_name) =
 265                         Time.utcToZonedTime Time.utc utc
 266                 int2 :: Int -> Doc
 267                 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
 268                 sep :: Char -> Doc
 269                 sep = W.bold . W.dullblack . W.char
 270
 271 -- * Printing 'Comment'
 272
 273 comment :: Comment -> Doc
 274 comment com =
 275         W.cyan $ do
 276                 W.char Read.comment_begin
 277                 <> (case Text.uncons com of
 278                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 279                  _ -> W.empty)
 280                 <> do W.if_color colorize (W.strict_text com)
 281         where
 282                 colorize :: Doc
 283                 colorize =
 284                         case R.runParser (do
 285                                 pre <- R.many $ R.try $ do
 286                                         ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
 287                                         sh <- R.space_horizontal
 288                                         return (ns ++ [sh])
 289                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 290                          () "" com of
 291                          Left _ -> W.strict_text com
 292                          Right doc -> doc
 293                 tags :: Stream s m Char => ParsecT s u m Doc
 294                 tags = do
 295                         x <- tag_
 296                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 297                         return $ x <> xs
 298                         where
 299                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 300                                 tag_sep = do
 301                                         s <- R.char Read.tag_sep
 302                                         sh <- R.many R.space_horizontal
 303                                         return $
 304                                                 do W.bold $ W.dullblack $ W.char s
 305                                                 <> do W.text $ TL.pack sh
 306                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 307                                 tag_ = do
 308                                         n <- Read.tag_name
 309                                         s <- R.char Read.tag_value_sep
 310                                         v <- Read.tag_value
 311                                         return $
 312                                                 (W.yellow $ W.strict_text n)
 313                                                 <> (W.bold $ W.dullblack $ W.char s)
 314                                                 <> (W.red $ W.strict_text v)
 315
 316 comments :: Doc -> [Comment] -> Doc
 317 comments prefix =
 318         W.hcat .
 319         Data.List.intersperse W.line .
 320         Data.List.map (\c -> prefix <> comment c)
 321
 322 -- * Printing 'Tag'
 323
 324 tag :: Tag -> Doc
 325 tag (n, v) =
 326         (W.dullyellow $ W.strict_text n)
 327         <> W.char Read.tag_value_sep
 328         <> (W.dullred $ W.strict_text v)
 329
 330 -- * Printing 'Posting'
 331
 332 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 333 posting max_posting_length type_
 334  Posting
 335  { posting_account=acct
 336  , posting_amounts
 337  , posting_comments=cmts
 338  -- , posting_dates
 339  , posting_status=status_
 340  -- , posting_tags
 341  } =
 342         W.char '\t' <> do
 343         status status_ <> do
 344                 case Data.Map.null posting_amounts of
 345                  True -> account type_ acct
 346                  False ->
 347                         let len_acct = account_length type_ acct in
 348                         let len_amts = amounts_length posting_amounts in
 349                         account type_ acct <> do
 350                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
 351                         W.intercalate
 352                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 353                          amount posting_amounts
 354         <> (case cmts of
 355          [] -> W.empty
 356          [c] -> W.space <> comment c
 357          _ -> W.line <> do comments (W.text "\t ") cmts)
 358
 359 status :: Ledger.Status -> Doc
 360 status = \x -> case x of
 361          True  -> W.char '!'
 362          False -> W.empty
 363
 364 -- ** Mesuring 'Posting'
 365
 366 type Posting_Lengths = (Int)
 367
 368 postings_lengths
 369  :: Posting_Type
 370  -> Posting_by_Account
 371  -> Posting_Lengths
 372  -> Posting_Lengths
 373 postings_lengths type_ ps pl =
 374         Data.Foldable.foldr
 375          (\p ->
 376                 max
 377                  ( account_length type_ (posting_account p)
 378                  + amounts_length       (posting_amounts p) )
 379          ) pl
 380          (Data.Functor.Compose.Compose ps)
 381
 382 -- * Printing 'Transaction'
 383
 384 transaction :: Transaction -> Doc
 385 transaction t = transaction_with_lengths (transaction_lengths t 0) t
 386
 387 transactions :: Foldable f => f Transaction -> Doc
 388 transactions ts = do
 389         let transaction_lengths_ =
 390                 Data.Foldable.foldr transaction_lengths 0 ts
 391         Data.Foldable.foldr
 392          (\t doc ->
 393                 transaction_with_lengths transaction_lengths_ t <> W.line <>
 394                 (if W.is_empty doc then W.empty else W.line <> doc)
 395          )
 396          W.empty
 397          ts
 398
 399 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 400 transaction_with_lengths
 401  posting_lengths_
 402  Transaction
 403  { transaction_code=code_
 404  , transaction_comments_before
 405  , transaction_comments_after
 406  , transaction_dates=(first_date, dates)
 407  , transaction_description
 408  , transaction_postings
 409  , transaction_virtual_postings
 410  , transaction_balanced_virtual_postings
 411  , transaction_status=status_
 412  -- , transaction_tags
 413  } = do
 414         (case transaction_comments_before of
 415          [] -> W.empty
 416          _  -> comments W.space transaction_comments_before <> W.line) <> do
 417         (W.hcat $
 418                 Data.List.intersperse
 419                  (W.char Read.date_sep)
 420                  (Data.List.map date (first_date:dates))) <> do
 421         (case status_ of
 422          True -> W.space <> status status_
 423          False -> W.empty) <> do
 424         code code_ <> do
 425         (case transaction_description of
 426          "" -> W.empty
 427          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 428         W.line <> do
 429         (case transaction_comments_after of
 430          [] -> W.empty
 431          _  -> comments W.space transaction_comments_after <> W.line) <> do
 432         W.vsep $ Data.List.map
 433          (\(type_, ps) ->
 434                 W.intercalate W.line
 435                  (W.intercalate W.line
 436                          (W.vsep . Data.List.map
 437                                  (posting posting_lengths_ type_)))
 438                  (Ledger.posting_by_Signs_and_Account ps))
 439          [ (Posting_Type_Regular, transaction_postings)
 440          , (Posting_Type_Virtual, transaction_virtual_postings)
 441          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 442          ]
 443
 444 code :: Ledger.Code -> Doc
 445 code = \x -> case x of
 446          "" -> W.empty
 447          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 448
 449 -- ** Mesuring 'Transaction'
 450
 451 type Transaction_Lengths = Posting_Lengths
 452
 453 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 454 transaction_lengths
 455  Transaction
 456  { transaction_postings
 457  , transaction_virtual_postings
 458  , transaction_balanced_virtual_postings
 459  } posting_lengths_ = do
 460         Data.List.foldl
 461          (flip (\(type_, ps) -> postings_lengths type_ ps))
 462          posting_lengths_
 463          [ (Posting_Type_Regular, transaction_postings)
 464          , (Posting_Type_Virtual, transaction_virtual_postings)
 465          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 466          ]
 467
 468 -- * Printing 'Journal'
 469
 470 journal :: Journal -> Doc
 471 journal Journal { journal_transactions } =
 472         transactions (Data.Functor.Compose.Compose journal_transactions)
 473
 474 -- * Rendering
 475
 476 data Style
 477  =   Style
 478  { style_align :: Bool
 479  , style_color :: Bool
 480  }
 481 style :: Style
 482 style =
 483         Style
 484          { style_align = True
 485          , style_color = True
 486          }
 487
 488 show :: Style -> Doc -> TL.Text
 489 show Style{style_color, style_align} =
 490         W.displayT .
 491         if style_align
 492         then W.renderPretty style_color 1.0 maxBound
 493         else W.renderCompact style_color
 494
 495 put :: Style -> Handle -> Doc -> IO ()
 496 put Style{style_color, style_align} handle =
 497         W.displayIO handle .
 498         if style_align
 499         then W.renderPretty style_color 1.0 maxBound
 500         else W.renderCompact style_color