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.Account.Read as Account.Read
  28 import qualified Hcompta.Amount as Amount
  29 import qualified Hcompta.Amount.Write as Amount.Write
  30 import qualified Hcompta.Format.Ledger as Ledger
  31 import           Hcompta.Format.Ledger
  32                   ( Comment
  33                   , Journal(..)
  34                   , Posting(..), Posting_by_Account
  35                   , Tag
  36                   , Transaction(..)
  37                   )
  38 import qualified Hcompta.Date.Write as Date.Write
  39 import qualified Hcompta.Format.Ledger.Read as Read
  40 -- import           Hcompta.Lib.Consable (Consable(..))
  41 import qualified Hcompta.Lib.Parsec as R
  42 import           Hcompta.Posting (Posting_Type(..))
  43
  44 -- * Write 'Account'
  45
  46 account :: Posting_Type -> Account -> Doc
  47 account type_ =
  48         case type_ of
  49          Posting_Type_Regular -> account_
  50          Posting_Type_Virtual -> \acct ->
  51                 W.char Read.posting_type_virtual_begin <> do
  52                 account_ acct <> do
  53                 W.char Read.posting_type_virtual_end
  54          Posting_Type_Virtual_Balanced -> \acct ->
  55                 W.char Read.posting_type_virtual_balanced_begin <> do
  56                 account_ acct <> do
  57                 W.char Read.posting_type_virtual_balanced_end
  58         where
  59                 account_ :: Account -> Doc
  60                 account_ acct =
  61                         W.align $ W.hcat $
  62                                 Data.List.NonEmpty.toList $
  63                                 Data.List.NonEmpty.intersperse
  64                                  (W.bold $ W.yellow $ W.char Account.Read.section_sep)
  65                                  (Data.List.NonEmpty.map account_name acct)
  66
  67 account_name :: Account.Name -> Doc
  68 account_name = W.strict_text
  69
  70 -- ** Measure 'Account'
  71
  72 account_length :: Posting_Type -> Account -> Int
  73 account_length type_ acct =
  74         Data.Foldable.foldl
  75          (\acc -> (1 +) . (acc +) . Text.length)
  76          (- 1) acct +
  77         case type_ of
  78          Posting_Type_Regular -> 0
  79          Posting_Type_Virtual -> 2
  80          Posting_Type_Virtual_Balanced -> 2
  81
  82 -- ** Measure 'Amount's
  83
  84 amounts_length :: Amount.By_Unit -> Int
  85 amounts_length amts =
  86         if Data.Map.null amts
  87         then 0
  88         else
  89                 Data.Map.foldr
  90                  (\n -> (3 +) . (+) (Amount.Write.amount_length n))
  91                  (-3) amts
  92
  93 -- * Write 'Comment'
  94
  95 comment :: Comment -> Doc
  96 comment com =
  97         W.cyan $ do
  98                 W.char Read.comment_begin
  99                 <> (case Text.uncons com of
 100                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
 101                  _ -> W.empty)
 102                 <> do W.if_color colorize (W.strict_text com)
 103         where
 104                 colorize :: Doc
 105                 colorize =
 106                         case R.runParser (do
 107                                 pre <- R.many $ R.try $ do
 108                                         ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
 109                                         sh <- R.space_horizontal
 110                                         return (ns ++ [sh])
 111                                 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
 112                          () "" com of
 113                          Left _ -> W.strict_text com
 114                          Right doc -> doc
 115                 tags :: Stream s m Char => ParsecT s u m Doc
 116                 tags = do
 117                         x <- tag_
 118                         xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
 119                         return $ x <> xs
 120                         where
 121                                 tag_sep :: Stream s m Char => ParsecT s u m Doc
 122                                 tag_sep = do
 123                                         s <- R.char Read.tag_sep
 124                                         sh <- R.many R.space_horizontal
 125                                         return $
 126                                                 do W.bold $ W.dullblack $ W.char s
 127                                                 <> do W.text $ TL.pack sh
 128                                 tag_ :: Stream s m Char => ParsecT s u m Doc
 129                                 tag_ = do
 130                                         n <- Read.tag_name
 131                                         s <- R.char Read.tag_value_sep
 132                                         v <- Read.tag_value
 133                                         return $
 134                                                 (W.yellow $ W.strict_text n)
 135                                                 <> (W.bold $ W.dullblack $ W.char s)
 136                                                 <> (W.red $ W.strict_text v)
 137
 138 comments :: Doc -> [Comment] -> Doc
 139 comments prefix =
 140         W.hcat .
 141         Data.List.intersperse W.line .
 142         Data.List.map (\c -> prefix <> comment c)
 143
 144 -- * Write 'Tag'
 145
 146 tag :: Tag -> Doc
 147 tag (n, v) =
 148         (W.dullyellow $ W.strict_text n)
 149         <> W.char Read.tag_value_sep
 150         <> (W.dullred $ W.strict_text v)
 151
 152 -- * Write 'Posting'
 153
 154 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 155 posting max_posting_length type_
 156  Posting
 157  { posting_account=acct
 158  , posting_amounts
 159  , posting_comments=cmts
 160  -- , posting_dates
 161  , posting_status=status_
 162  -- , posting_tags
 163  } =
 164         W.char '\t' <> do
 165         status status_ <> do
 166                 case Data.Map.null posting_amounts of
 167                  True -> account type_ acct
 168                  False ->
 169                         let len_acct = account_length type_ acct in
 170                         let len_amts = amounts_length posting_amounts in
 171                         account type_ acct <> do
 172                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
 173                         W.intercalate
 174                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 175                          Amount.Write.amount posting_amounts
 176         <> (case cmts of
 177          [] -> W.empty
 178          [c] -> W.space <> comment c
 179          _ -> W.line <> do comments (W.text "\t ") cmts)
 180
 181 status :: Ledger.Status -> Doc
 182 status = \x -> case x of
 183          True  -> W.char '!'
 184          False -> W.empty
 185
 186 -- ** Measure 'Posting'
 187
 188 type Posting_Lengths = (Int)
 189
 190 postings_lengths
 191  :: Posting_Type
 192  -> Posting_by_Account
 193  -> Posting_Lengths
 194  -> Posting_Lengths
 195 postings_lengths type_ ps pl =
 196         Data.Foldable.foldr
 197          (\p ->
 198                 max
 199                  ( account_length type_ (posting_account p)
 200                  + amounts_length       (posting_amounts p) )
 201          ) pl
 202          (Data.Functor.Compose.Compose ps)
 203
 204 -- * Write 'Transaction'
 205
 206 transaction :: Transaction -> Doc
 207 transaction t = transaction_with_lengths (transaction_lengths t 0) t
 208
 209 transactions :: Foldable ts => ts Transaction -> Doc
 210 transactions ts = do
 211         let transaction_lengths_ =
 212                 Data.Foldable.foldr transaction_lengths 0 ts
 213         Data.Foldable.foldr
 214          (\t doc ->
 215                 transaction_with_lengths transaction_lengths_ t <>
 216                 (if W.is_empty doc then W.empty else W.line <> doc)
 217          )
 218          W.empty
 219          ts
 220
 221 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 222 transaction_with_lengths
 223  posting_lengths_
 224  Transaction
 225  { transaction_code=code_
 226  , transaction_comments_before
 227  , transaction_comments_after
 228  , transaction_dates=(first_date, dates)
 229  , transaction_description
 230  , transaction_postings
 231  , transaction_virtual_postings
 232  , transaction_balanced_virtual_postings
 233  , transaction_status=status_
 234  -- , transaction_tags
 235  } = do
 236         (case transaction_comments_before of
 237          [] -> W.empty
 238          _  -> comments W.space transaction_comments_before <> W.line) <> do
 239         (W.hcat $
 240                 Data.List.intersperse
 241                  (W.char Read.date_sep)
 242                  (Data.List.map Date.Write.date (first_date:dates))) <> do
 243         (case status_ of
 244          True -> W.space <> status status_
 245          False -> W.empty) <> do
 246         code code_ <> do
 247         (case transaction_description of
 248          "" -> W.empty
 249          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 250         W.line <> do
 251         (case transaction_comments_after of
 252          [] -> W.empty
 253          _  -> comments W.space transaction_comments_after <> W.line) <> do
 254         W.vsep
 255          (fmap
 256                  (\(type_, ps) ->
 257                          (W.intercalate W.line
 258                                  (W.vsep . fmap (posting posting_lengths_ type_))
 259                          )
 260                          (ps)
 261                  )
 262                  [ (Posting_Type_Regular         , transaction_postings)
 263                  , (Posting_Type_Virtual         , transaction_virtual_postings)
 264                  , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 265                  ]
 266          ) <> W.line
 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 (uncurry postings_lengths))
 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  , Monoid (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