lcc/Hcompta/LCC/Document.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MagicHash #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE NamedFieldPuns #-}
   8 {-# LANGUAGE OverloadedStrings #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  12 module Hcompta.LCC.Document where
  13
  14 -- import Control.Monad (Monad)
  15 -- import Data.Time.LocalTime (TimeZone(..))
  16 -- import GHC.Integer.Logarithms (integerLogBase#)
  17 -- import qualified Control.Monad.Classes as MC
  18 -- import qualified Control.Monad.Trans.Reader as R
  19 -- import qualified Data.Time.Calendar  as Time
  20 -- import qualified Data.Time.LocalTime as Time
  21 -- import qualified Hcompta.LCC.Lib.Strict as S
  22 -- import qualified Text.WalderLeijen.ANSI.Text as W
  23 import Control.Monad (Monad(..))
  24 import Data.Bool
  25 import Data.Char (Char)
  26 import Data.Decimal
  27 import Data.Eq (Eq(..))
  28 import Data.Foldable (Foldable(..))
  29 import Data.Function (($), (.), flip, id)
  30 import Data.Functor ((<$>))
  31 import Data.Functor.Compose (Compose(..))
  32 import Data.Maybe (Maybe(..), maybe)
  33 import Data.Ord (Ord(..))
  34 import Data.Semigroup (Semigroup(..))
  35 import Data.Tuple (fst)
  36 import GHC.Exts (Int(..))
  37 import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
  38 import qualified Data.ByteString as BS
  39 import qualified Data.Char as Char
  40 import qualified Data.List as List
  41 import qualified Data.Map.Strict as Map
  42 import qualified Data.MonoTraversable as MT
  43 import qualified Data.NonNull as NonNull
  44 import qualified Data.Strict as S
  45 import qualified Data.Text as Text
  46 import qualified Data.Text.Encoding as Enc
  47 import qualified Data.TreeMap.Strict as TreeMap
  48
  49 import qualified Language.Symantic.Document as D
  50
  51 import qualified Hcompta as H
  52
  53 import Hcompta.LCC.Account
  54 import Hcompta.LCC.Amount
  55 import Hcompta.LCC.Chart
  56 import Hcompta.LCC.Journal
  57 import Hcompta.LCC.Name
  58 import Hcompta.LCC.Posting
  59 import Hcompta.LCC.Tag
  60 import Hcompta.LCC.Transaction
  61 import Hcompta.LCC.Grammar
  62 import Hcompta.LCC.Compta
  63
  64 -- import Debug.Trace (trace)
  65 -- dbg msg x = trace (msg <> " = " <> show x) x
  66
  67 -- * Type 'Context_Write'
  68 data Context_Write
  69  =   Context_Write
  70  {   context_write_account_ref    :: Bool
  71  ,   context_write_amounts        :: Style_Amounts
  72  ,   context_write_width_acct_amt :: Int
  73  }
  74
  75 context_write :: Context_Write
  76 context_write =
  77         Context_Write
  78          { context_write_account_ref    = True
  79          , context_write_amounts        = Style_Amounts Map.empty
  80          , context_write_width_acct_amt = 0
  81          }
  82
  83 -- * Document 'Date'
  84 d_date dat =
  85         let (y, mo, d) = H.date_gregorian dat in
  86         (if y == 0 then D.empty else D.integer y <> sep char_ymd_sep) <>
  87         int2 mo <>
  88         sep char_ymd_sep <> int2 d <>
  89         (case H.date_tod dat of
  90          (0, 0, 0) -> D.empty
  91          (h, m, s) ->
  92                 sep '_' <> int2 h <>
  93                 sep ':' <> int2 m <>
  94                 (case s of
  95                  0 -> D.empty
  96                  _ -> sep ':' <>
  97                         (if s < 10 then D.charH '0' else D.empty) <>
  98                         D.integer ((truncate s::Integer))))
  99         where
 100         int2 i = (if i < 10 then D.charH '0' else D.empty) <> D.int i
 101         sep = D.blacker . D.charH
 102
 103 -- * Document 'Account'
 104 d_account (acct::Account) =
 105         (`MT.ofoldMap` acct) $ \a ->
 106                 D.blacker (D.charH char_account_sep) <>
 107                 d_account_section a
 108 w_account = D.width . D.dim . d_account
 109
 110 d_account_section = D.textH . unName
 111
 112 -- ** Document 'Account_Ref'
 113 d_account_ref (Tag_Path path) =
 114         D.catH $
 115                 (:) (op $ D.charH char_account_tag_prefix) $
 116                 List.intersperse
 117                  (op $ D.charH char_tag_sep)
 118                  (D.textH . unName <$> NonNull.toNullable path)
 119         where op = D.yellower
 120 w_account_ref = D.width . D.dim . d_account_ref
 121
 122 -- ** Document 'Account_Tag'
 123 d_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 124         D.catH (
 125                 (:) (op $ D.charH char_account_tag_prefix) $
 126                 List.intersperse
 127                  (op $ D.charH char_tag_sep)
 128                  (D.textH . unName <$> NonNull.toNullable path) ) <>
 129         if Text.null value
 130         then D.empty
 131         else
 132                 op (D.charH char_tag_data_prefix) <>
 133                 D.textH value
 134         where op = D.yellower
 135
 136 -- * Document 'Amount'
 137 d_amount
 138  ( sty@(Style_Amount
 139          { style_amount_unit_side=uside
 140          , style_amount_unit_spaced=uspaced
 141          })
 142  , Amount u q ) =
 143         case uside of
 144          S.Just L ->
 145                 d_unit u <>
 146                 case uspaced of
 147                  S.Just True | u /= H.unit_empty -> D.space
 148                  _ -> D.empty
 149          _ -> D.empty
 150         <> d_quantity (sty, q)
 151         <> case uside of
 152          S.Just R ->
 153                 (case uspaced of
 154                  S.Just True | u /= H.unit_empty -> D.space
 155                  _ -> D.empty) <>
 156                 d_unit u
 157          S.Nothing ->
 158                 (case uspaced of
 159                  S.Just True | u /= H.unit_empty -> D.space
 160                  _ -> D.empty) <>
 161                 d_unit u
 162          _ -> D.empty
 163 w_amount = D.width . D.dim . d_amount
 164
 165 -- * Document 'Unit'
 166 d_unit u =
 167         let t = H.unit_text u in
 168         D.yellow $
 169         if Text.all
 170          (\c -> case Char.generalCategory c of
 171                  Char.CurrencySymbol  -> True
 172                  Char.LowercaseLetter -> True
 173                  Char.ModifierLetter  -> True
 174                  Char.OtherLetter     -> True
 175                  Char.TitlecaseLetter -> True
 176                  Char.UppercaseLetter -> True
 177                  _ -> False
 178          ) t
 179         then D.textH t
 180         else D.dquote $ D.textH t
 181
 182 -- * Document 'Quantity'
 183 d_quantity
 184  ( Style_Amount
 185          { style_amount_fractioning
 186          , style_amount_grouping_integral
 187          , style_amount_grouping_fractional
 188          }
 189  , qty ) = do
 190         let Decimal e n = qty
 191         let num = show $ abs n
 192         let sign = D.bold $ D.yellow $ D.textH (if n < 0 then "-" else "")
 193         if e == 0
 194          then sign <> D.bold (D.blue $ D.stringH num)
 195          else do
 196                 let num_len = List.length num
 197                 let padded =
 198                         List.concat
 199                          [ List.replicate (fromIntegral e + 1 - num_len) '0'
 200                          , num
 201                          -- , replicate (fromIntegral precision - fromIntegral e) '0'
 202                          ]
 203                 let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
 204                 let default_fractioning =
 205                         List.head $
 206                         del_grouping_sep style_amount_grouping_integral $
 207                         del_grouping_sep style_amount_grouping_fractional $
 208                         ['.', ',']
 209                 sign <>
 210                  D.bold (D.blue $
 211                         D.stringH (S.maybe id
 212                          (\g -> List.reverse . group g . List.reverse)
 213                          style_amount_grouping_integral $ int) <>
 214                         D.yellow (D.charH (S.fromMaybe default_fractioning style_amount_fractioning)) <>
 215                         D.stringH (S.maybe id group style_amount_grouping_fractional frac))
 216         where
 217         group :: Style_Amount_Grouping -> [Char] -> [Char]
 218         group (Style_Amount_Grouping sep sizes_) =
 219                 List.concat . List.reverse .
 220                 List.map List.reverse . fst .
 221                 List.foldl'
 222                  (flip (\digit x -> case x of
 223                          ([], sizes) -> ([[digit]], sizes)
 224                          (digits:groups, []) -> ((digit:digits):groups, [])
 225                          (digits:groups, curr_sizes@(size:sizes)) ->
 226                                 if List.length digits < size
 227                                 then (      (digit:digits):groups, curr_sizes)
 228                                 else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
 229                  ))
 230                  ([], sizes_)
 231         del_grouping_sep grouping =
 232                 case grouping of
 233                  S.Just (Style_Amount_Grouping sep _) -> List.delete sep
 234                  _ -> id
 235
 236 -- * Document 'Comment'
 237 d_comment (Comment com) =
 238         D.cyan $
 239                 D.charH char_comment_prefix
 240                 <> (case Text.uncons com of
 241                  Just (c, _) | not $ Char.isSpace c -> D.space
 242                  _ -> D.empty)
 243                 <> D.textH com
 244
 245 d_comments prefix =
 246         D.catH .
 247         List.intersperse D.eol .
 248         List.map (\c -> prefix <> d_comment c)
 249
 250 -- * Document 'Posting'
 251 d_posting ctx
 252  Posting
 253  { posting_account
 254  , posting_account_ref
 255  , posting_amounts
 256  , posting_comments
 257  -- , posting_dates
 258  -- , posting_tags
 259  } =
 260         let d_indent = D.spaces 2 in
 261         d_indent <>
 262         let (doc_acct, w_acct) =
 263                 case posting_account_ref of
 264                  S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 265                         ( d_account_ref a <> S.maybe D.empty d_account sa
 266                         , w_account_ref a +  S.maybe 0       w_account sa )
 267                  _ -> (d_account posting_account, w_account posting_account) in
 268         (case posting_amounts of
 269          Amounts amts | Map.null amts -> doc_acct
 270          Amounts amts ->
 271                 maybe D.empty id $
 272                 Map.foldlWithKey
 273                  (\mdoc unit qty -> Just $
 274                         let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
 275                         let pad = max 0 $ context_write_width_acct_amt ctx - (w_acct + w_amount amt) in
 276                         (case mdoc of
 277                          Nothing -> D.empty
 278                          Just doc -> doc <> D.eol <> d_indent) <>
 279                         doc_acct <> D.spaces pad <> D.space <> d_amount amt
 280                  ) Nothing amts) <>
 281         (case posting_comments of
 282          []  -> D.empty
 283          [c] -> D.space <> d_comment c
 284          _   -> D.eol   <> d_comments (d_indent <> D.space) posting_comments)
 285 w_posting  ctx = D.width . D.dim . d_posting ctx
 286
 287 -- * Document 'Transaction'
 288 d_transaction ctx
 289  t@Transaction
 290  { transaction_comments
 291  , transaction_dates
 292  , transaction_wording  = Wording transaction_wording
 293  , transaction_postings = Postings transaction_postings
 294  , transaction_tags     = Transaction_Tags (Tags tags)
 295  } =
 296         let ctx' = ctx { context_write_width_acct_amt =
 297                 let w = context_write_width_acct_amt ctx in
 298                 if w == 0
 299                 then w_postings_acct_amt ctx t
 300                 else w } in
 301         D.catH (
 302                 List.intersperse
 303                  (D.charH char_transaction_date_sep)
 304                  (d_date <$> NonNull.toNullable transaction_dates)) <>
 305         (case transaction_wording of
 306          "" -> D.empty
 307          _  -> D.space <> D.magenta (D.textH transaction_wording)) <>
 308         D.eol <>
 309         (case transaction_comments of
 310          [] -> D.empty
 311          _  -> d_comments D.space transaction_comments <> D.eol) <>
 312         TreeMap.foldr_with_Path
 313          (\path -> flip $
 314                 foldr (\value -> (<>) (D.spaces 2 <>
 315                 d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
 316          D.empty tags <>
 317         D.catV (d_posting ctx' <$> Compose transaction_postings)
 318
 319 d_transactions ctx j =
 320         let ctx' = ctx{context_write_width_acct_amt =
 321                 foldr (max . w_postings_acct_amt ctx) 0 j} in
 322         maybe D.empty id $
 323         foldr (\t mdoc -> Just $
 324                 d_transaction ctx' t <>
 325                 case mdoc of
 326                  Nothing  -> D.eol
 327                  Just doc -> D.eol <> D.eol <> doc
 328          ) Nothing j
 329
 330 -- w_postings ctx = MT.ofoldr (max . w_posting ctx) 0
 331 -- | Return the width of given 'Postings',
 332 -- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
 333 w_postings_acct_amt :: H.Get Postings a => Context_Write -> a -> Int
 334 w_postings_acct_amt ctx =
 335         MT.ofoldr (\Posting
 336          { posting_account
 337          , posting_account_ref
 338          , posting_amounts
 339          } -> max $
 340                 let w_acct =
 341                         case posting_account_ref of
 342                          S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 343                                 w_account_ref a + S.maybe 0 w_account sa
 344                          _ -> w_account posting_account in
 345                 let w_amt =
 346                         case posting_amounts of
 347                          Amounts amts | Map.null amts -> 0
 348                          Amounts amts ->
 349                                 Map.foldrWithKey
 350                                  (\unit qty -> max $
 351                                         let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
 352                                         w_amount amt)
 353                                  1 amts in
 354                 w_acct + w_amt
 355          ) 0 .
 356         H.get @Postings
 357
 358 -- ** Document 'Transaction_Tag'
 359 d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 360         D.catH (
 361                 (:) (op $ D.charH char_tag_prefix) $
 362                 List.intersperse
 363                  (op $ D.charH char_tag_sep)
 364                  (d_transaction_tag_section <$> NonNull.toNullable path)) <>
 365         if Text.null value
 366         then D.empty
 367         else op (D.charH char_tag_data_prefix) <> D.textH value
 368         where
 369         op = D.yellower
 370
 371 d_transaction_tag_section = D.bold . D.textH . unName
 372
 373 -- * Document 'Journal'
 374 d_journal ctx jnl =
 375         d_transactions ctx $
 376         Compose $ journal_content jnl
 377
 378 -- * Document 'Journals'
 379 d_journals ctx (Journals js) =
 380         Map.foldl
 381          (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
 382                 doc <>
 383                 d_comment (Comment $ Text.pack jf) <> D.eol <>
 384                 if null jc then D.empty else (D.eol <> d_journal ctx j)
 385          ) D.empty js
 386
 387 -- * Document 'Chart'
 388 d_chart =
 389         TreeMap.foldl_with_Path
 390          (\doc acct (Account_Tags (Tags ca)) ->
 391                 doc <>
 392                 d_account (H.get acct) <> D.eol <>
 393                 TreeMap.foldl_with_Path
 394                  (\doc' tp tvs ->
 395                         doc' <>
 396                         foldl'
 397                          (\doc'' tv ->
 398                                 doc'' <> D.spaces 2 <>
 399                                 d_account_tag (Account_Tag (Tag (Tag_Path tp) tv)) <>
 400                                 D.eol)
 401                          D.empty
 402                          tvs)
 403                  D.empty
 404                  ca
 405          ) D.empty .
 406         chart_accounts
 407
 408 -- * Document 'Terms'
 409 d_terms (ts::Terms) =
 410         Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts
 411
 412 -- * Document 'Compta'
 413 d_compta ctx Compta
 414  { compta_journals=js
 415  , compta_chart=c@Chart{chart_accounts=ca}
 416  , compta_style_amounts=amts
 417  , compta_terms=ts
 418  } =
 419         (if null ts then D.empty else (d_terms ts <> D.eol)) <>
 420         (if TreeMap.null ca then D.empty else (d_chart c <> D.eol)) <>
 421         d_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js
 422
 423 -- * Document 'SourcePos'
 424 d_sourcepos (SourcePos p (PosFile l) (PosFile c)) = do
 425         content <- Enc.decodeUtf8 <$> BS.readFile p
 426         let ls = Text.lines content
 427         let ll = max 1 $ l - size_ctx
 428         let qs =
 429                 List.take (intFrom $ (l - ll) + 1 + size_ctx) $
 430                 List.drop (intFrom $ ll-1) ls
 431         let ns = show <$> List.take (List.length qs) [ll..]
 432         let max_len_n = maximum $ 0 : (List.length <$> ns)
 433         let ns' = (<$> ns) $ \n ->
 434                 List.replicate (max_len_n - List.length n) ' ' <> n
 435         let quote =
 436                 D.catV $
 437                 List.zipWith (\(n, sn) q ->
 438                         D.spaces 2 <> D.blacker (D.stringH sn) <>
 439                         D.spaces 2 <> (if n == l then mark q else D.textH q)
 440                  ) (List.zip [ll..] ns') qs
 441         return $ quote <> D.eol
 442         where
 443         size_ctx = 2
 444         intFrom = fromInteger . toInteger
 445         mark q =
 446                 let (b, a) = Text.splitAt (intFrom c - 1) q in
 447                 D.textH b <>
 448                 case Text.uncons a of
 449                  Nothing -> D.red D.space
 450                  Just (a0, a') -> D.red (D.charH a0) <> D.textH a'