lib/Hcompta/Format/Ledger/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 module Hcompta.Format.Ledger.Write where
   7
   8 import           Control.Applicative ((<$>), (<*))
   9 import           Control.Arrow ((***))
  10 import           Data.Decimal (DecimalRaw(..))
  11 import qualified Data.Char (isSpace)
  12 import           Data.Fixed (showFixed)
  13 import qualified Data.List
  14 import qualified Data.Map.Strict as Data.Map
  15 import           Data.Maybe (fromMaybe)
  16 import qualified Data.Text.Lazy as TL
  17 import qualified Data.Text as Text
  18 import qualified Data.Time.Calendar  as Time (toGregorian)
  19 import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
  20 import qualified Hcompta.Lib.Leijen as W
  21 import           Hcompta.Lib.Leijen (Doc, (<>))
  22 import           System.IO (Handle)
  23 import qualified Text.Parsec as R
  24 import           Text.Parsec (Stream, ParsecT)
  25
  26 import qualified Hcompta.Model.Account as Account
  27 import           Hcompta.Model.Account (Account)
  28 import qualified Hcompta.Model.Amount as Amount
  29 import           Hcompta.Model.Amount (Amount)
  30 import qualified Hcompta.Model.Amount.Quantity as Quantity
  31 import           Hcompta.Model.Amount.Quantity (Quantity)
  32 import qualified Hcompta.Model.Amount.Style as Style
  33 import           Hcompta.Model.Amount.Style (Style)
  34 -- import qualified Hcompta.Model.Amount.Unit as Unit
  35 import           Hcompta.Model.Amount.Unit (Unit)
  36 import qualified Hcompta.Model.Transaction as Transaction
  37 import           Hcompta.Model.Transaction (Comment, Tag, Transaction)
  38 import qualified Hcompta.Model.Transaction.Posting as Posting
  39 import           Hcompta.Model.Transaction (Posting)
  40 import qualified Hcompta.Model.Journal as Journal
  41 import           Hcompta.Model.Journal (Journal)
  42 -- import qualified Hcompta.Model.Transaction.Tag as Tag
  43 -- import           Hcompta.Model.Transaction (Tag)
  44 -- import qualified Hcompta.Model.Date as Date
  45 import           Hcompta.Model.Date (Date)
  46 -- import           Hcompta.Format.Ledger.Journal as Journal
  47 import qualified Hcompta.Format.Ledger.Read as Read
  48 import qualified Hcompta.Lib.Parsec as R
  49
  50
  51 -- * Printing 'Account'
  52
  53 account :: Posting.Type -> Account -> Doc
  54 account type_ =
  55         case type_ of
  56          Posting.Type_Regular -> account_
  57          Posting.Type_Virtual -> \acct ->
  58                 W.char Read.posting_type_virtual_begin <> do
  59                 account_ acct <> do
  60                 W.char Read.posting_type_virtual_end
  61          Posting.Type_Virtual_Balanced -> \acct ->
  62                 W.char Read.posting_type_virtual_balanced_begin <> do
  63                 account_ acct <> do
  64                 W.char Read.posting_type_virtual_balanced_end
  65         where
  66                 account_ :: Account -> Doc
  67                 account_ acct =
  68                         W.align $ W.hcat $
  69                                 Data.List.intersperse
  70                                  (W.bold $ W.dullblack $ W.char Read.account_name_sep)
  71                                  (Data.List.map account_name acct)
  72
  73 account_name :: Account.Name -> Doc
  74 account_name = W.strict_text
  75
  76 -- ** Mesuring 'Account'
  77
  78 account_length :: Posting.Type -> Account -> Int
  79 account_length type_ acct =
  80         Data.List.foldl
  81          (\acc -> (1 +) . (acc +) . Text.length)
  82          (if acct == [] then 0 else (- 1)) acct +
  83         case type_ of
  84          Posting.Type_Regular -> 0
  85          Posting.Type_Virtual -> 2
  86          Posting.Type_Virtual_Balanced -> 2
  87
  88 -- * Printing 'Amount'
  89
  90 amount :: Amount -> Doc
  91 amount Amount.Amount
  92  { Amount.quantity=qty
  93  , Amount.style = style@(Style.Style
  94          { Style.unit_side
  95          , Style.unit_spaced
  96          })
  97  , Amount.unit=unit_
  98  } = do
  99         case unit_side of
 100          Just Style.Side_Left ->
 101                 (unit unit_)
 102                 <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 103          _ -> W.empty
 104         <> quantity style qty
 105         <> case unit_side of
 106          (Just Style.Side_Right) ->
 107                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 108                 <> unit unit_
 109          Nothing ->
 110                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 111                 <> unit unit_
 112          _ -> W.empty
 113
 114 unit :: Unit -> Doc
 115 unit = W.yellow . W.strict_text
 116
 117 quantity :: Style -> Quantity -> Doc
 118 quantity Style.Style
 119  { Style.fractioning
 120  , Style.grouping_integral
 121  , Style.grouping_fractional
 122  , Style.precision
 123  } qty = do
 124         let Decimal e n = Quantity.round precision qty
 125         let num = Prelude.show $ abs $ n
 126         let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
 127         case e == 0 || precision == 0 of
 128          True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
 129          False -> do
 130                 let num_len = length num
 131                 let padded =
 132                         Data.List.concat
 133                          [ replicate (fromIntegral e + 1 - num_len) '0'
 134                          , num
 135                          , replicate (fromIntegral precision - fromIntegral e) '0'
 136                          ]
 137                 let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
 138                 let default_fractioning =
 139                         Data.List.head $
 140                         del_grouping_sep grouping_integral $
 141                         del_grouping_sep grouping_fractional $
 142                         ['.', ',']
 143                 sign <> do
 144                 W.bold $ W.blue $ do
 145                         W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
 146                         W.char (fromMaybe default_fractioning fractioning) <> do
 147                         W.text (TL.pack $ maybe id group grouping_fractional frac)
 148         where
 149                 group :: Style.Grouping -> [Char] -> [Char]
 150                 group (Style.Grouping sep sizes_) =
 151                         Data.List.concat . reverse .
 152                         Data.List.map reverse . fst .
 153                         Data.List.foldl
 154                          (flip (\digit -> \case
 155                                  ([], sizes) -> ([[digit]], sizes)
 156                                  (digits:groups, []) -> ((digit:digits):groups, [])
 157                                  (digits:groups, curr_sizes@(size:sizes)) ->
 158                                         if length digits < size
 159                                         then (      (digit:digits):groups, curr_sizes)
 160                                         else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
 161                          ))
 162                          ([], sizes_)
 163                 del_grouping_sep grouping =
 164                         case grouping of
 165                          Just (Style.Grouping sep _) -> Data.List.delete sep
 166                          _ -> id
 167
 168 -- ** Mesuring 'Amount'
 169
 170 amount_length :: Amount -> Int
 171 amount_length Amount.Amount
 172  { Amount.quantity=qty
 173  , Amount.style = style@(Style.Style
 174          { Style.unit_spaced
 175          })
 176  , Amount.unit=unit_
 177  } = do
 178         Text.length unit_
 179         + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
 180         + quantity_length style qty
 181
 182 amounts_length :: Amount.By_Unit -> Int
 183 amounts_length amts =
 184         if Data.Map.null amts
 185         then 0
 186         else
 187                 Data.Map.foldr
 188                  (\n -> (3 +) . (+) (amount_length n))
 189                  (-3) amts
 190
 191 quantity_length :: Style -> Quantity -> Int
 192 quantity_length Style.Style
 193  { Style.grouping_integral
 194  , Style.grouping_fractional
 195  , Style.precision
 196  } qty =
 197         let Decimal e n = Quantity.round precision qty in
 198         let sign_len = if n < 0 then 1 else 0 in
 199         let fractioning_len = if e > 0 then 1 else 0 in
 200         let num_len = if n == 0 then 0 else (1 +) $ truncate $ logBase 10 $ (fromIntegral (abs n)::Double) in
 201         let pad_left_len  = max 0 (fromIntegral e + 1 - num_len) in
 202         let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
 203         let padded_len = pad_left_len + num_len + pad_right_len in
 204         let int_len  = max 1 (num_len - fromIntegral precision) in
 205         let frac_len = max 0 (padded_len - int_len) in
 206         ( sign_len
 207         + fractioning_len
 208         + padded_len
 209         + maybe 0 (group int_len)  grouping_integral
 210         + maybe 0 (group frac_len) grouping_fractional
 211         )
 212         where
 213                 group :: Int -> Style.Grouping -> Int
 214                 group num_len (Style.Grouping _sep sizes_) =
 215                         if num_len <= 0
 216                         then 0
 217                         else loop 0 num_len sizes_
 218                         where
 219                                 loop :: Int -> Int -> [Int] -> Int
 220                                 loop pad len =
 221                                         \case
 222                                          [] -> 0
 223                                          sizes@[size] ->
 224                                                 let l = len - size in
 225                                                 if l <= 0 then pad
 226                                                 else loop (pad + 1) l sizes
 227                                          size:sizes ->
 228                                                 let l = len - size in
 229                                                 if l <= 0 then pad
 230                                                 else loop (pad + 1) l sizes
 231
 232 -- * Printing 'Date'
 233
 234 date :: Date -> Doc
 235 date (Time.ZonedTime
 236  (Time.LocalTime day tod)
 237  tz@(Time.TimeZone tz_min _ tz_name)) = do
 238         let (y, mo, d) = Time.toGregorian day
 239         (if y == 0 then W.empty else W.integer y <> sep '/') <> do
 240         int2 mo <> do
 241         sep '/' <> int2 d <> do
 242         (case tod of
 243          Time.TimeOfDay 0 0 0 -> W.empty
 244          Time.TimeOfDay h m s ->
 245                 W.space <> int2 h <> do
 246                 sep ':' <> int2 m <> do
 247                 (case s of
 248                  0 -> W.empty
 249                  _ -> sep ':' <> do
 250                         (if s < 10 then W.char '0' else W.empty) <> do
 251                         W.strict_text $ Text.pack $ showFixed True s)) <> do
 252         (case tz_min of
 253          0 -> W.empty
 254          _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
 255          _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
 256         where
 257                 int2 :: Int -> Doc
 258                 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
 259                 sep :: Char -> Doc
 260                 sep = W.bold . W.dullblack . W.char
 261
 262 -- * Printing 'Comment'
 263
 264 comment :: Comment -> Doc
 265 comment com =
 266         W.cyan $ do
 267                 W.char Read.comment_begin
 268                 <> (case Text.uncons com of
 269                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 270                  _ -> W.empty)
 271                 <> do W.if_color colorize (W.strict_text com)
 272         where
 273                 colorize :: Doc
 274                 colorize =
 275                         case R.runParser (do
 276                                 pre <- R.many $ R.try $ do
 277                                         ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
 278                                         sh <- R.space_horizontal
 279                                         return (ns ++ [sh])
 280                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 281                          () "" com of
 282                          Left _ -> W.strict_text com
 283                          Right doc -> doc
 284                 tags :: Stream s m Char => ParsecT s u m Doc
 285                 tags = do
 286                         x <- tag_
 287                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 288                         return $ x <> xs
 289                         where
 290                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 291                                 tag_sep = do
 292                                         s <- R.char Read.tag_sep
 293                                         sh <- R.many R.space_horizontal
 294                                         return $
 295                                                 do W.bold $ W.dullblack $ W.char s
 296                                                 <> do W.text $ TL.pack sh
 297                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 298                                 tag_ = do
 299                                         n <- Read.tag_name
 300                                         s <- R.char Read.tag_value_sep
 301                                         v <- Read.tag_value
 302                                         return $
 303                                                 (W.yellow $ W.strict_text n)
 304                                                 <> (W.bold $ W.dullblack $ W.char s)
 305                                                 <> (W.red $ W.strict_text v)
 306
 307 comments :: Doc -> [Comment] -> Doc
 308 comments prefix =
 309         W.hcat .
 310         Data.List.intersperse W.line .
 311         Data.List.map (\c -> prefix <> comment c)
 312
 313 -- * Printing 'Tag'
 314
 315 tag :: Tag -> Doc
 316 tag (n, v) =
 317         (W.dullyellow $ W.strict_text n)
 318         <> W.char Read.tag_value_sep
 319         <> (W.dullred $ W.strict_text v)
 320
 321 -- * Printing 'Posting'
 322
 323 posting :: Posting_Lengths -> Posting.Type -> Posting -> Doc
 324 posting
 325  ( max_account_length
 326  , max_amount_length
 327  )
 328  type_
 329  Posting.Posting
 330  { Posting.account=acct
 331  , Posting.amounts
 332  , Posting.comments=cmts
 333  -- , Posting.dates
 334  , Posting.status=status_
 335  -- , Posting.tags
 336  } =
 337         W.char '\t' <> do
 338         status status_ <> do
 339                 case Data.Map.null amounts of
 340                  True -> account type_ acct
 341                  False ->
 342                         W.fill (max_account_length + 2)
 343                          (account type_ acct) <> do
 344                         W.fill (max 0
 345                          ( max_amount_length
 346                          - (fromIntegral $ amounts_length amounts) )) W.empty <> do
 347                         W.intercalate
 348                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 349                          amount amounts
 350         <> (case cmts of
 351          [] -> W.empty
 352          [c] -> W.space <> comment c
 353          _ -> W.line <> do comments (W.text "\t\t") cmts)
 354
 355 status :: Transaction.Status -> Doc
 356 status = \case
 357          True  -> W.char '!'
 358          False -> W.empty
 359
 360 -- ** Mesuring 'Posting'
 361
 362 type Posting_Lengths = (Int, Int)
 363
 364 nil_Posting_Lengths :: Posting_Lengths
 365 nil_Posting_Lengths = (0, 0)
 366
 367 postings_lengths :: Posting.Type -> Posting.By_Account -> Posting_Lengths -> Posting_Lengths
 368 postings_lengths type_ =
 369         flip $ Data.Map.foldl $ Data.List.foldl $
 370         flip $ \p ->
 371         (max (account_length type_ (Posting.account p)))
 372         ***
 373         (max (amounts_length (Posting.amounts p)))
 374
 375 -- * Printing 'Transaction'
 376
 377 transaction :: Transaction -> Doc
 378 transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
 379
 380 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 381 transaction_with_lengths
 382  posting_lengths_
 383  Transaction.Transaction
 384  { Transaction.code=code_
 385  , Transaction.comments_before
 386  , Transaction.comments_after
 387  , Transaction.dates=(first_date, dates)
 388  , Transaction.description
 389  , Transaction.postings
 390  , Transaction.virtual_postings
 391  , Transaction.balanced_virtual_postings
 392  , Transaction.status=status_
 393  -- , Transaction.tags
 394  } = do
 395         (case comments_before of
 396          [] -> W.empty
 397          _  -> comments (W.text "\t") comments_before <> W.line) <> do
 398         (W.hcat $
 399                 Data.List.intersperse
 400                  (W.char Read.date_sep)
 401                  (Data.List.map date (first_date:dates))) <> do
 402         (case status_ of
 403          True -> W.space <> status status_
 404          False -> W.empty) <> do
 405         code code_ <> do
 406         (case description of
 407          "" -> W.empty
 408          _  -> W.space <> (W.dullmagenta $ W.strict_text description)) <> do
 409         W.line <> do
 410         (case comments_after of
 411          [] -> W.empty
 412          _  -> comments (W.text "\t") comments_after <> W.line) <> do
 413         W.vsep $ Data.List.map
 414          (\(type_, ps) ->
 415                 W.intercalate W.line
 416                  (W.intercalate W.line
 417                          (W.vsep . Data.List.map
 418                                  (posting posting_lengths_ type_)))
 419                  (Posting.by_signs_and_account ps))
 420          [ (Posting.Type_Regular, postings)
 421          , (Posting.Type_Virtual, virtual_postings)
 422          , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
 423          ]
 424
 425 code :: Transaction.Code -> Doc
 426 code = \case
 427          "" -> W.empty
 428          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 429
 430 -- ** Mesuring 'Transaction'
 431
 432 type Transaction_Lengths = Posting_Lengths
 433
 434 nil_Transaction_Lengths :: Posting_Lengths
 435 nil_Transaction_Lengths = nil_Posting_Lengths
 436
 437 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 438 transaction_lengths
 439  Transaction.Transaction
 440  { Transaction.postings
 441  , Transaction.virtual_postings
 442  , Transaction.balanced_virtual_postings
 443  } posting_lengths_ = do
 444         Data.List.foldl
 445          (flip (\(type_, ps) -> postings_lengths type_ ps))
 446          posting_lengths_
 447          [ (Posting.Type_Regular, postings)
 448          , (Posting.Type_Virtual, virtual_postings)
 449          , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
 450          ]
 451
 452 -- * Printing 'Journal'
 453
 454 journal :: Journal -> Doc
 455 journal Journal.Journal
 456  { Journal.transactions
 457  } = do
 458         let transaction_lengths_ =
 459                 Data.Map.foldl
 460                  (Data.List.foldl (flip transaction_lengths))
 461                  nil_Transaction_Lengths
 462                  transactions
 463         Data.Map.foldl
 464          (Data.List.foldl (\doc t ->
 465                 (if W.is_empty doc then W.empty else doc <> W.line)
 466                         <> transaction_with_lengths transaction_lengths_ t <> W.line
 467                 ))
 468          W.empty
 469          transactions
 470
 471 -- * Rendering
 472
 473 show :: Bool -> Doc -> TL.Text
 474 show with_color = W.displayT . W.renderPretty with_color 1.0 maxBound
 475
 476 put :: Bool -> Handle -> Doc -> IO ()
 477 put with_color handle = W.displayIO handle . W.renderPretty with_color 1.0 maxBound