lib/Hcompta/Format/Ledger/Write.hs

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