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 qualified Hcompta.Format.Ledger.Read as 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.read_posting_type_virtual_begin <> do
 120                 account_ acct <> do
 121                 W.char Read.read_posting_type_virtual_end
 122          Posting_Type_Virtual_Balanced -> \acct ->
 123                 W.char Read.read_posting_type_virtual_balanced_begin <> do
 124                 account_ acct <> do
 125                 W.char Read.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.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.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.read_comment_begin
 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.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.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.read_tag
 386                                         return $
 387                                                 foldMap (\s -> W.dullyellow (W.strict_text s) <> do
 388                                                         W.bold $ W.dullblack $ W.char Read.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.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         W.char '\t' <> 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 (W.text "\t ") posting_comments)
 431
 432 write_status :: Status -> Doc
 433 write_status = \x -> case x of
 434          True  -> W.char '!'
 435          False -> W.empty
 436
 437 -- ** Type 'Posting_Lengths'
 438
 439 type Posting_Lengths = (Int)
 440
 441 write_postings_lengths
 442  :: Amount_Styles
 443  -> Map Account [Posting]
 444  -> Posting_Lengths
 445  -> Posting_Lengths
 446 write_postings_lengths styles ps pl =
 447         Data.Foldable.foldr
 448          (\p ->
 449                 max
 450                  ( write_account_length (posting_type p) (posting_account p)
 451                  + write_amounts_length styles (posting_amounts p) )
 452          ) pl
 453          (Data.Functor.Compose.Compose ps)
 454
 455 -- * Write 'Transaction'
 456
 457 write_transaction :: Amount_Styles -> Transaction -> Doc
 458 write_transaction styles t =
 459         write_transaction_with_lengths
 460          styles (write_transaction_lengths styles t 0) t
 461
 462 write_transactions :: Foldable j => Amount_Styles -> j Transaction -> Doc
 463 write_transactions styles j = do
 464         let transaction_lengths_ =
 465                 Data.Foldable.foldr (write_transaction_lengths styles) 0 j
 466         Data.Foldable.foldr
 467          (\t doc ->
 468                 write_transaction_with_lengths styles transaction_lengths_ t <>
 469                 (if W.is_empty doc then W.empty else W.line <> doc)
 470          )
 471          W.empty
 472          j
 473
 474 write_transaction_with_lengths
 475  :: Amount_Styles
 476  -> Transaction_Lengths
 477  -> Transaction -> Doc
 478 write_transaction_with_lengths
 479  styles
 480  posting_lengths_
 481  Transaction
 482  { transaction_code
 483  , transaction_comments_before
 484  , transaction_comments_after
 485  , transaction_dates=(first_date, dates)
 486  , transaction_postings
 487  , transaction_status
 488  -- , transaction_tags
 489  , transaction_wording
 490  } = do
 491         (case transaction_comments_before of
 492          [] -> W.empty
 493          _  -> write_comments W.space transaction_comments_before <> W.line) <> do
 494         (W.hcat $
 495                 List.intersperse
 496                  (W.char Read.read_date_sep)
 497                  (write_date <$> (first_date:dates))) <> do
 498         (case transaction_status of
 499          True -> W.space <> write_status transaction_status
 500          False -> W.empty) <> do
 501         write_code transaction_code <> do
 502         (case transaction_wording of
 503          "" -> W.empty
 504          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
 505         W.line <> do
 506         (case transaction_comments_after of
 507          [] -> W.empty
 508          _  -> write_comments W.space transaction_comments_after <> W.line) <> do
 509         W.intercalate W.line
 510          (W.vsep . fmap (write_posting styles posting_lengths_))
 511          transaction_postings
 512          <> W.line
 513
 514 write_code :: Code -> Doc
 515 write_code = \x -> case x of
 516          "" -> W.empty
 517          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 518
 519 -- ** Type 'Transaction_Lengths'
 520
 521 type Transaction_Lengths = Posting_Lengths
 522
 523 write_transaction_lengths
 524  :: Amount_Styles
 525  -> Transaction
 526  -> Posting_Lengths
 527  -> Posting_Lengths
 528 write_transaction_lengths
 529  styles
 530  Transaction
 531  { transaction_postings
 532  } posting_lengths = do
 533         List.foldl'
 534          (flip $ write_postings_lengths styles)
 535          posting_lengths
 536          [ transaction_postings ]
 537
 538 -- * Write 'Journal'
 539
 540 write_journal
 541  :: ( Foldable j
 542     , Monoid (j Transaction)
 543     ) => Journal (j Transaction) -> Doc
 544 write_journal Journal
 545  { journal_amount_styles
 546  , journal_content
 547  } = write_transactions journal_amount_styles journal_content
 548
 549 -- * Write 'Chart'
 550
 551 write_chart :: Chart -> Doc
 552 write_chart =
 553         TreeMap.foldl_with_Path
 554          (\doc acct (Account_Tags (Tags ca)) ->
 555                 doc <>
 556                 write_account Posting_Type_Regular acct <> W.line <>
 557                 Map.foldlWithKey
 558                  (\dd tn tvs ->
 559                         dd <>
 560                         List.foldl'
 561                          (\ddd tv ->
 562                                 ddd <> W.char '\t' <> write_tag (tn, tv) <> W.line)
 563                          W.empty
 564                          tvs
 565                  )
 566                  W.empty
 567                  ca
 568          ) W.empty .
 569         Chart.chart_accounts
 570
 571 -- * Type 'Write_Style'
 572
 573 data Write_Style
 574  =   Write_Style
 575  { write_style_align :: Bool
 576  , write_style_color :: Bool
 577  }
 578 write_style :: Write_Style
 579 write_style =
 580         Write_Style
 581          { write_style_align = True
 582          , write_style_color = True
 583          }
 584
 585 -- * Write
 586 write :: Write_Style -> Doc -> TL.Text
 587 write Write_Style
 588  { write_style_color
 589  , write_style_align } =
 590         W.displayT .
 591         if write_style_align
 592         then W.renderPretty  write_style_color 1.0 maxBound
 593         else W.renderCompact write_style_color
 594
 595 writeIO :: Write_Style -> Doc -> Handle -> IO ()
 596 writeIO Write_Style
 597  { write_style_color
 598  , write_style_align
 599  } doc handle =
 600         W.displayIO handle $
 601                 if write_style_align
 602                 then W.renderPretty  write_style_color 1.0 maxBound doc
 603                 else W.renderCompact write_style_color doc