jcc/Hcompta/Format/JCC/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.Format.JCC.Write
   8  ( module Hcompta.Format.JCC.Write
   9  , module Hcompta.Format.JCC.Date.Write
  10  ) where
  11
  12 import           Data.Bool
  13 import           Data.Char (isSpace)
  14 import qualified Data.Foldable
  15 import           Data.Foldable (Foldable(..))
  16 import           Data.Functor (Functor(..), (<$>))
  17 import qualified Data.Functor.Compose
  18 import           Data.List
  19 import qualified Data.List.NonEmpty as NonEmpty
  20 import           Data.Map.Strict (Map)
  21 import qualified Data.Map.Strict as Map
  22 import           Data.Maybe (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)
  28 import           System.IO (Handle)
  29
  30 import qualified Hcompta.Account as Account
  31 import           Hcompta.Account ( Account_Anchor(..)
  32                                  , Account_Tag(..)
  33                                  , Account_Tags(..)
  34                                  )
  35 import qualified Hcompta.Anchor as Anchor
  36 import           Hcompta.Chart (Chart)
  37 import qualified Hcompta.Chart as Chart
  38 import qualified Hcompta.Format.JCC as JCC
  39 import           Hcompta.Format.JCC
  40                   ( Account
  41                   , Comment
  42                   , Journal(..)
  43                   , Posting(..)
  44                   , Transaction(..)
  45                   , Quantity
  46                   , Unit(..)
  47                   )
  48 import qualified Hcompta.Format.JCC.Amount as Amount
  49 import qualified Hcompta.Format.JCC.Amount.Write as Amount.Write
  50 import qualified Hcompta.Format.JCC.Read as Read
  51 -- import           Hcompta.Lib.Consable (Consable(..))
  52 import           Hcompta.Lib.Leijen (Doc, (<>))
  53 import qualified Hcompta.Lib.Leijen as W
  54 import qualified Hcompta.Lib.TreeMap as TreeMap
  55 import qualified Hcompta.Tag as Tag
  56 import           Hcompta.Tag (Tags(..))
  57 import           Hcompta.Anchor (Anchors(..))
  58 import           Hcompta.Transaction ( Transaction_Anchor(..)
  59                                      , Transaction_Anchors(..)
  60                                      , Transaction_Tag(..)
  61                                      , Transaction_Tags(..) )
  62
  63 import           Hcompta.Format.JCC.Date.Write
  64
  65 -- * Write 'Comment'
  66
  67 comment :: Comment -> Doc
  68 comment com =
  69         W.cyan $ do
  70                 W.char Read.comment_begin
  71                 <> (case Text.uncons com of
  72                  Just (c, _) | not $ Data.Char.isSpace c -> W.space
  73                  _ -> W.empty)
  74                 <> W.strict_text com
  75
  76 comments :: Doc -> [Comment] -> Doc
  77 comments prefix =
  78         W.hcat .
  79         Data.List.intersperse W.line .
  80         Data.List.map (\c -> prefix <> comment c)
  81
  82 -- * Write 'Account'
  83
  84 account :: Account -> Doc
  85 account acct =
  86         W.align $ W.hcat $
  87                 NonEmpty.toList $
  88                 fmap (sep <>) $
  89                 (NonEmpty.map account_section acct)
  90         where sep = W.bold $ W.dullblack $ W.char Read.account_section_sep
  91
  92 account_section :: Account.Account_Section Account -> Doc
  93 account_section = W.strict_text
  94
  95 -- ** Measure 'Account'
  96
  97 account_length :: Account -> Int
  98 account_length acct =
  99         Data.Foldable.foldl
 100          (\acc -> (1 +) . (acc +) . Text.length)
 101          0 acct
 102
 103 -- ** Write 'Account_Anchor'
 104
 105 account_anchor :: Account_Anchor -> Doc
 106 account_anchor (Account_Anchor anchor) =
 107         W.hcat $
 108                 (:) (op $ W.char Read.account_anchor_prefix) $
 109                 NonEmpty.toList $
 110                 NonEmpty.intersperse
 111                  (op $ W.char Read.account_anchor_sep)
 112                  (W.strict_text <$> anchor)
 113         where op = W.bold . W.dullyellow
 114
 115 account_anchor_length :: Account_Anchor -> Int
 116 account_anchor_length (Account_Anchor anch) =
 117         Data.Foldable.foldl
 118          (\acc -> (1 +) . (acc +) . Text.length)
 119          0 anch
 120
 121 -- ** Write 'Account_Tag'
 122
 123 account_tag :: Account_Tag -> Doc
 124 account_tag (Account_Tag (path, value)) =
 125         (W.hcat $
 126                 (:) (op $ W.char Read.account_tag_prefix) $
 127                 NonEmpty.toList $
 128                 NonEmpty.intersperse
 129                  (op $ W.char Read.account_tag_sep)
 130                  (W.strict_text <$> path)) <>
 131         if Text.null value
 132         then W.empty
 133         else
 134                 (op $ W.char Read.account_tag_value_prefix) <>
 135                 W.strict_text value
 136         where op = W.bold . W.dullyellow
 137
 138 -- * Write 'Amount'
 139
 140 amounts :: Amount.Styles -> Map Unit Quantity -> Doc
 141 amounts styles =
 142         Map.foldlWithKey
 143          (\doc unit qty ->
 144                 (if W.is_empty doc
 145                 then doc
 146                 else doc <> W.space <>
 147                         (W.bold $ W.yellow $ W.char Read.amount_sep) <>
 148                         W.space) <>
 149                 (Amount.Write.amount $
 150                 Amount.style styles $
 151                 JCC.Amount unit qty))
 152          W.empty
 153
 154 -- ** Measure 'Amount's
 155
 156 amounts_length :: Amount.Styles -> Map Unit Quantity -> Int
 157 amounts_length styles amts =
 158         if Map.null amts
 159         then 0
 160         else
 161                 Map.foldrWithKey
 162                  (\unit qty -> (3 +) . (+)
 163                          (Amount.Write.amount_length $
 164                                 Amount.style styles $
 165                                 JCC.Amount unit qty))
 166                  (-3) amts
 167
 168 -- * Write 'Posting'
 169
 170 posting :: Amount.Styles -> Posting_Lengths -> Posting -> Doc
 171 posting styles max_posting_length
 172  Posting
 173  { posting_account
 174  , posting_account_anchor
 175  , posting_amounts
 176  , posting_comments=cmts
 177  -- , posting_dates
 178  -- , posting_tags
 179  } =
 180         W.string "  " <> do
 181                 let (doc_acct, len_acct) =
 182                         case posting_account_anchor of
 183                          Nothing ->
 184                                 ( account        posting_account
 185                                 , account_length posting_account )
 186                          Just (a, sa) ->
 187                                 ( account_anchor        a <> maybe W.empty account sa
 188                                 , account_anchor_length a + maybe 0 account_length sa )
 189                 case Map.null posting_amounts of
 190                  True -> doc_acct
 191                  False ->
 192                         let len_amts = amounts_length styles posting_amounts in
 193                         doc_acct <>
 194                         W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <>
 195                         amounts styles posting_amounts
 196         <> (case cmts of
 197          []  -> W.empty
 198          [c] -> W.space <> comment c
 199          _   -> W.line <> do comments (W.text "   ") cmts)
 200
 201 -- ** Measure 'Posting'
 202
 203 type Posting_Lengths = (Int)
 204
 205 postings_lengths
 206  :: Amount.Styles
 207  -> Map Account [Posting]
 208  -> Posting_Lengths
 209  -> Posting_Lengths
 210 postings_lengths styles ps pl =
 211         Data.Foldable.foldr
 212          (\p ->
 213                 let len_acct =
 214                         case posting_account_anchor p of
 215                          Nothing -> account_length $ posting_account p
 216                          Just (a, sa) ->
 217                                 account_anchor_length a +
 218                                 maybe 0 account_length sa in
 219                 max
 220                  ( len_acct
 221                  + amounts_length styles (posting_amounts p) )
 222          ) pl
 223          (Data.Functor.Compose.Compose ps)
 224
 225 -- * Write 'Transaction'
 226
 227 transaction :: Amount.Styles -> Transaction -> Doc
 228 transaction styles t = transaction_with_lengths styles (transaction_lengths styles t 0) t
 229
 230 transactions :: Foldable ts => Amount.Styles -> ts Transaction -> Doc
 231 transactions styles ts = do
 232         let transaction_lengths_ =
 233                 Data.Foldable.foldr (transaction_lengths styles) 0 ts
 234         Data.Foldable.foldr
 235          (\t doc ->
 236                 transaction_with_lengths styles transaction_lengths_ t <>
 237                 (if W.is_empty doc then W.empty else W.line <> doc)
 238          )
 239          W.empty
 240          ts
 241
 242 transaction_with_lengths
 243  :: Amount.Styles
 244  -> Transaction_Lengths
 245  -> Transaction -> Doc
 246 transaction_with_lengths
 247  styles
 248  posting_lengths_
 249  Transaction
 250  { transaction_comments
 251  , transaction_dates=(first_date, dates)
 252  , transaction_wording
 253  , transaction_postings
 254  , transaction_anchors=Transaction_Anchors (Anchors anchors)
 255  , transaction_tags=Transaction_Tags (Tags tags)
 256  } = do
 257         (W.hcat $
 258                 Data.List.intersperse
 259                  (W.char Read.date_sep)
 260                  (date <$> (first_date:dates))) <> do
 261         (case transaction_wording of
 262          "" -> W.empty
 263          _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
 264         W.line <> do
 265         (case transaction_comments of
 266          [] -> W.empty
 267          _  -> comments W.space transaction_comments <> W.line) <> do
 268         Map.foldrWithKey
 269          (\path () -> ((W.string "  " <>
 270                 transaction_anchor (Transaction_Anchor path) <> W.line) <>))
 271          W.empty anchors <> do
 272         Map.foldrWithKey
 273          (\path -> flip $
 274                 Data.List.foldr
 275                  (\value -> (<>) (W.string "  " <>
 276                 transaction_tag (Transaction_Tag (path, value)) <> W.line)))
 277          W.empty tags <> do
 278         W.intercalate W.line
 279          (W.vsep . fmap (posting styles posting_lengths_))
 280          transaction_postings <> W.line
 281
 282 -- ** Measure 'Transaction'
 283
 284 type Transaction_Lengths = Posting_Lengths
 285
 286 transaction_lengths
 287  :: Amount.Styles
 288  -> Transaction
 289  -> Posting_Lengths
 290  -> Posting_Lengths
 291 transaction_lengths
 292  styles
 293  Transaction
 294  { transaction_postings
 295  } posting_lengths_ = do
 296         Data.List.foldl
 297          (flip $ postings_lengths styles)
 298          posting_lengths_
 299          [ transaction_postings
 300          ]
 301
 302 -- ** Write 'Transaction_Tag'
 303
 304 transaction_tag :: Transaction_Tag -> Doc
 305 transaction_tag (Transaction_Tag (path, value)) =
 306         (W.hcat $
 307                 (:) (W.bold $ W.dullyellow $ W.char Read.transaction_tag_prefix) $
 308                 NonEmpty.toList $
 309                 NonEmpty.intersperse
 310                  (op $ W.char Read.transaction_tag_sep)
 311                  (transaction_tag_section <$> path)) <>
 312         if Text.null value
 313         then W.empty
 314         else
 315                 (op $ W.char Read.transaction_tag_value_prefix) <>
 316                 W.strict_text value
 317         where
 318                 op = W.bold . W.yellow
 319
 320 transaction_tag_section :: Tag.Section -> Doc
 321 transaction_tag_section = W.bold . W.strict_text
 322
 323 -- ** Write 'Transaction_Anchor'
 324
 325 transaction_anchor :: Transaction_Anchor -> Doc
 326 transaction_anchor (Transaction_Anchor path) =
 327         W.hcat $
 328                 (:) (op $ W.char Read.transaction_anchor_prefix) $
 329                 NonEmpty.toList $
 330                 NonEmpty.intersperse
 331                  (op $ W.char Read.transaction_anchor_sep)
 332                  (transaction_anchor_section <$> path)
 333         where
 334                 op = W.bold . W.yellow
 335
 336 transaction_anchor_section :: Anchor.Section -> Doc
 337 transaction_anchor_section = W.bold . W.strict_text
 338
 339 -- * Write 'Journal'
 340
 341 journal ::
 342  ( Foldable ts
 343  , Monoid (ts Transaction)
 344  ) => Journal (ts Transaction) -> Doc
 345 journal Journal{ journal_content, journal_amount_styles } =
 346         transactions journal_amount_styles journal_content
 347
 348 -- * Write 'Chart'
 349
 350 chart :: Chart Account -> Doc
 351 chart =
 352         TreeMap.foldl_with_Path
 353          (\doc acct (Account_Tags (Tags ca)) ->
 354                 doc <>
 355                 account acct <> W.line <>
 356                 Map.foldlWithKey
 357                  (\dd tn tvs ->
 358                         dd <>
 359                         foldl'
 360                          (\ddd tv ->
 361                                 ddd <> W.string "  " <> account_tag (Account_Tag (tn, tv)) <> W.line)
 362                          W.empty
 363                          tvs
 364                  )
 365                  W.empty
 366                  ca
 367          ) W.empty .
 368         Chart.chart_accounts
 369
 370 -- * Rendering
 371
 372 data Style
 373  =   Style
 374  { style_align :: Bool
 375  , style_color :: Bool
 376  }
 377 style :: Style
 378 style =
 379         Style
 380          { style_align = True
 381          , style_color = True
 382          }
 383
 384 show :: Style -> Doc -> TL.Text
 385 show Style{style_color, style_align} =
 386         W.displayT .
 387         if style_align
 388         then W.renderPretty style_color 1.0 maxBound
 389         else W.renderCompact style_color
 390
 391 put :: Style -> Doc -> Handle -> IO ()
 392 put Style{style_color, style_align} doc handle =
 393         W.displayIO handle $
 394                 if style_align
 395                 then W.renderPretty style_color 1.0 maxBound doc
 396                 else W.renderCompact style_color doc