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