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