lib/Hcompta/Format/Ledger/Write.hs

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