lib/Hcompta/Format/Ledger/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Hcompta.Format.Ledger.Write where
   6
   7 import           Control.Applicative ((<$>), (<*))
   8 import           Control.Arrow ((***))
   9 import           Data.Decimal (DecimalRaw(..))
  10 import qualified Data.Char (isSpace)
  11 import           Data.Fixed (showFixed)
  12 import qualified Data.Foldable
  13 import qualified Data.List
  14 import qualified Data.List.NonEmpty
  15 import qualified Data.Map.Strict as Data.Map
  16 import           Data.Maybe (fromMaybe)
  17 import qualified Data.Text.Lazy as TL
  18 import qualified Data.Text as Text
  19 import qualified Data.Time.Calendar  as Time (toGregorian)
  20 import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
  21 import qualified Hcompta.Lib.Leijen as W
  22 import           Hcompta.Lib.Leijen (Doc, (<>))
  23 import           System.IO (Handle)
  24 import qualified Text.Parsec as R hiding (satisfy, char)
  25 import           Text.Parsec (Stream, ParsecT)
  26
  27 import qualified Hcompta.Model.Account as Account
  28 import           Hcompta.Model.Account (Account)
  29 import qualified Hcompta.Model.Amount as Amount
  30 import           Hcompta.Model.Amount (Amount)
  31 import qualified Hcompta.Model.Amount.Quantity as Quantity
  32 import           Hcompta.Model.Amount.Quantity (Quantity)
  33 import qualified Hcompta.Model.Amount.Style as Amount.Style
  34 import qualified Hcompta.Model.Amount.Unit as Unit
  35 import           Hcompta.Model.Amount.Unit (Unit)
  36 import qualified Hcompta.Format.Ledger as Ledger
  37 import           Hcompta.Format.Ledger
  38                   ( Comment
  39                   , Journal(..)
  40                   , Posting(..), Posting_by_Account, Posting_Type(..)
  41                   , Tag
  42                   , Transaction(..)
  43                   )
  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.NonEmpty.toList $
  70                                 Data.List.NonEmpty.intersperse
  71                                  (W.bold $ W.yellow $ W.char Read.account_name_sep)
  72                                  (Data.List.NonEmpty.map account_name acct)
  73
  74 account_name :: Account.Name -> Doc
  75 account_name = W.strict_text
  76
  77 -- ** Mesuring 'Account'
  78
  79 account_length :: Posting_Type -> Account -> Int
  80 account_length type_ acct =
  81         Data.Foldable.foldl
  82          (\acc -> (1 +) . (acc +) . Text.length)
  83          (- 1) acct +
  84         case type_ of
  85          Posting_Type_Regular -> 0
  86          Posting_Type_Virtual -> 2
  87          Posting_Type_Virtual_Balanced -> 2
  88
  89 -- * Printing 'Amount'
  90
  91 amount :: Amount -> Doc
  92 amount Amount.Amount
  93  { Amount.quantity=qty
  94  , Amount.style = sty@(Amount.Style.Style
  95          { Amount.Style.unit_side
  96          , Amount.Style.unit_spaced
  97          })
  98  , Amount.unit=unit_
  99  } = do
 100         case unit_side of
 101          Just Amount.Style.Side_Left ->
 102                 (unit unit_)
 103                 <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 104          _ -> W.empty
 105         <> quantity sty qty
 106         <> case unit_side of
 107          (Just Amount.Style.Side_Right) ->
 108                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 109                 <> unit unit_
 110          Nothing ->
 111                 (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
 112                 <> unit unit_
 113          _ -> W.empty
 114
 115 unit :: Unit -> Doc
 116 unit = W.yellow . W.strict_text . Unit.text
 117
 118 quantity :: Amount.Style -> Quantity -> Doc
 119 quantity Amount.Style.Style
 120  { Amount.Style.fractioning
 121  , Amount.Style.grouping_integral
 122  , Amount.Style.grouping_fractional
 123  , Amount.Style.precision
 124  } qty = do
 125         let Decimal e n = Quantity.round precision qty
 126         let num = Prelude.show $ abs $ n
 127         let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
 128         case e == 0 || precision == 0 of
 129          True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
 130          False -> do
 131                 let num_len = length num
 132                 let padded =
 133                         Data.List.concat
 134                          [ replicate (fromIntegral e + 1 - num_len) '0'
 135                          , num
 136                          , replicate (fromIntegral precision - fromIntegral e) '0'
 137                          ]
 138                 let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
 139                 let default_fractioning =
 140                         Data.List.head $
 141                         del_grouping_sep grouping_integral $
 142                         del_grouping_sep grouping_fractional $
 143                         ['.', ',']
 144                 sign <> do
 145                 W.bold $ W.blue $ do
 146                         W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
 147                         (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
 148                         W.text (TL.pack $ maybe id group grouping_fractional frac)
 149         where
 150                 group :: Amount.Style.Grouping -> [Char] -> [Char]
 151                 group (Amount.Style.Grouping sep sizes_) =
 152                         Data.List.concat . reverse .
 153                         Data.List.map reverse . fst .
 154                         Data.List.foldl
 155                          (flip (\digit -> \x -> case x of
 156                                  ([], sizes) -> ([[digit]], sizes)
 157                                  (digits:groups, []) -> ((digit:digits):groups, [])
 158                                  (digits:groups, curr_sizes@(size:sizes)) ->
 159                                         if length digits < size
 160                                         then (      (digit:digits):groups, curr_sizes)
 161                                         else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
 162                          ))
 163                          ([], sizes_)
 164                 del_grouping_sep grouping =
 165                         case grouping of
 166                          Just (Amount.Style.Grouping sep _) -> Data.List.delete sep
 167                          _ -> id
 168
 169 -- ** Mesuring 'Amount'
 170
 171 amount_length :: Amount -> Int
 172 amount_length Amount.Amount
 173  { Amount.quantity=qty
 174  , Amount.style = sty@(Amount.Style.Style
 175          { Amount.Style.unit_spaced
 176          })
 177  , Amount.unit=unit_
 178  } = do
 179         Unit.length unit_
 180         + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
 181         + quantity_length sty qty
 182
 183 amounts_length :: Amount.By_Unit -> Int
 184 amounts_length amts =
 185         if Data.Map.null amts
 186         then 0
 187         else
 188                 Data.Map.foldr
 189                  (\n -> (3 +) . (+) (amount_length n))
 190                  (-3) amts
 191
 192 quantity_length :: Amount.Style -> Quantity -> Int
 193 quantity_length Amount.Style.Style
 194  { Amount.Style.grouping_integral
 195  , Amount.Style.grouping_fractional
 196  , Amount.Style.precision
 197  } qty =
 198         let Decimal e n = Quantity.round precision qty in
 199         let sign_len = if n < 0 then 1 else 0 in
 200         let fractioning_len = if e > 0 then 1 else 0 in
 201         let num_len = if n == 0 then 0 else (1 +) $ truncate $ logBase 10 $ (fromIntegral (abs n)::Double) in
 202         let pad_left_len  = max 0 (fromIntegral e + 1 - num_len) in
 203         let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
 204         let padded_len = pad_left_len + num_len + pad_right_len in
 205         let int_len  = max 1 (num_len - fromIntegral precision) in
 206         let frac_len = max 0 (padded_len - int_len) in
 207         ( sign_len
 208         + fractioning_len
 209         + padded_len
 210         + maybe 0 (group int_len)  grouping_integral
 211         + maybe 0 (group frac_len) grouping_fractional
 212         )
 213         where
 214                 group :: Int -> Amount.Style.Grouping -> Int
 215                 group num_len (Amount.Style.Grouping _sep sizes_) =
 216                         if num_len <= 0
 217                         then 0
 218                         else loop 0 num_len sizes_
 219                         where
 220                                 loop :: Int -> Int -> [Int] -> Int
 221                                 loop pad len =
 222                                         \x -> case x of
 223                                          [] -> 0
 224                                          sizes@[size] ->
 225                                                 let l = len - size in
 226                                                 if l <= 0 then pad
 227                                                 else loop (pad + 1) l sizes
 228                                          size:sizes ->
 229                                                 let l = len - size in
 230                                                 if l <= 0 then pad
 231                                                 else loop (pad + 1) l sizes
 232
 233 -- * Printing 'Date'
 234
 235 date :: Date -> Doc
 236 date (Time.ZonedTime
 237  (Time.LocalTime day tod)
 238  tz@(Time.TimeZone tz_min _ tz_name)) = do
 239         let (y, mo, d) = Time.toGregorian day
 240         (if y == 0 then W.empty else W.integer y <> sep '/') <> do
 241         int2 mo <> do
 242         sep '/' <> int2 d <> do
 243         (case tod of
 244          Time.TimeOfDay 0 0 0 -> W.empty
 245          Time.TimeOfDay h m s ->
 246                 W.space <> int2 h <> do
 247                 sep ':' <> int2 m <> do
 248                 (case s of
 249                  0 -> W.empty
 250                  _ -> sep ':' <> do
 251                         (if s < 10 then W.char '0' else W.empty) <> do
 252                         W.strict_text $ Text.pack $ showFixed True s)) <> do
 253         (case tz_min of
 254          0 -> W.empty
 255          _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
 256          _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
 257         where
 258                 int2 :: Int -> Doc
 259                 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
 260                 sep :: Char -> Doc
 261                 sep = W.bold . W.dullblack . W.char
 262
 263 -- * Printing 'Comment'
 264
 265 comment :: Comment -> Doc
 266 comment com =
 267         W.cyan $ do
 268                 W.char Read.comment_begin
 269                 <> (case Text.uncons com of
 270                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 271                  _ -> W.empty)
 272                 <> do W.if_color colorize (W.strict_text com)
 273         where
 274                 colorize :: Doc
 275                 colorize =
 276                         case R.runParser (do
 277                                 pre <- R.many $ R.try $ do
 278                                         ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
 279                                         sh <- R.space_horizontal
 280                                         return (ns ++ [sh])
 281                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 282                          () "" com of
 283                          Left _ -> W.strict_text com
 284                          Right doc -> doc
 285                 tags :: Stream s m Char => ParsecT s u m Doc
 286                 tags = do
 287                         x <- tag_
 288                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 289                         return $ x <> xs
 290                         where
 291                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 292                                 tag_sep = do
 293                                         s <- R.char Read.tag_sep
 294                                         sh <- R.many R.space_horizontal
 295                                         return $
 296                                                 do W.bold $ W.dullblack $ W.char s
 297                                                 <> do W.text $ TL.pack sh
 298                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 299                                 tag_ = do
 300                                         n <- Read.tag_name
 301                                         s <- R.char Read.tag_value_sep
 302                                         v <- Read.tag_value
 303                                         return $
 304                                                 (W.yellow $ W.strict_text n)
 305                                                 <> (W.bold $ W.dullblack $ W.char s)
 306                                                 <> (W.red $ W.strict_text v)
 307
 308 comments :: Doc -> [Comment] -> Doc
 309 comments prefix =
 310         W.hcat .
 311         Data.List.intersperse W.line .
 312         Data.List.map (\c -> prefix <> comment c)
 313
 314 -- * Printing 'Tag'
 315
 316 tag :: Tag -> Doc
 317 tag (n, v) =
 318         (W.dullyellow $ W.strict_text n)
 319         <> W.char Read.tag_value_sep
 320         <> (W.dullred $ W.strict_text v)
 321
 322 -- * Printing 'Posting'
 323
 324 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 325 posting
 326  ( max_account_length
 327  , max_amount_length
 328  )
 329  type_
 330  Posting
 331  { posting_account=acct
 332  , posting_amounts
 333  , posting_comments=cmts
 334  -- , posting_dates
 335  , posting_status=status_
 336  -- , posting_tags
 337  } =
 338         W.char '\t' <> do
 339         status status_ <> do
 340                 case Data.Map.null posting_amounts of
 341                  True -> account type_ acct
 342                  False ->
 343                         W.fill (max_account_length) (account type_ acct) <> do
 344                         W.space <> W.space <> do
 345                         W.fill (max 0
 346                          ( max_amount_length
 347                          - (fromIntegral $ amounts_length posting_amounts) )) W.empty <> do
 348                         W.intercalate
 349                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 350                          amount posting_amounts
 351         <> (case cmts of
 352          [] -> W.empty
 353          [c] -> W.space <> comment c
 354          _ -> W.line <> do comments (W.text "\t ") cmts)
 355
 356 status :: Ledger.Status -> Doc
 357 status = \x -> case x of
 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
 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 transaction_comments_before of
 397          [] -> W.empty
 398          _  -> comments W.space transaction_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 transaction_description of
 408          "" -> W.empty
 409          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 410         W.line <> do
 411         (case transaction_comments_after of
 412          [] -> W.empty
 413          _  -> comments W.space transaction_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                  (Ledger.posting_by_Signs_and_Account ps))
 421          [ (Posting_Type_Regular, transaction_postings)
 422          , (Posting_Type_Virtual, transaction_virtual_postings)
 423          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 424          ]
 425
 426 code :: Ledger.Code -> Doc
 427 code = \x -> case x of
 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
 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, transaction_postings)
 449          , (Posting_Type_Virtual, transaction_virtual_postings)
 450          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 451          ]
 452
 453 -- * Printing 'Journal'
 454
 455 journal :: Journal -> Doc
 456 journal Journal
 457  { journal_transactions
 458  } = do
 459         let transaction_lengths_ =
 460                 Data.Map.foldr
 461                  (flip (Data.List.foldr transaction_lengths))
 462                  nil_Transaction_Lengths
 463                  journal_transactions
 464         Data.Foldable.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          journal_transactions
 471
 472 -- * Rendering
 473
 474 data Style
 475  =   Style
 476  { style_align :: Bool
 477  , style_color :: Bool
 478  }
 479 style :: Style
 480 style =
 481         Style
 482          { style_align = True
 483          , style_color = True
 484          }
 485
 486 show :: Style -> Doc -> TL.Text
 487 show Style{style_color, style_align} =
 488         W.displayT .
 489         if style_align
 490         then W.renderPretty style_color 1.0 maxBound
 491         else W.renderCompact style_color
 492
 493 put :: Style -> Handle -> Doc -> IO ()
 494 put Style{style_color, style_align} handle =
 495         W.displayIO handle .
 496         if style_align
 497         then W.renderPretty style_color 1.0 maxBound
 498         else W.renderCompact style_color