lcc/Hcompta/LCC/Document.hs

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