lcc/Hcompta/LCC/Write.hs

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