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