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