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                   , 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 import           Hcompta.Posting (Posting_Type(..))
  42 import           Hcompta.Tag (Tag)
  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                         (<>)
 118                          <$> tag_
 119                          <*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
 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                                         (p, v) <- Read.tag
 131                                         return $
 132                                                 foldMap (\s -> W.dullyellow (W.strict_text s) <> do
 133                                                         W.bold $ W.dullblack $ W.char Read.tag_value_sep) p <>
 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 (p, v) =
 146         foldMap (\s -> W.dullyellow (W.strict_text s) <> W.char Read.tag_value_sep) p <>
 147         (W.dullred $ W.strict_text v)
 148
 149 -- * Write 'Posting'
 150
 151 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
 152 posting max_posting_length type_
 153  Posting
 154  { posting_account=acct
 155  , posting_amounts
 156  , posting_comments=cmts
 157  -- , posting_dates
 158  , posting_status=status_
 159  -- , posting_tags
 160  } =
 161         W.char '\t' <> do
 162         status status_ <> do
 163                 case Data.Map.null posting_amounts of
 164                  True -> account type_ acct
 165                  False ->
 166                         let len_acct = account_length type_ acct in
 167                         let len_amts = amounts_length posting_amounts in
 168                         account type_ acct <> do
 169                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
 170                         W.intercalate
 171                          (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
 172                          Amount.Write.amount posting_amounts
 173         <> (case cmts of
 174          [] -> W.empty
 175          [c] -> W.space <> comment c
 176          _ -> W.line <> do comments (W.text "\t ") cmts)
 177
 178 status :: Ledger.Status -> Doc
 179 status = \x -> case x of
 180          True  -> W.char '!'
 181          False -> W.empty
 182
 183 -- ** Measure 'Posting'
 184
 185 type Posting_Lengths = (Int)
 186
 187 postings_lengths
 188  :: Posting_Type
 189  -> Posting_by_Account
 190  -> Posting_Lengths
 191  -> Posting_Lengths
 192 postings_lengths type_ ps pl =
 193         Data.Foldable.foldr
 194          (\p ->
 195                 max
 196                  ( account_length type_ (posting_account p)
 197                  + amounts_length       (posting_amounts p) )
 198          ) pl
 199          (Data.Functor.Compose.Compose ps)
 200
 201 -- * Write 'Transaction'
 202
 203 transaction :: Transaction -> Doc
 204 transaction t = transaction_with_lengths (transaction_lengths t 0) t
 205
 206 transactions :: Foldable ts => ts Transaction -> Doc
 207 transactions ts = do
 208         let transaction_lengths_ =
 209                 Data.Foldable.foldr transaction_lengths 0 ts
 210         Data.Foldable.foldr
 211          (\t doc ->
 212                 transaction_with_lengths transaction_lengths_ t <>
 213                 (if W.is_empty doc then W.empty else W.line <> doc)
 214          )
 215          W.empty
 216          ts
 217
 218 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 219 transaction_with_lengths
 220  posting_lengths_
 221  Transaction
 222  { transaction_code=code_
 223  , transaction_comments_before
 224  , transaction_comments_after
 225  , transaction_dates=(first_date, dates)
 226  , transaction_description
 227  , transaction_postings
 228  , transaction_virtual_postings
 229  , transaction_balanced_virtual_postings
 230  , transaction_status=status_
 231  -- , transaction_tags
 232  } = do
 233         (case transaction_comments_before of
 234          [] -> W.empty
 235          _  -> comments W.space transaction_comments_before <> W.line) <> do
 236         (W.hcat $
 237                 Data.List.intersperse
 238                  (W.char Read.date_sep)
 239                  (Data.List.map Date.Write.date (first_date:dates))) <> do
 240         (case status_ of
 241          True -> W.space <> status status_
 242          False -> W.empty) <> do
 243         code code_ <> do
 244         (case transaction_description of
 245          "" -> W.empty
 246          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
 247         W.line <> do
 248         (case transaction_comments_after of
 249          [] -> W.empty
 250          _  -> comments W.space transaction_comments_after <> W.line) <> do
 251         W.vsep
 252          (fmap
 253                  (\(type_, ps) ->
 254                          (W.intercalate W.line
 255                                  (W.vsep . fmap (posting posting_lengths_ type_))
 256                          )
 257                          (ps)
 258                  )
 259                  [ (Posting_Type_Regular         , transaction_postings)
 260                  , (Posting_Type_Virtual         , transaction_virtual_postings)
 261                  , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 262                  ]
 263          ) <> W.line
 264
 265 code :: Ledger.Code -> Doc
 266 code = \x -> case x of
 267          "" -> W.empty
 268          t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 269
 270 -- ** Measure 'Transaction'
 271
 272 type Transaction_Lengths = Posting_Lengths
 273
 274 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 275 transaction_lengths
 276  Transaction
 277  { transaction_postings
 278  , transaction_virtual_postings
 279  , transaction_balanced_virtual_postings
 280  } posting_lengths_ = do
 281         Data.List.foldl
 282          (flip (uncurry postings_lengths))
 283          posting_lengths_
 284          [ (Posting_Type_Regular, transaction_postings)
 285          , (Posting_Type_Virtual, transaction_virtual_postings)
 286          , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
 287          ]
 288
 289 -- * Write 'Journal'
 290
 291 journal ::
 292  ( Foldable ts
 293  , Monoid (ts Transaction)
 294  ) => Journal (ts Transaction) -> Doc
 295 journal Journal{ journal_transactions } =
 296         transactions journal_transactions
 297
 298 -- * Rendering
 299
 300 data Style
 301  =   Style
 302  { style_align :: Bool
 303  , style_color :: Bool
 304  }
 305 style :: Style
 306 style =
 307         Style
 308          { style_align = True
 309          , style_color = True
 310          }
 311
 312 show :: Style -> Doc -> TL.Text
 313 show Style{style_color, style_align} =
 314         W.displayT .
 315         if style_align
 316         then W.renderPretty style_color 1.0 maxBound
 317         else W.renderCompact style_color
 318
 319 put :: Style -> Handle -> Doc -> IO ()
 320 put Style{style_color, style_align} handle =
 321         W.displayIO handle .
 322         if style_align
 323         then W.renderPretty style_color 1.0 maxBound
 324         else W.renderCompact style_color