lcc/Hcompta/LCC/Write/Compta.hs

   1 module Hcompta.LCC.Write.Compta where
   2
   3 import Control.Monad (Monad(..))
   4 import Data.Bool
   5 import Data.Char (Char)
   6 import Data.Decimal
   7 import Data.Eq (Eq(..))
   8 import Data.Foldable (Foldable(..))
   9 import Data.Function (($), (.), flip, id)
  10 import Data.Functor ((<$>))
  11 import Data.Functor.Compose (Compose(..))
  12 import Data.Maybe (Maybe(..), fromMaybe)
  13 import Data.Monoid (Monoid(..))
  14 import Data.Ord (Ord(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.Tuple (fst, uncurry)
  17 import GHC.Exts (Int(..))
  18 import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
  19 import System.IO (IO)
  20 import qualified Data.ByteString as BS
  21 import qualified Data.Char as Char
  22 import qualified Data.List as L
  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 T
  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 import qualified Language.Symantic.Grammar as G
  33 import qualified Language.Symantic as Sym
  34
  35 import qualified Hcompta as H
  36
  37 import Hcompta.LCC.Account
  38 import Hcompta.LCC.Amount
  39 import Hcompta.LCC.Chart
  40 import Hcompta.LCC.IO
  41 import Hcompta.LCC.Journal
  42 import Hcompta.LCC.Name
  43 import Hcompta.LCC.Posting
  44 import Hcompta.LCC.Tag
  45 import Hcompta.LCC.Transaction
  46 import Hcompta.LCC.Source
  47 import Hcompta.LCC.Compta
  48 import qualified Hcompta.LCC.Read.Compta as G
  49
  50 -- * Class 'Writeable'
  51 class Writeable d a where
  52         write :: a -> d
  53
  54 widthWrite :: Writeable D.Dim a => a -> Int
  55 widthWrite = D.width . D.dim . write
  56
  57 -- import Debug.Trace (trace)
  58 -- dbg msg x = trace (msg <> " = " <> show x) x
  59
  60 -- * Type 'Context_Write'
  61 data Context_Write
  62  =   Context_Write
  63  {   context_write_account_ref    :: Bool
  64  ,   context_write_amounts        :: Style_Amounts
  65  ,   context_write_width_acct_amt :: Int
  66  }
  67
  68 context_write :: Context_Write
  69 context_write =
  70         Context_Write
  71          { context_write_account_ref    = True
  72          , context_write_amounts        = Style_Amounts Map.empty
  73          , context_write_width_acct_amt = 0
  74          }
  75
  76 instance (D.Doc_Text d, D.Doc_Color d) =>
  77          Writeable d Date where
  78         write dat =
  79                 let (y, mo, d) = H.gregorianOf dat in
  80                 (if y == 0 then D.empty else D.integer y <> sep G.char_ymd_sep) <>
  81                 int2 mo <>
  82                 sep G.char_ymd_sep <> int2 d <>
  83                 (case H.todOf dat of
  84                  (0, 0, 0) -> D.empty
  85                  (h, m, s) ->
  86                         sep '_' <> int2 h <>
  87                         sep ':' <> int2 m <>
  88                         (case s of
  89                          0 -> D.empty
  90                          _ -> sep ':' <>
  91                                 (if s < 10 then D.charH '0' else D.empty) <>
  92                                 D.integer ((truncate s::Integer))))
  93                 where
  94                 int2 i = (if i < 10 then D.charH '0' else D.empty) <> D.int i
  95                 sep = D.blacker . D.charH
  96 instance (D.Doc_Text d, D.Doc_Color d, Monoid d) =>
  97          Writeable d Account where
  98         write acct =
  99                 (`MT.ofoldMap` acct) $ \a ->
 100                         D.blacker (D.charH G.char_account_sep) <>
 101                         write a
 102 instance D.Doc_Text d =>
 103          Writeable d NameAccount where
 104         write = D.textH . unName
 105 instance (D.Doc_Text d, D.Doc_Color d) =>
 106          Writeable d Tag_Path where
 107         write (Tag_Path path) =
 108                 D.catH $
 109                 (:) (D.yellower $ D.charH G.char_account_tag_prefix) $
 110                 L.intersperse
 111                  (D.yellower $ D.charH G.char_tag_sep)
 112                  (D.textH . unName <$> NonNull.toNullable path)
 113 instance (D.Doc_Text d, D.Doc_Color d) =>
 114          Writeable d Account_Tag where
 115         write (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 116                 D.catH (
 117                         (:) (D.yellower $ D.charH G.char_account_tag_prefix) $
 118                         L.intersperse
 119                          (D.yellower $ D.charH G.char_tag_sep)
 120                          (D.textH . unName <$> NonNull.toNullable path) ) <>
 121                 if T.null value
 122                 then D.empty
 123                 else
 124                         D.yellower (D.charH G.char_tag_data_prefix) <>
 125                         D.textH value
 126 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
 127          Writeable d (Styled_Amount Amount) where
 128         write
 129          ( sty@Style_Amount
 130                  { style_amount_unit_side   = uside
 131                  , style_amount_unit_spaced = uspaced
 132                  }
 133          , Amount u q
 134          ) =
 135                 case uside of
 136                  S.Just L ->
 137                         write u <>
 138                         case uspaced of
 139                          S.Just True | not (H.null u) -> D.space
 140                          _ -> D.empty
 141                  _ -> D.empty
 142                 <> write (sty, q)
 143                 <> case uside of
 144                  S.Just R ->
 145                         (case uspaced of
 146                          S.Just True | not (H.null u) -> D.space
 147                          _ -> D.empty) <>
 148                         write u
 149                  S.Nothing ->
 150                         (case uspaced of
 151                          S.Just True | not (H.null u) -> D.space
 152                          _ -> D.empty) <>
 153                         write u
 154                  _ -> D.empty
 155 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
 156          Writeable (Context_Write -> d) Amount where
 157         write amt ctx =
 158                 write (styled_amount (context_write_amounts ctx) amt)
 159 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 160          Writeable (Context_Write -> d) Amounts where
 161         write (Amounts amts) ctx =
 162                 mconcat $
 163                 L.intersperse " + " $
 164                 ((`write` ctx) <$>) $
 165                 uncurry Amount <$> Map.toList amts
 166 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
 167          Writeable d Unit where
 168         write (Unit t) =
 169                 D.yellower $
 170                 if T.all
 171                  (\c -> case Char.generalCategory c of
 172                          Char.CurrencySymbol  -> True
 173                          Char.LowercaseLetter -> True
 174                          Char.ModifierLetter  -> True
 175                          Char.OtherLetter     -> True
 176                          Char.TitlecaseLetter -> True
 177                          Char.UppercaseLetter -> True
 178                          _ -> False
 179                  ) t
 180                 then D.textH t
 181                 else D.dquote $ D.textH t
 182 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
 183          Writeable d (Styled_Amount Quantity) where
 184         write
 185          ( Style_Amount
 186                  { style_amount_fractioning
 187                  , style_amount_grouping_integral
 188                  , style_amount_grouping_fractional
 189                  }
 190          , qty ) = do
 191                 let Decimal e n = qty
 192                 let num = show $ abs n
 193                 let sign = D.bold $ D.yellower $ D.textH (if n < 0 then "-" else "")
 194                 if e == 0
 195                  then sign <> D.bold (D.blue $ D.stringH num)
 196                  else do
 197                         let num_len = L.length num
 198                         let padded =
 199                                 L.concat
 200                                  [ L.replicate (fromIntegral e + 1 - num_len) '0'
 201                                  , num
 202                                  -- , replicate (fromIntegral precision - fromIntegral e) '0'
 203                                  ]
 204                         let (int, frac) = L.splitAt (max 1 (num_len - fromIntegral e)) padded
 205                         let default_fractioning =
 206                                 L.head $
 207                                 del_grouping_sep style_amount_grouping_integral $
 208                                 del_grouping_sep style_amount_grouping_fractional $
 209                                 ['.', ',']
 210                         sign <>
 211                          D.bold (D.blue $
 212                                 D.stringH (S.maybe id
 213                                  (\g -> L.reverse . group g . L.reverse)
 214                                  style_amount_grouping_integral $ int) <>
 215                                 D.yellower (D.charH (S.fromMaybe default_fractioning style_amount_fractioning)) <>
 216                                 D.stringH (S.maybe id group style_amount_grouping_fractional frac))
 217                 where
 218                 group :: Style_Amount_Grouping -> [Char] -> [Char]
 219                 group (Style_Amount_Grouping sep sizes_) =
 220                         L.concat . L.reverse .
 221                         L.map L.reverse . fst .
 222                         L.foldl'
 223                          (flip (\digit x -> case x of
 224                                  ([], sizes) -> ([[digit]], sizes)
 225                                  (digits:groups, []) -> ((digit:digits):groups, [])
 226                                  (digits:groups, curr_sizes@(size:sizes)) ->
 227                                         if L.length digits < size
 228                                         then (      (digit:digits):groups, curr_sizes)
 229                                         else ([digit]:[sep]:digits:groups, if L.null sizes then curr_sizes else sizes)
 230                          ))
 231                          ([], sizes_)
 232                 del_grouping_sep grouping =
 233                         case grouping of
 234                          S.Just (Style_Amount_Grouping sep _) -> L.delete sep
 235                          _ -> id
 236 instance (D.Doc_Text d, D.Doc_Color d) =>
 237          Writeable d Comment where
 238         write (Comment com) =
 239                 D.cyan $
 240                 D.charH G.char_comment_prefix
 241                 <> (case T.uncons com of
 242                  Just (c, _) | not $ Char.isSpace c -> D.space
 243                  _ -> D.empty)
 244                 <> D.textH com
 245 instance (D.Doc_Text d, D.Doc_Color d) =>
 246          Writeable d (d, [Comment]) where
 247         write (prefix, com) =
 248                 D.catH $
 249                 L.intersperse D.eol $
 250                 (\c -> prefix <> write c) <$> com
 251 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 252          Writeable d (Context_Write, Posting src) where
 253         write (ctx, Posting
 254          { posting_account
 255          , posting_account_ref
 256          , posting_amounts
 257          , posting_comments
 258          -- , posting_dates
 259          -- , posting_tags
 260          }) =
 261                 let d_indent = D.spaces 2 in
 262                 d_indent <>
 263                 let (d_acct, w_acct) =
 264                         case posting_account_ref of
 265                          S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 266                                 ( write a <> S.maybe D.empty write sa
 267                                 , widthWrite a + S.maybe 0 widthWrite sa )
 268                          _ -> (write posting_account, widthWrite posting_account) in
 269                 (case posting_amounts of
 270                  Amounts amts | Map.null amts -> d_acct
 271                  Amounts amts ->
 272                         fromMaybe D.empty $
 273                         Map.foldlWithKey
 274                          (\mdoc unit qty -> Just $
 275                                 let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
 276                                 let pad = max 0 $ context_write_width_acct_amt ctx - (w_acct + widthWrite amt) in
 277                                 (case mdoc of
 278                                  Nothing -> D.empty
 279                                  Just doc -> doc <> D.eol <> d_indent) <>
 280                                 d_acct <> D.spaces pad <> D.space <> write amt
 281                          ) Nothing amts) <>
 282                 (case posting_comments of
 283                  []  -> D.empty
 284                  [c] -> D.space <> write c
 285                  _   -> D.eol   <> write (d_indent <> D.space :: d, posting_comments))
 286 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 287          Writeable d (Context_Write, Transaction src) where
 288         write (ctx,
 289          txn@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_Transaction ctx txn
 300                         else w } in
 301                 D.catH (
 302                         L.intersperse
 303                          (D.charH G.char_transaction_date_sep)
 304                          (write <$> 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                  _  -> write (D.space :: d, transaction_comments) <> D.eol) <>
 312                 TreeMap.foldr_with_Path
 313                  (\path -> flip $
 314                         foldr (\value -> (<>) (D.spaces 2 <>
 315                         write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
 316                  D.empty tags <>
 317                 D.catV (write . (ctx',) <$> Compose transaction_postings)
 318 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 319          Writeable d (Context_Write, Transactions src) where
 320         write (ctx, Transactions txns) =
 321                 let ctx' = ctx{context_write_width_acct_amt =
 322                         foldr (max . w_Transaction ctx) 0 $ Compose txns} in
 323                 fromMaybe D.empty $
 324                 foldl (\mdoc txn -> Just $
 325                         write (ctx', txn) <>
 326                         case mdoc of
 327                          Nothing  -> D.eol
 328                          Just doc -> D.eol <> D.eol <> doc
 329                  ) Nothing (Compose txns)
 330 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 331          Writeable d Transaction_Tag where
 332         write (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 333                 D.catH (
 334                         (:) (D.yellower $ D.charH G.char_tag_prefix) $
 335                         L.intersperse
 336                          (D.yellower $ D.charH G.char_tag_sep)
 337                          (D.bold . D.textH . unName <$> NonNull.toNullable path)) <>
 338                 if T.null value
 339                 then D.empty
 340                 else D.yellower (D.charH G.char_tag_data_prefix) <> D.textH value
 341 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writeable d (ctx, j)) =>
 342          Writeable d (ctx, Journal src j) where
 343         write (ctx, Journal
 344          { journal_content
 345          , journal_terms
 346          , journal_chart
 347          }) =
 348                 (if   null journal_terms then D.empty else (write journal_terms <> D.eol)) <>
 349                 (if H.null journal_chart then D.empty else (write journal_chart <> D.eol)) <>
 350                 write (ctx, journal_content)
 351 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writeable d (ctx, j)) =>
 352          Writeable d (ctx, Journals src j) where
 353         write (ctx, Journals js) =
 354                 Map.foldl
 355                  (\doc j@Journal{journal_file=PathFile jf} ->
 356                         doc <>
 357                         write (Comment $ T.pack jf) <> D.eol <>
 358                         D.eol <> write (ctx, j)
 359                  ) D.empty js
 360 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 361          Writeable d Chart where
 362         write =
 363                 TreeMap.foldl_with_Path
 364                  (\doc acct (Account_Tags (Tags ca)) ->
 365                         doc <>
 366                         write (H.to acct :: Account) <> D.eol <>
 367                         TreeMap.foldl_with_Path
 368                          (\doc' tp tvs ->
 369                                 doc' <>
 370                                 foldl'
 371                                  (\doc'' tv ->
 372                                         doc'' <> D.spaces 2 <>
 373                                         write (Account_Tag (Tag (Tag_Path tp) tv)) <>
 374                                         D.eol)
 375                                  D.empty
 376                                  tvs)
 377                          D.empty
 378                          ca
 379                  ) D.empty .
 380                 chart_accounts
 381 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
 382          Writeable d (Terms src) where
 383         write = Map.foldlWithKey (\doc n (G.At _src t) -> doc <> write n <> D.space <> D.text t <> D.eol) D.empty
 384 instance (D.Doc_Text d, D.Doc_Color d) => Writeable d (Sym.Mod Sym.NameTe) where
 385         write (ms `Sym.Mod` Sym.NameTe n) =
 386                 D.catH $
 387                 L.intersperse (D.charH '.') $
 388                 ((\(Sym.NameMod m) -> D.textH m) <$> ms) <>
 389                 [(if isOp n then id else D.yellower) $ D.text n]
 390                 where
 391                 isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
 392 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => Writeable d (Context_Write, LCC src) where
 393         write (ctx, LCC
 394          { lcc_journals = js
 395          , lcc_style    = amts
 396          }) =
 397                 write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
 398 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => Writeable (Context_Write -> d) (LCC src) where
 399         write LCC
 400          { lcc_journals = js
 401          , lcc_style    = amts
 402          } ctx =
 403                 write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
 404 {-
 405 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writeable d (Context_Write, j)) =>
 406          Writeable d (Context_Write, Compta src ss j) where
 407         write (ctx, Compta
 408          { compta_journals      = js
 409          , compta_chart         = c@Chart{chart_accounts=ca}
 410          , compta_style_amounts = amts
 411          , compta_terms         = terms
 412          }) =
 413                 (if null terms then D.empty else (write terms <> D.eol)) <>
 414                 (if TreeMap.null ca then D.empty else (write c <> D.eol)) <>
 415                 write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
 416 -}
 417 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
 418          Writeable (IO d) SourcePos where
 419         write (SourcePos p (PosFile l) (PosFile c)) = do
 420                 content <- Enc.decodeUtf8 <$> BS.readFile p
 421                 let ls = T.lines content
 422                 let ll = max 1 $ l - size_ctx
 423                 let qs =
 424                         L.take (intFrom $ (l - ll) + 1 + size_ctx) $
 425                         L.drop (intFrom $ ll-1) ls
 426                 let ns = show <$> L.take (L.length qs) [ll..]
 427                 let max_len_n = maximum $ 0 : (L.length <$> ns)
 428                 let ns' = (<$> ns) $ \n ->
 429                         L.replicate (max_len_n - L.length n) ' ' <> n
 430                 let quote =
 431                         D.catV $
 432                         L.zipWith (\(n, sn) q ->
 433                                 D.spaces 2 <> D.blacker (D.stringH sn) <>
 434                                 D.spaces 2 <> (if n == l then mark q else D.textH q)
 435                          ) (L.zip [ll..] ns') qs
 436                 return $ quote <> D.eol
 437                 where
 438                 size_ctx = 2
 439                 intFrom = fromInteger . toInteger
 440                 mark q =
 441                         let (b, a) = T.splitAt (intFrom c - 1) q in
 442                         D.textH b <>
 443                         case T.uncons a of
 444                          Nothing -> D.red D.space
 445                          Just (a0, a') -> D.red (D.charH a0) <> D.textH a'
 446
 447 -- | Return the width of given 'Postings',
 448 -- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
 449 w_Transaction :: Context_Write -> Transaction src -> Int
 450 -- w_Postings ctx = MT.ofoldr (max . widthWrite ctx) 0
 451 w_Transaction ctx =
 452         MT.ofoldr (\Posting
 453          { posting_account
 454          , posting_account_ref
 455          , posting_amounts
 456          } -> max $
 457                 let w_Acct =
 458                         case posting_account_ref of
 459                          S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 460                                 widthWrite a + S.maybe 0 widthWrite sa
 461                          _ -> widthWrite posting_account in
 462                 let w_Amt =
 463                         case posting_amounts of
 464                          Amounts amts | Map.null amts -> 0
 465                          Amounts amts ->
 466                                 Map.foldrWithKey
 467                                  (\unit qty -> max $
 468                                         let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
 469                                         widthWrite amt)
 470                                  1 amts in
 471                 w_Acct + w_Amt
 472          ) 0 .
 473         transaction_postings