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 <>
 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
 253          (fmap
 254                  (\(type_, ps) ->
 255                          (W.intercalate W.line
 256                                  (W.vsep . fmap (posting posting_lengths_ type_))
 257                          )
 258                          (ps)
 259                  )
 260                  [ (Posting_Type_Regular         , transaction_postings)
 261                  , (Posting_Type_Virtual         , transaction_virtual_postings)
 262                  , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 263                  ]
 264          ) <> W.line
 265
 266 code :: Ledger.Code -> Doc
 267 code = \x -> case x of
 268          "" -> W.empty
 269          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 270
 271 -- ** Measure 'Transaction'
 272
 273 type Transaction_Lengths = Posting_Lengths
 274
 275 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 276 transaction_lengths
 277  Transaction
 278  { transaction_postings
 279  , transaction_virtual_postings
 280  , transaction_balanced_virtual_postings
 281  } posting_lengths_ = do
 282         Data.List.foldl
 283          (flip (uncurry postings_lengths))
 284          posting_lengths_
 285          [ (Posting_Type_Regular, transaction_postings)
 286          , (Posting_Type_Virtual, transaction_virtual_postings)
 287          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 288          ]
 289
 290 -- * Write 'Journal'
 291
 292 journal ::
 293  ( Foldable ts
 294  , Monoid (ts Transaction)
 295  ) => Journal (ts Transaction) -> Doc
 296 journal Journal{ journal_transactions } =
 297         transactions journal_transactions
 298
 299 -- * Rendering
 300
 301 data Style
 302  =   Style
 303  { style_align :: Bool
 304  , style_color :: Bool
 305  }
 306 style :: Style
 307 style =
 308         Style
 309          { style_align = True
 310          , style_color = True
 311          }
 312
 313 show :: Style -> Doc -> TL.Text
 314 show Style{style_color, style_align} =
 315         W.displayT .
 316         if style_align
 317         then W.renderPretty style_color 1.0 maxBound
 318         else W.renderCompact style_color
 319
 320 put :: Style -> Handle -> Doc -> IO ()
 321 put Style{style_color, style_align} handle =
 322         W.displayIO handle .
 323         if style_align
 324         then W.renderPretty style_color 1.0 maxBound
 325         else W.renderCompact style_color