lib/Hcompta/Format/Ledger/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 module Hcompta.Format.Ledger.Write where
   7
   8 import           Control.Applicative ((<$>), (<*))
   9 import qualified Data.Char (isSpace)
  10 import qualified Data.Functor.Compose
  11 import qualified Data.Foldable
  12 import           Data.Foldable (Foldable)
  13 import qualified Data.List
  14 import qualified Data.List.NonEmpty
  15 import qualified Data.Map.Strict as Data.Map
  16 import qualified Data.Text.Lazy as TL
  17 import qualified Data.Text as Text
  18 import qualified Hcompta.Lib.Leijen as W
  19 import           Hcompta.Lib.Leijen (Doc, (<>))
  20 import           System.IO (Handle)
  21 import qualified Text.Parsec as R hiding (satisfy, char)
  22 import           Text.Parsec (Stream, ParsecT)
  23
  24 import qualified Hcompta.Account as Account
  25 import           Hcompta.Account (Account)
  26 import qualified Hcompta.Amount as Amount
  27 import qualified Hcompta.Amount.Write as Amount.Write
  28 import qualified Hcompta.Format.Ledger as Ledger
  29 import           Hcompta.Format.Ledger
  30                   ( Comment
  31                   , Journal(..)
  32                   , Posting(..), Posting_by_Account, Posting_Type(..)
  33                   , Tag
  34                   , Transaction(..)
  35                   )
  36 import qualified Hcompta.Date.Write as Date.Write
  37 import qualified Hcompta.Format.Ledger.Read as Read
  38 import qualified Hcompta.Lib.Parsec as R
  39
  40 -- * Write 'Account'
  41
  42 account :: Posting_Type -> Account -> Doc
  43 account type_ =
  44         case type_ of
  45          Posting_Type_Regular -> account_
  46          Posting_Type_Virtual -> \acct ->
  47                 W.char Read.posting_type_virtual_begin <> do
  48                 account_ acct <> do
  49                 W.char Read.posting_type_virtual_end
  50          Posting_Type_Virtual_Balanced -> \acct ->
  51                 W.char Read.posting_type_virtual_balanced_begin <> do
  52                 account_ acct <> do
  53                 W.char Read.posting_type_virtual_balanced_end
  54         where
  55                 account_ :: Account -> Doc
  56                 account_ acct =
  57                         W.align $ W.hcat $
  58                                 Data.List.NonEmpty.toList $
  59                                 Data.List.NonEmpty.intersperse
  60                                  (W.bold $ W.yellow $ W.char Read.account_name_sep)
  61                                  (Data.List.NonEmpty.map account_name acct)
  62
  63 account_name :: Account.Name -> Doc
  64 account_name = W.strict_text
  65
  66 -- ** Measure 'Account'
  67
  68 account_length :: Posting_Type -> Account -> Int
  69 account_length type_ acct =
  70         Data.Foldable.foldl
  71          (\acc -> (1 +) . (acc +) . Text.length)
  72          (- 1) acct +
  73         case type_ of
  74          Posting_Type_Regular -> 0
  75          Posting_Type_Virtual -> 2
  76          Posting_Type_Virtual_Balanced -> 2
  77
  78 -- ** Measure 'Amount's
  79
  80 amounts_length :: Amount.By_Unit -> Int
  81 amounts_length amts =
  82         if Data.Map.null amts
  83         then 0
  84         else
  85                 Data.Map.foldr
  86                  (\n -> (3 +) . (+) (Amount.Write.amount_length n))
  87                  (-3) amts
  88
  89 -- * Write 'Comment'
  90
  91 comment :: Comment -> Doc
  92 comment com =
  93         W.cyan $ do
  94                 W.char Read.comment_begin
  95                 <> (case Text.uncons com of
  96                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
  97                  _ -> W.empty)
  98                 <> do W.if_color colorize (W.strict_text com)
  99         where
 100                 colorize :: Doc
 101                 colorize =
 102                         case R.runParser (do
 103                                 pre <- R.many $ R.try $ do
 104                                         ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
 105                                         sh <- R.space_horizontal
 106                                         return (ns ++ [sh])
 107                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 108                          () "" com of
 109                          Left _ -> W.strict_text com
 110                          Right doc -> doc
 111                 tags :: Stream s m Char => ParsecT s u m Doc
 112                 tags = do
 113                         x <- tag_
 114                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 115                         return $ x <> xs
 116                         where
 117                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 118                                 tag_sep = do
 119                                         s <- R.char Read.tag_sep
 120                                         sh <- R.many R.space_horizontal
 121                                         return $
 122                                                 do W.bold $ W.dullblack $ W.char s
 123                                                 <> do W.text $ TL.pack sh
 124                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 125                                 tag_ = do
 126                                         n <- Read.tag_name
 127                                         s <- R.char Read.tag_value_sep
 128                                         v <- Read.tag_value
 129                                         return $
 130                                                 (W.yellow $ W.strict_text n)
 131                                                 <> (W.bold $ W.dullblack $ W.char s)
 132                                                 <> (W.red $ W.strict_text v)
 133
 134 comments :: Doc -> [Comment] -> Doc
 135 comments prefix =
 136         W.hcat .
 137         Data.List.intersperse W.line .
 138         Data.List.map (\c -> prefix <> comment c)
 139
 140 -- * Write 'Tag'
 141
 142 tag :: Tag -> Doc
 143 tag (n, v) =
 144         (W.dullyellow $ W.strict_text n)
 145         <> W.char Read.tag_value_sep
 146         <> (W.dullred $ W.strict_text v)
 147
 148 -- * Write 'Posting'
 149
 150 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 151 posting max_posting_length type_
 152  Posting
 153  { posting_account=acct
 154  , posting_amounts
 155  , posting_comments=cmts
 156  -- , posting_dates
 157  , posting_status=status_
 158  -- , posting_tags
 159  } =
 160         W.char '\t' <> do
 161         status status_ <> do
 162                 case Data.Map.null posting_amounts of
 163                  True -> account type_ acct
 164                  False ->
 165                         let len_acct = account_length type_ acct in
 166                         let len_amts = amounts_length posting_amounts in
 167                         account type_ acct <> do
 168                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
 169                         W.intercalate
 170                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 171                          Amount.Write.amount posting_amounts
 172         <> (case cmts of
 173          [] -> W.empty
 174          [c] -> W.space <> comment c
 175          _ -> W.line <> do comments (W.text "\t ") cmts)
 176
 177 status :: Ledger.Status -> Doc
 178 status = \x -> case x of
 179          True  -> W.char '!'
 180          False -> W.empty
 181
 182 -- ** Measure 'Posting'
 183
 184 type Posting_Lengths = (Int)
 185
 186 postings_lengths
 187  :: Posting_Type
 188  -> Posting_by_Account
 189  -> Posting_Lengths
 190  -> Posting_Lengths
 191 postings_lengths type_ ps pl =
 192         Data.Foldable.foldr
 193          (\p ->
 194                 max
 195                  ( account_length type_ (posting_account p)
 196                  + amounts_length       (posting_amounts p) )
 197          ) pl
 198          (Data.Functor.Compose.Compose ps)
 199
 200 -- * Write 'Transaction'
 201
 202 transaction :: Transaction -> Doc
 203 transaction t = transaction_with_lengths (transaction_lengths t 0) t
 204
 205 transactions :: Foldable f => f Transaction -> Doc
 206 transactions ts = do
 207         let transaction_lengths_ =
 208                 Data.Foldable.foldr transaction_lengths 0 ts
 209         Data.Foldable.foldr
 210          (\t doc ->
 211                 transaction_with_lengths transaction_lengths_ t <> W.line <>
 212                 (if W.is_empty doc then W.empty else W.line <> doc)
 213          )
 214          W.empty
 215          ts
 216
 217 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 218 transaction_with_lengths
 219  posting_lengths_
 220  Transaction
 221  { transaction_code=code_
 222  , transaction_comments_before
 223  , transaction_comments_after
 224  , transaction_dates=(first_date, dates)
 225  , transaction_description
 226  , transaction_postings
 227  , transaction_virtual_postings
 228  , transaction_balanced_virtual_postings
 229  , transaction_status=status_
 230  -- , transaction_tags
 231  } = do
 232         (case transaction_comments_before of
 233          [] -> W.empty
 234          _  -> comments W.space transaction_comments_before <> W.line) <> do
 235         (W.hcat $
 236                 Data.List.intersperse
 237                  (W.char Read.date_sep)
 238                  (Data.List.map Date.Write.date (first_date:dates))) <> do
 239         (case status_ of
 240          True -> W.space <> status status_
 241          False -> W.empty) <> do
 242         code code_ <> do
 243         (case transaction_description of
 244          "" -> W.empty
 245          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 246         W.line <> do
 247         (case transaction_comments_after of
 248          [] -> W.empty
 249          _  -> comments W.space transaction_comments_after <> W.line) <> do
 250         W.vsep $ Data.List.map
 251          (\(type_, ps) ->
 252                 W.intercalate W.line
 253                  (W.intercalate W.line
 254                          (W.vsep . Data.List.map
 255                                  (posting posting_lengths_ type_)))
 256                  (Ledger.posting_by_Signs_and_Account ps))
 257          [ (Posting_Type_Regular, transaction_postings)
 258          , (Posting_Type_Virtual, transaction_virtual_postings)
 259          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 260          ]
 261
 262 code :: Ledger.Code -> Doc
 263 code = \x -> case x of
 264          "" -> W.empty
 265          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 266
 267 -- ** Measure 'Transaction'
 268
 269 type Transaction_Lengths = Posting_Lengths
 270
 271 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 272 transaction_lengths
 273  Transaction
 274  { transaction_postings
 275  , transaction_virtual_postings
 276  , transaction_balanced_virtual_postings
 277  } posting_lengths_ = do
 278         Data.List.foldl
 279          (flip (\(type_, ps) -> postings_lengths type_ ps))
 280          posting_lengths_
 281          [ (Posting_Type_Regular, transaction_postings)
 282          , (Posting_Type_Virtual, transaction_virtual_postings)
 283          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 284          ]
 285
 286 -- * Write 'Journal'
 287
 288 journal :: Journal -> Doc
 289 journal Journal { journal_transactions } =
 290         transactions (Data.Functor.Compose.Compose journal_transactions)
 291
 292 -- * Rendering
 293
 294 data Style
 295  =   Style
 296  { style_align :: Bool
 297  , style_color :: Bool
 298  }
 299 style :: Style
 300 style =
 301         Style
 302          { style_align = True
 303          , style_color = True
 304          }
 305
 306 show :: Style -> Doc -> TL.Text
 307 show Style{style_color, style_align} =
 308         W.displayT .
 309         if style_align
 310         then W.renderPretty style_color 1.0 maxBound
 311         else W.renderCompact style_color
 312
 313 put :: Style -> Handle -> Doc -> IO ()
 314 put Style{style_color, style_align} handle =
 315         W.displayIO handle .
 316         if style_align
 317         then W.renderPretty style_color 1.0 maxBound
 318         else W.renderCompact style_color