ledger/Hcompta/Ledger/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MagicHash #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Hcompta.Ledger.Write where
   9
  10 import           Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
  11 import           Control.Applicative (Applicative(..), (<*))
  12 import           Data.Bool
  13 import           Data.Char (Char, isSpace)
  14 import qualified Data.Char as Char
  15 import           Data.Decimal
  16 import           Data.Either (Either(..))
  17 import           Data.Eq (Eq(..))
  18 import           GHC.Exts (Int(..))
  19 import qualified Data.Foldable
  20 import           Data.Foldable (Foldable(..))
  21 import           Data.Function (($), (.), flip, id)
  22 import           Data.Functor (Functor(..), (<$>))
  23 import qualified Data.Functor.Compose
  24 import           System.IO (IO, Handle)
  25 import           GHC.Integer.Logarithms (integerLogBase#)
  26 import           Data.List ((++))
  27 import qualified Data.List as List
  28 import qualified Data.List.NonEmpty
  29 import           Data.Map.Strict (Map)
  30 import qualified Data.Map.Strict as Map
  31 import           Data.Maybe (Maybe(..), maybe, fromMaybe)
  32 import           Control.Monad (Monad(..))
  33 import           Data.Monoid (Monoid(..), (<>))
  34 import           Data.Ord (Ord(..))
  35 import           Text.Parsec (Stream, ParsecT)
  36 import qualified Text.Parsec as R hiding (satisfy, char)
  37 import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
  38 import qualified Data.Text as Text
  39 import qualified Data.Text.Lazy as TL
  40 import qualified Data.Time.LocalTime as Time
  41 import qualified Data.TreeMap.Strict as TreeMap
  42 import           Data.Tuple (fst)
  43
  44
  45 import qualified Hcompta as H
  46 import           Text.WalderLeijen.ANSI.Text (Doc)
  47 import qualified Text.WalderLeijen.ANSI.Text as W
  48
  49 import           Hcompta.Ledger.Account
  50 import           Hcompta.Ledger.Amount
  51 import           Hcompta.Ledger.Chart
  52 import           Hcompta.Ledger.Posting
  53 import           Hcompta.Ledger.Transaction
  54 import           Hcompta.Ledger.Journal
  55 import           Hcompta.Ledger.Read
  56
  57 -- * Write 'Date'
  58
  59 write_date :: H.Date -> Doc
  60 write_date dat =
  61         let (y, mo, d) = H.date_gregorian dat in
  62         (if y == 0 then W.empty else W.integer y <> sep '-') <>
  63         int2 mo <>
  64         sep '-' <> int2 d <>
  65         (case H.date_tod dat of
  66          Time.TimeOfDay 0 0 0 -> W.empty
  67          Time.TimeOfDay h m s ->
  68                 sep '_' <> int2 h <>
  69                 sep ':' <> int2 m <>
  70                 (case s of
  71                  0 -> W.empty
  72                  _ -> sep ':' <>
  73                         (if s < 10 then W.char '0' else W.empty) <>
  74                         W.strict_text (Text.pack $ show $ (truncate s::Integer))))
  75         -- (case tz_min of
  76         --  0 -> W.empty
  77         --  _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
  78         --  _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
  79         where
  80                 int2 :: Int -> Doc
  81                 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
  82                 sep :: Char -> Doc
  83                 sep = W.bold . W.dullblack . W.char
  84
  85 write_date_length :: H.Date -> Int
  86 write_date_length dat = do
  87         let (y, _, _) = H.date_gregorian dat
  88         (case y of
  89          0 -> 0
  90          _ ->
  91                 (if y < 0 then 1 else 0) -- sign
  92                 + (1 + (I# (integerLogBase# 10 (abs y)))) -- year
  93                 + 1) -- -
  94         + 2 -- month
  95         + 1 -- -
  96         + 2 -- dom
  97         + (case H.date_tod dat of
  98          Time.TimeOfDay 0 0 0 -> 0
  99          Time.TimeOfDay _ _ s ->
 100                 1 -- _
 101                 + 2 -- hour
 102                 + 1 -- :
 103                 + 2 -- min
 104                 + (case s of
 105                  0 -> 0
 106                  _ -> 1 + 2 -- : sec
 107                 )
 108         )
 109
 110 -- * Write 'Account'
 111
 112 write_account :: Posting_Type -> Account -> Doc
 113 write_account type_ =
 114         case type_ of
 115          Posting_Type_Regular -> account_
 116          Posting_Type_Virtual -> \acct ->
 117                 W.char read_posting_type_virtual_begin <>
 118                 account_ acct <>
 119                 W.char read_posting_type_virtual_end
 120          Posting_Type_Virtual_Balanced -> \acct ->
 121                 W.char read_posting_type_virtual_balanced_begin <>
 122                 account_ acct <>
 123                 W.char read_posting_type_virtual_balanced_end
 124         where
 125                 account_ :: Account -> Doc
 126                 account_ acct =
 127                         W.align $ W.hcat $
 128                                 Data.List.NonEmpty.toList $
 129                                 Data.List.NonEmpty.intersperse
 130                                  (W.bold $ W.dullblack $ W.char read_account_section_sep)
 131                                  (Data.List.NonEmpty.map write_account_section acct)
 132
 133 write_account_section :: Account_Section -> Doc
 134 write_account_section = W.strict_text
 135
 136 write_account_length :: Posting_Type -> Account -> Int
 137 write_account_length type_ acct =
 138         Data.Foldable.foldl
 139          (\acc -> (1 +) . (acc +) . Text.length)
 140          (- 1) acct +
 141         case type_ of
 142          Posting_Type_Regular -> 0
 143          Posting_Type_Virtual -> 2
 144          Posting_Type_Virtual_Balanced -> 2
 145
 146 -- * Write 'Amount'
 147
 148 write_amount :: Amount_Styled Amount -> Doc
 149 write_amount
 150  ( sty@(Amount_Style
 151          { amount_style_unit_side
 152          , amount_style_unit_spaced
 153          })
 154  , amt ) =
 155         let unt = H.amount_unit amt in
 156         case amount_style_unit_side of
 157          Just Amount_Style_Side_Left ->
 158                 write_unit unt <>
 159                 case amount_style_unit_spaced of
 160                  Just True | unt /= H.unit_empty -> W.space
 161                  _ -> W.empty
 162          _ -> W.empty
 163         <> write_quantity (sty, H.amount_quantity amt)
 164         <> case amount_style_unit_side of
 165          (Just Amount_Style_Side_Right) ->
 166                 (case amount_style_unit_spaced of
 167                  Just True | unt /= H.unit_empty -> W.space
 168                  _ -> W.empty) <>
 169                 write_unit unt
 170          Nothing ->
 171                 (case amount_style_unit_spaced of
 172                  Just True | unt /= H.unit_empty -> W.space
 173                  _ -> W.empty) <>
 174                 write_unit unt
 175          _ -> W.empty
 176
 177 write_amount_length :: Amount_Styled Amount -> Int
 178 write_amount_length (sty@(Amount_Style { amount_style_unit_spaced }), amt) =
 179         let unt = H.amount_unit amt in
 180         write_unit_length unt
 181         + (case amount_style_unit_spaced of
 182                  { Just True | unt /= H.unit_empty -> 1; _ -> 0 })
 183         + write_quantity_length sty (H.amount_quantity amt)
 184
 185 -- ** Write 'Amount's
 186
 187 write_amounts :: Amount_Styles -> Map Unit Quantity -> Doc
 188 write_amounts styles =
 189         Map.foldlWithKey
 190          (\doc unit qty ->
 191                 (if W.is_empty doc
 192                 then doc
 193                 else doc <> W.space <>
 194                         W.bold (W.yellow $ W.char read_amount_sep) <>
 195                         W.space) <>
 196                 write_amount (amount_styled styles $ Amount unit qty))
 197          W.empty
 198
 199 write_amounts_length :: Amount_Styles -> Map Unit Quantity -> Int
 200 write_amounts_length styles amts =
 201         if Map.null amts
 202         then 0
 203         else
 204                 Map.foldrWithKey
 205                  (\unit qty -> (3 +) . (+)
 206                          (write_amount_length $
 207                                 amount_styled styles $
 208                                 Amount unit qty))
 209                  (-3) amts
 210
 211 -- * Write 'Unit'
 212
 213 write_unit :: Unit -> Doc
 214 write_unit u =
 215         let t = H.unit_text u in
 216         W.yellow $
 217         if Text.all
 218          (\c -> case Char.generalCategory c of
 219                  Char.CurrencySymbol  -> True
 220                  Char.LowercaseLetter -> True
 221                  Char.ModifierLetter  -> True
 222                  Char.OtherLetter     -> True
 223                  Char.TitlecaseLetter -> True
 224                  Char.UppercaseLetter -> True
 225                  _ -> False
 226          ) t
 227         then W.strict_text t
 228         else W.hcat $ W.strict_text <$> ["\"", t, "\""]
 229
 230 write_unit_length :: Unit -> Int
 231 write_unit_length u =
 232         let t = H.unit_text u in
 233         Text.length t +
 234         if Text.all
 235          (\c -> case Char.generalCategory c of
 236                  Char.CurrencySymbol  -> True
 237                  Char.LowercaseLetter -> True
 238                  Char.ModifierLetter  -> True
 239                  Char.OtherLetter     -> True
 240                  Char.TitlecaseLetter -> True
 241                  Char.UppercaseLetter -> True
 242                  _ -> False) t
 243         then 0
 244         else 2
 245
 246 -- * Write 'Quantity'
 247
 248 write_quantity :: Amount_Styled Quantity -> Doc
 249 write_quantity
 250  ( Amount_Style
 251          { amount_style_fractioning
 252          , amount_style_grouping_integral
 253          , amount_style_grouping_fractional
 254          }
 255  , qty ) = do
 256         let Decimal e n = qty
 257         let num = show $ abs $ n
 258         let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
 259         if e == 0
 260          then sign <> W.bold (W.blue $ W.strict_text $ Text.pack num)
 261          else
 262                 let num_len = List.length num in
 263                 let padded =
 264                         List.concat
 265                          [ List.replicate (fromIntegral e + 1 - num_len) '0'
 266                          , num
 267                          -- , replicate (fromIntegral precision - fromIntegral e) '0'
 268                          ] in
 269                 let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded in
 270                 let default_fractioning =
 271                         List.head $
 272                         del_grouping_sep amount_style_grouping_integral $
 273                         del_grouping_sep amount_style_grouping_fractional $
 274                         ['.', ','] in
 275                 sign <>
 276                 W.bold (W.blue $
 277                         W.text (TL.pack $ maybe id
 278                          (\g -> List.reverse . group g . List.reverse)
 279                          amount_style_grouping_integral $ int) <>
 280                         W.yellow (W.char (fromMaybe default_fractioning amount_style_fractioning)) <>
 281                         W.text (TL.pack $ maybe id group amount_style_grouping_fractional frac))
 282         where
 283                 group :: Amount_Style_Grouping -> [Char] -> [Char]
 284                 group (Amount_Style_Grouping sep sizes_) =
 285                         List.concat . List.reverse .
 286                         List.map List.reverse . fst .
 287                         List.foldl'
 288                          (flip (\digit x -> case x of
 289                                  ([], sizes) -> ([[digit]], sizes)
 290                                  (digits:groups, []) -> ((digit:digits):groups, [])
 291                                  (digits:groups, curr_sizes@(size:sizes)) ->
 292                                         if List.length digits < size
 293                                         then (      (digit:digits):groups, curr_sizes)
 294                                         else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
 295                          ))
 296                          ([], sizes_)
 297                 del_grouping_sep grouping =
 298                         case grouping of
 299                          Just (Amount_Style_Grouping sep _) -> List.delete sep
 300                          _ -> id
 301
 302 write_quantity_length :: Amount_Style -> Quantity -> Int
 303 write_quantity_length Amount_Style
 304  { amount_style_grouping_integral
 305  , amount_style_grouping_fractional
 306  } qty =
 307         let Decimal e n     = qty in
 308         let sign_len        = if n < 0 then 1 else 0 in
 309         let fractioning_len = if e > 0 then 1 else 0 in
 310         let num_len         = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
 311         let pad_left_len    = max 0 (fromIntegral e + 1 - num_len) in
 312         -- let pad_right_len   = max 0 (fromIntegral precision - fromIntegral e) in
 313         let padded_len      = pad_left_len + num_len {-+ pad_right_len-} in
 314         let int_len         = max 1 (num_len - fromIntegral e) in
 315         let frac_len        = max 0 (padded_len - int_len) in
 316         ( sign_len
 317         + fractioning_len
 318         + padded_len
 319         + maybe 0 (group int_len)  amount_style_grouping_integral
 320         + maybe 0 (group frac_len) amount_style_grouping_fractional
 321         )
 322         where
 323                 group :: Int -> Amount_Style_Grouping -> Int
 324                 group num_len (Amount_Style_Grouping _sep sizes_) =
 325                         if num_len <= 0
 326                         then 0
 327                         else loop 0 num_len sizes_
 328                         where
 329                                 loop :: Int -> Int -> [Int] -> Int
 330                                 loop pad len x =
 331                                         case x of
 332                                          [] -> 0
 333                                          sizes@[size] ->
 334                                                 let l = len - size in
 335                                                 if l <= 0 then pad
 336                                                 else loop (pad + 1) l sizes
 337                                          size:sizes ->
 338                                                 let l = len - size in
 339                                                 if l <= 0 then pad
 340                                                 else loop (pad + 1) l sizes
 341
 342 -- * Write 'Comment'
 343
 344 write_comment :: Comment -> Doc
 345 write_comment com =
 346         W.cyan $
 347                 W.char read_comment_prefix
 348                 <> (case Text.uncons com of
 349                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 350                  _ -> W.empty)
 351                 <> W.if_color colorize (W.strict_text com)
 352         where
 353                 colorize :: Doc
 354                 colorize =
 355                         case R.runParser (do
 356                                 pre <- R.many $ R.try $ do
 357                                         ns <- R.many $ R.satisfy
 358                                          (\c -> c /= read_tag_value_sep
 359                                                  && not (Data.Char.isSpace c))
 360                                         sh <- R.spaceHorizontal
 361                                         return (ns ++ [sh])
 362                                 ((W.text $ TL.pack $ mconcat pre) <>) <$> tags <* R.eof)
 363                          () "" com of
 364                          Left _ -> W.strict_text com
 365                          Right doc -> doc
 366                 tags :: Stream s m Char => ParsecT s u m Doc
 367                 tags =
 368                         (<>)
 369                          <$> tag_
 370                          <*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
 371                         where
 372                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 373                                 tag_sep = do
 374                                         s <- R.char read_tag_sep
 375                                         sh <- R.many R.spaceHorizontal
 376                                         return $
 377                                                 W.cyan (W.char s) <>
 378                                                 W.text (TL.pack sh)
 379                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 380                                 tag_ = do
 381                                         (p, v) <- read_tag
 382                                         return $
 383                                                 foldMap (\s -> W.dullyellow (W.strict_text s) <>
 384                                                         W.bold (W.dullblack $ W.char read_tag_value_sep)) p <>
 385                                                 W.red (W.strict_text v)
 386
 387 write_comments :: Doc -> [Comment] -> Doc
 388 write_comments prefix =
 389         W.hcat .
 390         List.intersperse W.line .
 391         List.map (\c -> prefix <> write_comment c)
 392
 393 -- * Write 'Tag'
 394
 395 write_tag :: H.Tag -> Doc
 396 write_tag (p, v) =
 397         foldMap (\s ->
 398                 W.dullyellow (W.strict_text s) <>
 399                 W.char read_tag_value_sep) p <>
 400         W.dullred (W.strict_text v)
 401
 402 -- * Write 'Posting'
 403
 404 write_posting :: Amount_Styles -> Posting_Lengths -> Posting -> Doc
 405 write_posting styles max_posting_length
 406  p@Posting
 407  { posting_account
 408  , posting_amounts
 409  , posting_comments
 410  -- , posting_dates
 411  , posting_status
 412  -- , posting_tags
 413  } =
 414         let type_ = posting_type p in
 415         write_indent <>
 416         write_status posting_status <>
 417                 if Map.null posting_amounts
 418                  then write_account type_ posting_account
 419                  else
 420                         let len_acct = write_account_length type_ posting_account in
 421                         let len_amts = write_amounts_length styles posting_amounts in
 422                         write_account type_ posting_account <>
 423                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <>
 424                         write_amounts styles posting_amounts
 425         <> (case posting_comments of
 426          [] -> W.empty
 427          [c] -> W.space <> write_comment c
 428          _ -> W.line <> write_comments (write_indent <> W.space) posting_comments)
 429
 430 write_indent :: Doc
 431 write_indent = W.space <> W.space
 432
 433 write_status :: Status -> Doc
 434 write_status s =
 435         if s
 436          then W.char '!'
 437          else W.empty
 438
 439 -- ** Type 'Posting_Lengths'
 440
 441 type Posting_Lengths = (Int)
 442
 443 write_postings_lengths
 444  :: Amount_Styles
 445  -> Map Account [Posting]
 446  -> Posting_Lengths
 447  -> Posting_Lengths
 448 write_postings_lengths styles ps pl =
 449         Data.Foldable.foldr
 450          (\p ->
 451                 max
 452                  ( write_account_length (posting_type p) (posting_account p)
 453                  + write_amounts_length styles (posting_amounts p) )
 454          ) pl
 455          (Data.Functor.Compose.Compose ps)
 456
 457 -- * Write 'Transaction'
 458
 459 write_transaction :: Amount_Styles -> Transaction -> Doc
 460 write_transaction styles t =
 461         write_transaction_with_lengths
 462          styles (write_transaction_lengths styles t 0) t
 463
 464 write_transactions :: Foldable j => Amount_Styles -> j Transaction -> Doc
 465 write_transactions styles j = do
 466         let transaction_lengths_ =
 467                 Data.Foldable.foldr (write_transaction_lengths styles) 0 j
 468         Data.Foldable.foldr
 469          (\t doc ->
 470                 write_transaction_with_lengths styles transaction_lengths_ t <>
 471                 (if W.is_empty doc then W.empty else W.line <> doc)
 472          )
 473          W.empty
 474          j
 475
 476 write_transaction_with_lengths
 477  :: Amount_Styles
 478  -> Transaction_Lengths
 479  -> Transaction -> Doc
 480 write_transaction_with_lengths
 481  styles
 482  posting_lengths_
 483  Transaction
 484  { transaction_code
 485  , transaction_comments_before
 486  , transaction_comments_after
 487  , transaction_dates=(first_date, dates)
 488  , transaction_postings
 489  , transaction_status
 490  -- , transaction_tags
 491  , transaction_wording
 492  } =
 493         (case transaction_comments_before of
 494          [] -> W.empty
 495          _  -> write_comments W.space transaction_comments_before <> W.line) <>
 496         W.hcat
 497          (List.intersperse
 498                  (W.char read_date_ymd_sep)
 499                  (write_date <$> (first_date:dates))) <>
 500         (if transaction_status
 501          then W.space <> write_status transaction_status
 502          else W.empty) <>
 503         write_code transaction_code <>
 504         (case transaction_wording of
 505          "" -> W.empty
 506          _  -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
 507         W.line <>
 508         (case transaction_comments_after of
 509          [] -> W.empty
 510          _  -> write_comments W.space transaction_comments_after <> W.line) <>
 511         W.intercalate W.line
 512          (W.vsep . fmap (write_posting styles posting_lengths_))
 513          transaction_postings
 514          <> W.line
 515
 516 write_code :: Code -> Doc
 517 write_code c =
 518         case c of
 519          "" -> W.empty
 520          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 521
 522 -- ** Type 'Transaction_Lengths'
 523
 524 type Transaction_Lengths = Posting_Lengths
 525
 526 write_transaction_lengths
 527  :: Amount_Styles
 528  -> Transaction
 529  -> Posting_Lengths
 530  -> Posting_Lengths
 531 write_transaction_lengths
 532  styles
 533  Transaction
 534  { transaction_postings
 535  } posting_lengths =
 536         List.foldl'
 537          (flip $ write_postings_lengths styles)
 538          posting_lengths
 539          [ transaction_postings ]
 540
 541 -- * Write 'Journal'
 542
 543 write_journal
 544  :: ( Foldable j
 545     , Monoid (j Transaction)
 546     ) => Journal (j Transaction) -> Doc
 547 write_journal Journal
 548  { journal_amount_styles
 549  , journal_content
 550  } = write_transactions journal_amount_styles journal_content
 551
 552 -- * Write 'Chart'
 553
 554 write_chart :: Chart -> Doc
 555 write_chart =
 556         TreeMap.foldl_with_Path
 557          (\doc acct (H.Account_Tags (H.Tags ca)) ->
 558                 doc <>
 559                 write_account Posting_Type_Regular acct <> W.line <>
 560                 Map.foldlWithKey
 561                  (\dd tn tvs ->
 562                         dd <>
 563                         List.foldl'
 564                          (\ddd tv ->
 565                                 ddd <> write_indent <> write_tag (tn, tv) <> W.line)
 566                          W.empty
 567                          tvs
 568                  )
 569                  W.empty
 570                  ca
 571          ) W.empty .
 572         chart_accounts
 573
 574 -- * Type 'Write_Style'
 575
 576 data Write_Style
 577  =   Write_Style
 578  { write_style_align :: Bool
 579  , write_style_color :: Bool
 580  }
 581 write_style :: Write_Style
 582 write_style =
 583         Write_Style
 584          { write_style_align = True
 585          , write_style_color = True
 586          }
 587
 588 -- * Write
 589 write :: Write_Style -> Doc -> TL.Text
 590 write Write_Style
 591  { write_style_color
 592  , write_style_align } =
 593         W.displayT .
 594         if write_style_align
 595         then W.renderPretty  write_style_color 1.0 maxBound
 596         else W.renderCompact write_style_color
 597
 598 writeIO :: Write_Style -> Doc -> Handle -> IO ()
 599 writeIO Write_Style
 600  { write_style_color
 601  , write_style_align
 602  } doc handle =
 603         W.displayIO handle $
 604                 if write_style_align
 605                 then W.renderPretty  write_style_color 1.0 maxBound doc
 606                 else W.renderCompact write_style_color doc