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