lib/Hcompta/Format/Ledger/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE MagicHash #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 module Hcompta.Format.Ledger.Write where
   7
   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#)
  29
  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
  41                   ( Comment
  42                   , Journal(..)
  43                   , Posting(..), Posting_by_Account, Posting_Type(..)
  44                   , Tag
  45                   , Transaction(..)
  46                   )
  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
  52
  53
  54 -- * Printing 'Account'
  55
  56 account :: Posting_Type -> Account -> Doc
  57 account type_ =
  58         case type_ of
  59          Posting_Type_Regular -> account_
  60          Posting_Type_Virtual -> \acct ->
  61                 W.char Read.posting_type_virtual_begin <> do
  62                 account_ acct <> 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
  66                 account_ acct <> do
  67                 W.char Read.posting_type_virtual_balanced_end
  68         where
  69                 account_ :: Account -> Doc
  70                 account_ acct =
  71                         W.align $ W.hcat $
  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)
  76
  77 account_name :: Account.Name -> Doc
  78 account_name = W.strict_text
  79
  80 -- ** Mesuring 'Account'
  81
  82 account_length :: Posting_Type -> Account -> Int
  83 account_length type_ acct =
  84         Data.Foldable.foldl
  85          (\acc -> (1 +) . (acc +) . Text.length)
  86          (- 1) acct +
  87         case type_ of
  88          Posting_Type_Regular -> 0
  89          Posting_Type_Virtual -> 2
  90          Posting_Type_Virtual_Balanced -> 2
  91
  92 -- * Printing 'Amount'
  93
  94 amount :: Amount -> Doc
  95 amount Amount.Amount
  96  { Amount.quantity=qty
  97  , Amount.style = sty@(Amount.Style.Style
  98          { Amount.Style.unit_side
  99          , Amount.Style.unit_spaced
 100          })
 101  , Amount.unit=unit_
 102  } = do
 103         case unit_side of
 104          Just Amount.Style.Side_Left ->
 105                 (unit unit_)
 106                 <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 107          _ -> W.empty
 108         <> quantity sty qty
 109         <> case unit_side of
 110          (Just Amount.Style.Side_Right) ->
 111                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 112                 <> unit unit_
 113          Nothing ->
 114                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 115                 <> unit unit_
 116          _ -> W.empty
 117
 118 unit :: Unit -> Doc
 119 unit = W.yellow . W.strict_text . Unit.text
 120
 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
 127  } qty = do
 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)
 133          False -> do
 134                 let num_len = length num
 135                 let padded =
 136                         Data.List.concat
 137                          [ replicate (fromIntegral e + 1 - num_len) '0'
 138                          , num
 139                          , replicate (fromIntegral precision - fromIntegral e) '0'
 140                          ]
 141                 let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
 142                 let default_fractioning =
 143                         Data.List.head $
 144                         del_grouping_sep grouping_integral $
 145                         del_grouping_sep grouping_fractional $
 146                         ['.', ',']
 147                 sign <> do
 148                 W.bold $ W.blue $ do
 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)
 152         where
 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 .
 157                         Data.List.foldl
 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)
 165                          ))
 166                          ([], sizes_)
 167                 del_grouping_sep grouping =
 168                         case grouping of
 169                          Just (Amount.Style.Grouping sep _) -> Data.List.delete sep
 170                          _ -> id
 171
 172 -- ** Mesuring 'Amount'
 173
 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
 179          })
 180  , Amount.unit = unit_
 181  } = do
 182         Unit.length unit_
 183         + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
 184         + quantity_length sty qty
 185
 186 amounts_length :: Amount.By_Unit -> Int
 187 amounts_length amts =
 188         if Data.Map.null amts
 189         then 0
 190         else
 191                 Data.Map.foldr
 192                  (\n -> (3 +) . (+) (amount_length n))
 193                  (-3) amts
 194
 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
 200  } qty =
 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
 210         ( sign_len
 211         + fractioning_len
 212         + padded_len
 213         + maybe 0 (group int_len)  grouping_integral
 214         + maybe 0 (group frac_len) grouping_fractional
 215         )
 216         where
 217                 group :: Int -> Amount.Style.Grouping -> Int
 218                 group num_len (Amount.Style.Grouping _sep sizes_) =
 219                         if num_len <= 0
 220                         then 0
 221                         else loop 0 num_len sizes_
 222                         where
 223                                 loop :: Int -> Int -> [Int] -> Int
 224                                 loop pad len =
 225                                         \x -> case x of
 226                                          [] -> 0
 227                                          sizes@[size] ->
 228                                                 let l = len - size in
 229                                                 if l <= 0 then pad
 230                                                 else loop (pad + 1) l sizes
 231                                          size:sizes ->
 232                                                 let l = len - size in
 233                                                 if l <= 0 then pad
 234                                                 else loop (pad + 1) l sizes
 235
 236 -- * Printing 'Date'
 237
 238 date :: Date -> Doc
 239 date (Time.ZonedTime
 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
 244         int2 mo <> do
 245         sep '/' <> int2 d <> do
 246         (case tod of
 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
 251                 (case s of
 252                  0 -> W.empty
 253                  _ -> sep ':' <> do
 254                         (if s < 10 then W.char '0' else W.empty) <> do
 255                         W.strict_text $ Text.pack $ showFixed True s)) <> do
 256         (case tz_min of
 257          0 -> W.empty
 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)
 260         where
 261                 int2 :: Int -> Doc
 262                 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
 263                 sep :: Char -> Doc
 264                 sep = W.bold . W.dullblack . W.char
 265
 266 -- * Printing 'Comment'
 267
 268 comment :: Comment -> Doc
 269 comment com =
 270         W.cyan $ do
 271                 W.char Read.comment_begin
 272                 <> (case Text.uncons com of
 273                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 274                  _ -> W.empty)
 275                 <> do W.if_color colorize (W.strict_text com)
 276         where
 277                 colorize :: Doc
 278                 colorize =
 279                         case R.runParser (do
 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
 283                                         return (ns ++ [sh])
 284                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 285                          () "" com of
 286                          Left _ -> W.strict_text com
 287                          Right doc -> doc
 288                 tags :: Stream s m Char => ParsecT s u m Doc
 289                 tags = do
 290                         x <- tag_
 291                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 292                         return $ x <> xs
 293                         where
 294                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 295                                 tag_sep = do
 296                                         s <- R.char Read.tag_sep
 297                                         sh <- R.many R.space_horizontal
 298                                         return $
 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
 302                                 tag_ = do
 303                                         n <- Read.tag_name
 304                                         s <- R.char Read.tag_value_sep
 305                                         v <- Read.tag_value
 306                                         return $
 307                                                 (W.yellow $ W.strict_text n)
 308                                                 <> (W.bold $ W.dullblack $ W.char s)
 309                                                 <> (W.red $ W.strict_text v)
 310
 311 comments :: Doc -> [Comment] -> Doc
 312 comments prefix =
 313         W.hcat .
 314         Data.List.intersperse W.line .
 315         Data.List.map (\c -> prefix <> comment c)
 316
 317 -- * Printing 'Tag'
 318
 319 tag :: Tag -> Doc
 320 tag (n, v) =
 321         (W.dullyellow $ W.strict_text n)
 322         <> W.char Read.tag_value_sep
 323         <> (W.dullred $ W.strict_text v)
 324
 325 -- * Printing 'Posting'
 326
 327 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 328 posting
 329  ( max_account_length
 330  , max_amount_length
 331  )
 332  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                         W.fill (max_account_length) (account type_ acct) <> do
 347                         W.space <> W.space <> do
 348                         W.fill (max 0
 349                          ( max_amount_length
 350                          - (fromIntegral $ amounts_length posting_amounts) )) W.empty <> 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, Int)
 367
 368 nil_Posting_Lengths :: Posting_Lengths
 369 nil_Posting_Lengths = (0, 0)
 370
 371 postings_lengths :: Posting_Type -> Posting_by_Account -> Posting_Lengths -> Posting_Lengths
 372 postings_lengths type_ =
 373         flip $ Data.Map.foldl $ Data.List.foldl $
 374         flip $ \p ->
 375         (max (account_length type_ (posting_account p)))
 376         ***
 377         (max (amounts_length (posting_amounts p)))
 378
 379 -- * Printing 'Transaction'
 380
 381 transaction :: Transaction -> Doc
 382 transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
 383
 384 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 385 transaction_with_lengths
 386  posting_lengths_
 387  Transaction
 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
 398  } = do
 399         (case transaction_comments_before of
 400          [] -> W.empty
 401          _  -> comments W.space transaction_comments_before <> W.line) <> do
 402         (W.hcat $
 403                 Data.List.intersperse
 404                  (W.char Read.date_sep)
 405                  (Data.List.map date (first_date:dates))) <> do
 406         (case status_ of
 407          True -> W.space <> status status_
 408          False -> W.empty) <> do
 409         code code_ <> do
 410         (case transaction_description of
 411          "" -> W.empty
 412          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 413         W.line <> do
 414         (case transaction_comments_after of
 415          [] -> W.empty
 416          _  -> comments W.space transaction_comments_after <> W.line) <> do
 417         W.vsep $ Data.List.map
 418          (\(type_, ps) ->
 419                 W.intercalate W.line
 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)
 427          ]
 428
 429 code :: Ledger.Code -> Doc
 430 code = \x -> case x of
 431          "" -> W.empty
 432          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 433
 434 -- ** Mesuring 'Transaction'
 435
 436 type Transaction_Lengths = Posting_Lengths
 437
 438 nil_Transaction_Lengths :: Posting_Lengths
 439 nil_Transaction_Lengths = nil_Posting_Lengths
 440
 441 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 442 transaction_lengths
 443  Transaction
 444  { transaction_postings
 445  , transaction_virtual_postings
 446  , transaction_balanced_virtual_postings
 447  } posting_lengths_ = do
 448         Data.List.foldl
 449          (flip (\(type_, ps) -> postings_lengths type_ ps))
 450          posting_lengths_
 451          [ (Posting_Type_Regular, transaction_postings)
 452          , (Posting_Type_Virtual, transaction_virtual_postings)
 453          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 454          ]
 455
 456 -- * Printing 'Journal'
 457
 458 journal :: Journal -> Doc
 459 journal Journal
 460  { journal_transactions
 461  } = do
 462         let transaction_lengths_ =
 463                 Data.Map.foldr
 464                  (flip (Data.List.foldr transaction_lengths))
 465                  nil_Transaction_Lengths
 466                  journal_transactions
 467         Data.Foldable.foldr
 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)
 471                 )))
 472          W.empty
 473          journal_transactions
 474
 475 -- * Rendering
 476
 477 data Style
 478  =   Style
 479  { style_align :: Bool
 480  , style_color :: Bool
 481  }
 482 style :: Style
 483 style =
 484         Style
 485          { style_align = True
 486          , style_color = True
 487          }
 488
 489 show :: Style -> Doc -> TL.Text
 490 show Style{style_color, style_align} =
 491         W.displayT .
 492         if style_align
 493         then W.renderPretty style_color 1.0 maxBound
 494         else W.renderCompact style_color
 495
 496 put :: Style -> Handle -> Doc -> IO ()
 497 put Style{style_color, style_align} handle =
 498         W.displayIO handle .
 499         if style_align
 500         then W.renderPretty style_color 1.0 maxBound
 501         else W.renderCompact style_color