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