lcc/Hcompta/LCC/Write/Compta.hs

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