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