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 ::
 208  ( Foldable ts
 209  , Consable ts Transaction
 210  )
 211  => ts Transaction -> Doc
 212 transactions ts = do
 213         let transaction_lengths_ =
 214                 Data.Foldable.foldr transaction_lengths 0 ts
 215         Data.Foldable.foldr
 216          (\t doc ->
 217                 transaction_with_lengths transaction_lengths_ t <> W.line <>
 218                 (if W.is_empty doc then W.empty else W.line <> doc)
 219          )
 220          W.empty
 221          ts
 222
 223 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 224 transaction_with_lengths
 225  posting_lengths_
 226  Transaction
 227  { transaction_code=code_
 228  , transaction_comments_before
 229  , transaction_comments_after
 230  , transaction_dates=(first_date, dates)
 231  , transaction_description
 232  , transaction_postings
 233  , transaction_virtual_postings
 234  , transaction_balanced_virtual_postings
 235  , transaction_status=status_
 236  -- , transaction_tags
 237  } = do
 238         (case transaction_comments_before of
 239          [] -> W.empty
 240          _  -> comments W.space transaction_comments_before <> W.line) <> do
 241         (W.hcat $
 242                 Data.List.intersperse
 243                  (W.char Read.date_sep)
 244                  (Data.List.map Date.Write.date (first_date:dates))) <> do
 245         (case status_ of
 246          True -> W.space <> status status_
 247          False -> W.empty) <> do
 248         code code_ <> do
 249         (case transaction_description of
 250          "" -> W.empty
 251          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 252         W.line <> do
 253         (case transaction_comments_after of
 254          [] -> W.empty
 255          _  -> comments W.space transaction_comments_after <> W.line) <> do
 256         W.vsep $ Data.List.map
 257          (\(type_, ps) ->
 258                 W.intercalate W.line
 259                  (W.intercalate W.line
 260                          (W.vsep . Data.List.map
 261                                  (posting posting_lengths_ type_)))
 262                  (Ledger.posting_by_Signs_and_Account ps))
 263          [ (Posting_Type_Regular, transaction_postings)
 264          , (Posting_Type_Virtual, transaction_virtual_postings)
 265          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 266          ]
 267
 268 code :: Ledger.Code -> Doc
 269 code = \x -> case x of
 270          "" -> W.empty
 271          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 272
 273 -- ** Measure 'Transaction'
 274
 275 type Transaction_Lengths = Posting_Lengths
 276
 277 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 278 transaction_lengths
 279  Transaction
 280  { transaction_postings
 281  , transaction_virtual_postings
 282  , transaction_balanced_virtual_postings
 283  } posting_lengths_ = do
 284         Data.List.foldl
 285          (flip (\(type_, ps) -> postings_lengths type_ ps))
 286          posting_lengths_
 287          [ (Posting_Type_Regular, transaction_postings)
 288          , (Posting_Type_Virtual, transaction_virtual_postings)
 289          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 290          ]
 291
 292 -- * Write 'Journal'
 293
 294 journal ::
 295  ( Foldable ts
 296  , Consable ts Transaction
 297  ) => Journal ts Transaction -> Doc
 298 journal Journal{ journal_transactions } =
 299         transactions journal_transactions
 300
 301 -- * Rendering
 302
 303 data Style
 304  =   Style
 305  { style_align :: Bool
 306  , style_color :: Bool
 307  }
 308 style :: Style
 309 style =
 310         Style
 311          { style_align = True
 312          , style_color = True
 313          }
 314
 315 show :: Style -> Doc -> TL.Text
 316 show Style{style_color, style_align} =
 317         W.displayT .
 318         if style_align
 319         then W.renderPretty style_color 1.0 maxBound
 320         else W.renderCompact style_color
 321
 322 put :: Style -> Handle -> Doc -> IO ()
 323 put Style{style_color, style_align} handle =
 324         W.displayIO handle .
 325         if style_align
 326         then W.renderPretty style_color 1.0 maxBound
 327         else W.renderCompact style_color