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