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