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