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