ledger/Hcompta/Format/Ledger/Write.hs

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