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                         let amounts_ =
 345                                 W.displayT $ W.renderPretty False 1.0 maxBound $
 346                                 W.intercalate
 347                                  (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 348                                  amount amounts
 349                         W.fill (max 0 (max_amount_length - (fromIntegral $ TL.length amounts_))) W.empty <> do
 350                         W.text amounts_
 351         <> (case cmts of
 352          [] -> W.empty
 353          [c] -> W.space <> comment c
 354          _ -> W.line <> do comments (W.text "\t\t") cmts)
 355
 356 status :: Transaction.Status -> Doc
 357 status = \case
 358          True  -> W.char '!'
 359          False -> W.empty
 360
 361 -- ** Mesuring 'Posting'
 362
 363 type Posting_Lengths = (Int, Int)
 364
 365 nil_Posting_Lengths :: Posting_Lengths
 366 nil_Posting_Lengths = (0, 0)
 367
 368 postings_lengths :: Posting.Type -> Posting.By_Account -> Posting_Lengths -> Posting_Lengths
 369 postings_lengths type_ =
 370         flip $ Data.Map.foldl $ Data.List.foldl $
 371         flip $ \p ->
 372         (max (account_length type_ (Posting.account p)))
 373         ***
 374         (max (amounts_length (Posting.amounts p)))
 375
 376 -- * Printing 'Transaction'
 377
 378 transaction :: Transaction -> Doc
 379 transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
 380
 381 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 382 transaction_with_lengths
 383  posting_lengths_
 384  Transaction.Transaction
 385  { Transaction.code=code_
 386  , Transaction.comments_before
 387  , Transaction.comments_after
 388  , Transaction.dates=(first_date, dates)
 389  , Transaction.description
 390  , Transaction.postings
 391  , Transaction.virtual_postings
 392  , Transaction.balanced_virtual_postings
 393  , Transaction.status=status_
 394  -- , Transaction.tags
 395  } = do
 396         (case comments_before of
 397          [] -> W.empty
 398          _  -> comments (W.text "\t") comments_before <> W.line) <> do
 399         (W.hcat $
 400                 Data.List.intersperse
 401                  (W.char Read.date_sep)
 402                  (Data.List.map date (first_date:dates))) <> do
 403         (case status_ of
 404          True -> W.space <> status status_
 405          False -> W.empty) <> do
 406         code code_ <> do
 407         (case description of
 408          "" -> W.empty
 409          _  -> W.space <> (W.dullmagenta $ W.strict_text description)) <> do
 410         W.line <> do
 411         (case comments_after of
 412          [] -> W.empty
 413          _  -> comments (W.text "\t") comments_after <> W.line) <> do
 414         W.vsep $ Data.List.map
 415          (\(type_, ps) ->
 416                 W.intercalate W.line
 417                  (W.intercalate W.line
 418                          (W.vsep . Data.List.map
 419                                  (posting posting_lengths_ type_)))
 420                  (Posting.by_signs_and_account ps))
 421          [ (Posting.Type_Regular, postings)
 422          , (Posting.Type_Virtual, virtual_postings)
 423          , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
 424          ]
 425
 426 code :: Transaction.Code -> Doc
 427 code = \case
 428          "" -> W.empty
 429          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 430
 431 -- ** Mesuring 'Transaction'
 432
 433 type Transaction_Lengths = Posting_Lengths
 434
 435 nil_Transaction_Lengths :: Posting_Lengths
 436 nil_Transaction_Lengths = nil_Posting_Lengths
 437
 438 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 439 transaction_lengths
 440  Transaction.Transaction
 441  { Transaction.postings
 442  , Transaction.virtual_postings
 443  , Transaction.balanced_virtual_postings
 444  } posting_lengths_ = do
 445         Data.List.foldl
 446          (flip (\(type_, ps) -> postings_lengths type_ ps))
 447          posting_lengths_
 448          [ (Posting.Type_Regular, postings)
 449          , (Posting.Type_Virtual, virtual_postings)
 450          , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
 451          ]
 452
 453 -- * Printing 'Journal'
 454
 455 journal :: Journal -> Doc
 456 journal Journal.Journal
 457  { Journal.transactions
 458  } = do
 459         let transaction_lengths_ =
 460                 Data.Map.foldl
 461                  (Data.List.foldl (flip transaction_lengths))
 462                  nil_Transaction_Lengths
 463                  transactions
 464         Data.Map.foldl
 465          (Data.List.foldl (\doc t ->
 466                 (if W.is_empty doc then W.empty else doc <> W.line)
 467                         <> transaction_with_lengths transaction_lengths_ t <> W.line
 468                 ))
 469          W.empty
 470          transactions
 471
 472 -- * Rendering
 473
 474 show :: Bool -> Doc -> TL.Text
 475 show with_color = W.displayT . W.renderPretty with_color 1.0 maxBound
 476
 477 put :: Bool -> Handle -> Doc -> IO ()
 478 put with_color handle = W.displayIO handle . W.renderPretty with_color 1.0 maxBound