lcc/Hcompta/LCC/Write/Balance.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.LCC.Write.Balance where
   7
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Decimal
  12 import Data.Eq (Eq(..))
  13 -- import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.), flip, id)
  15 import Data.Functor ((<$>))
  16 import Data.Functor.Compose (Compose(..))
  17 import Data.Proxy (Proxy(..))
  18 import Data.Map.Strict (Map)
  19 import Data.Maybe (Maybe(..), fromMaybe, maybe)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Ord (Ord(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Text (Text)
  24 import Data.Tuple (fst)
  25 import GHC.Exts (Int(..))
  26 import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
  27 import System.IO (IO)
  28 import qualified Data.ByteString as BS
  29 import qualified Data.Char as Char
  30 import qualified Data.List as L
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.MonoTraversable as MT
  33 import qualified Data.NonNull as NonNull
  34 import qualified Data.Strict as S
  35 import qualified Data.Text as Text
  36 import qualified Data.Text.Encoding as Enc
  37 import qualified Data.TreeMap.Strict as TM
  38
  39 import qualified Language.Symantic.Document as D
  40
  41 import qualified Hcompta as H
  42
  43 import Hcompta.LCC.Account
  44 import Hcompta.LCC.Amount
  45 import Hcompta.LCC.Chart
  46 import Hcompta.LCC.Compta
  47 import Hcompta.LCC.IO
  48 import Hcompta.LCC.Journal
  49 import Hcompta.LCC.Name
  50 import Hcompta.LCC.Posting
  51 import Hcompta.LCC.Tag
  52 import Hcompta.LCC.Transaction
  53 import Hcompta.LCC.Balance
  54 import Hcompta.LCC.Write.Compta
  55 import Hcompta.LCC.Write.Table
  56 import qualified Hcompta.LCC.Read.Compta as G
  57 import qualified Hcompta.Lib.Strict as S
  58
  59
  60 -- * Class 'Msg_Title'
  61 class Msg_Title lang d where
  62         msg_Title_Debit   :: d
  63         msg_Title_Credit  :: d
  64         msg_Title_Balance :: d
  65         msg_Title_Account :: d
  66
  67 -- * Type 'FR'
  68 data FR
  69 instance D.Doc_Text d => Msg_Title FR d where
  70         msg_Title_Debit   = D.textH "Débit"
  71         msg_Title_Credit  = D.textH "Crédit"
  72         msg_Title_Balance = D.textH "Solde"
  73         msg_Title_Account = D.textH "Compte"
  74
  75 -- * Type 'Config_Balance'
  76 data Config_Balance
  77  =   Config_Balance
  78  {   config_balance_heritage      :: Bool
  79  ,   config_balance_total_by_unit :: Bool
  80  }
  81
  82 instance Writeable (Style_Amount, Amount) d =>
  83          CellPlainOf (Style_Amount, Amount) d
  84 instance Writeable Date d => CellPlainOf Date d
  85 instance Writeable Account d => CellPlainOf Account d
  86 instance ( CellPlainOf () d
  87          , CellPlainOf (Style_Amount, Amount) d
  88          ) => CellPlainOf (Maybe (Style_Amount, Amount)) d where
  89         cellPlainOf = cellPlainOf () `maybe` cellPlainOf
  90
  91 -- instance D.Doc_Text d => CellPlainOf Wording d
  92
  93 -- * Type 'RowsPlain'
  94 type RowsPlain d = [[CellPlain d]] -> [[CellPlain d]]
  95
  96 -- * Class 'RowsPlainOf'
  97 class RowsPlainOf a d where
  98         rowsPlainOf :: a -> RowsPlain d
  99
 100 instance ( CellPlainOf () d
 101          , CellPlainOf Account d
 102          , CellPlainOf (Style_Amount, Amount) d
 103          ) => RowsPlainOf (Style_Amount, BalByAccount) d where
 104         rowsPlainOf (sty, bal) =
 105                 flip (TM.foldrWithPath
 106                  (\acct sum rows ->
 107                         Map.foldrWithKey
 108                          (\unit qty ->
 109                                 L.zipWith (:)
 110                                  [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
 111                                  , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
 112                                  , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
 113                                  , cellPlainOf $ Account acct
 114                                  ]
 115                          )
 116                          rows sum
 117                  )) bal
 118 instance ( CellPlainOf () d
 119          , CellPlainOf Account d
 120          , CellPlainOf (Style_Amount, Amount) d
 121          ) => RowsPlainOf (Style_Amount, ClusiveBalByAccount) d where
 122         rowsPlainOf (sty, bal) =
 123                 flip (TM.foldrWithPath
 124                  (\acct S.Clusive{S.inclusive=sum} rows ->
 125                         Map.foldrWithKey
 126                          (\unit qty ->
 127                                 L.zipWith (:)
 128                                  [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
 129                                  , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
 130                                  , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
 131                                  , cellPlainOf $ Account acct
 132                                  ]
 133                          )
 134                          rows sum
 135                  )) bal
 136 instance ( CellPlainOf () d
 137          , CellPlainOf Account d
 138          , CellPlainOf (Style_Amount, Amount) d
 139          ) => RowsPlainOf (Style_Amount, BalByUnit) d where
 140         rowsPlainOf (sty, bal) =
 141                 flip (Map.foldrWithKey
 142                  (\unit H.SumByUnit{H.sumByUnit_quantity=qty} ->
 143                         L.zipWith (:)
 144                          [ cellPlainOf $ (sty,) . Amount unit <$> H.unPositive qty
 145                          , cellPlainOf $ (sty,) . Amount unit <$> H.unNegative qty
 146                          , cellPlainOf $ (sty,) $ Amount unit $ H.depolarize qty
 147                          , cellPlainOf ()
 148                          ]
 149                  )) bal
 150 instance ( Monoid d
 151          , D.Doc_Text d
 152          , D.Doc_Color d
 153          , D.Doc_Decoration d
 154          , Msg_Title lang Text
 155          ) => TablePlainOf (Proxy lang, Style_Amount, BalByAccount, BalByUnit) d where
 156         tablePlainOf (_lang, sty, ba, bu) =
 157                 L.zipWith id
 158                  [ columnPlain (msg_Title_Debit   @lang) AlignPlainR
 159                  , columnPlain (msg_Title_Credit  @lang) AlignPlainR
 160                  , columnPlain (msg_Title_Balance @lang) AlignPlainR
 161                  , columnPlain (msg_Title_Account @lang) AlignPlainL
 162                  ] $
 163                 rowsPlainOf (sty, ba) $
 164                 rowsPlainOf (sty, bu) $
 165                 L.repeat []
 166
 167 {-
 168 instance Writeable (Proxy lang, Balance) d where
 169         write (lang, H.Balance)
 170
 171 instance Writeable (Proxy lang, Compta src ss Balance) d where
 172         write (lang, Compta{compta_journals=js, compta_style_amounts=sty}) =
 173                 tablePlainOf (lang, sty, )
 174
 175 instance ( CellPlainOf () d
 176          , CellPlainOf Account d
 177          , CellPlainOf (Style_Amount, Amount) d
 178          ) => RowsPlainOf (Style_Amount, BalByAccount, H.BalByUnit) d where
 179         rowsPlainOf (sty, bal) =
 180
 181 instance TablePlainOf (Style_Amount, H.BalByUnit NameAccount Unit (H.Polarized Quantity)) where
 182         tablePlainOf conf balByAccount =
 183                 let (rowsByAccount, rowsByUnit) =
 184                         case config_balance_heritage conf of
 185                          True  -> rowsOfBalByUnit $ H.clusiveBalByAccount balByAccount
 186                          False -> rowsOfBalByUnit                         balByAccount in
 187                 zipWith id
 188                  [ tColumn (msg_Title_Debit   @lang) AlignR
 189                  , tColumn (msg_Title_Credit  @lang) AlignR
 190                  , tColumn (msg_Title_Balance @lang) AlignR
 191                  , tColumn (msg_Title_Account @lang) AlignL
 192                  ] $
 193                 rowsByAccount $
 194                 (if config_balance_total_by_unit conf
 195                  then zipWith (:)
 196                          [ tCellLine '=' 0
 197                          , tCellLine '=' 0
 198                          , tCellLine '=' 0
 199                          , tCellLine ' ' 0
 200                          ] . rowsByUnit
 201                  else id) $
 202                 L.repeat []
 203                 where
 204                 expand :: Forall_Journal_Balance_by_Account ->
 205                           Forall_Journal_Balance_by_Account_Expanded
 206                 expand = Format.journal_wrap
 207                 rowsOfBalByUnit ::
 208                  ( Format.Journal_Filter Context (Const BalByAccount) ()
 209                  , Format.Journal_Wrap BalByAccount Forall_Journal_Balance_by_Unit
 210                  , Format.Journal_Leijen_Table_Cells (Const BalByAccount) ()
 211                  ) =>
 212                  BalByAccount ->
 213                  ( [[CellPlain d]] -> [[CellPlain d]]
 214                  , [[CellPlain d]] -> [[CellPlain d]] )
 215                 rowsOfBalByUnit =
 216                         (***) tCellsOfBalByAccount tCellsOfBalByUnit .
 217                         (&&&) id sum_by_unit .
 218                         Format.journal_filter ctx .
 219                         Const
 220                         where
 221                         sum_by_unit ::
 222                          Format.Journal_Wrap BalByAccount Forall_Journal_Balance_by_Unit =>
 223                          Const BalByAccount () ->
 224                          Const Forall_Journal_Balance_by_Unit ()
 225                         sum_by_unit = Const . Format.journal_wrap . getConst
 226
 227 {-
 228 ttableOf :: forall lang d.
 229  D.Doc_Text d =>
 230  D.Doc_Color d =>
 231  BalByAccount -> TTable d
 232
 233
 234 -}
 235
 236
 237
 238
 239 {-
 240 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
 241 -}
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252 {-
 253 -- * 'H.Balance_by_Account'
 254
 255 -- ** Type 'Format_Balance_by_Account'
 256
 257 type Format_Journal_Balance_by_Account
 258  = Format
 259    (   JCC.Journal Balance_by_Account_JCC)
 260    (Ledger.Journal Balance_by_Account_Ledger)
 261
 262 -- JCC
 263 type Balance_by_Account_JCC
 264  = H.Balance_by_Account JCC.Account_Section
 265                         JCC.Unit
 266                         (H.Polarized JCC.Quantity)
 267 instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
 268         type Journal_Format   (JCC.Journal Balance_by_Account_JCC)
 269          = Format_Journal_Balance_by_Account
 270         journal_format = Format_JCC
 271
 272 -- Ledger
 273 type Balance_by_Account_Ledger
 274  = H.Balance_by_Account Ledger.Account_Section
 275                         Ledger.Unit
 276                         (H.Polarized Ledger.Quantity)
 277 instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
 278         type Journal_Format   (Ledger.Journal Balance_by_Account_Ledger)
 279          = Format_Journal_Balance_by_Account
 280         journal_format = Format_Ledger
 281
 282 -- ** Class 'Journal_Balance_by_Account'
 283
 284 class
 285  ( Format.Journal (j m)
 286  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
 287  , Format.Journal_Read j
 288  , Format.Journal_Monoid (j m)
 289  , Format.Journal_Leijen_Table_Cells j m
 290  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
 291  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
 292  , Format.Journal_Filter Context j m
 293  , Journal_Equilibrium_Transaction j m
 294  ) => Journal_Balance_by_Account j m
 295
 296 instance Journal_Balance_by_Account    JCC.Journal Balance_by_Account_JCC
 297 instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
 298
 299 -- ** Type 'Forall_Journal_Balance_by_Account'
 300
 301 data    Forall_Journal_Balance_by_Account
 302  = forall j m. Journal_Balance_by_Account  j m
 303  =>     Forall_Journal_Balance_by_Account (j m)
 304
 305 instance Format.Journal Forall_Journal_Balance_by_Account where
 306         type Journal_Format   Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
 307         journal_format
 308          (Forall_Journal_Balance_by_Account j) =
 309                 Format.journal_format j
 310 instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
 311         journal_empty f =
 312                 case f of
 313                  Format_JCC    () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
 314                  Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
 315 instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
 316         journal_flatten
 317          (Forall_Journal_Balance_by_Account j) =
 318                 Forall_Journal_Balance_by_Account $
 319                 Format.journal_flatten j
 320         journal_fold f (Forall_Journal_Balance_by_Account j) =
 321                 Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
 322 instance Monoid Forall_Journal_Balance_by_Account where
 323         mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
 324         mappend x y =
 325                 case (mappend `on` Format.journal_format) x y of
 326                  Format_JCC    j -> Forall_Journal_Balance_by_Account j
 327                  Format_Ledger j -> Forall_Journal_Balance_by_Account j
 328         mconcat js =
 329                 case js of
 330                  [] -> mempty
 331                  j:jn -> List.foldl' mappend j jn
 332
 333 -- ** 'journal_read'
 334
 335 type Journal_Filter_Simplified transaction
 336  = Filter.Simplified
 337    (Filter.Filter_Bool
 338    (Filter.Filter_Transaction transaction))
 339 type Journal_Read_Cons txn
 340  = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
 341 journal_read
 342  :: Context -> FilePath
 343  -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
 344 journal_read ctx =
 345         case ctx_input_format ctx of
 346          Format_JCC () ->
 347                 let wrap (j::JCC.Journal Balance_by_Account_JCC)
 348                          = Forall_Journal_Balance_by_Account j in
 349                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 350                          = Filter.Filtered (ctx_filter_transaction ctx) in
 351                 liftM ((+++) Format.Message wrap) .
 352                 Format.journal_read cons
 353          Format_Ledger () ->
 354                 let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
 355                          = Forall_Journal_Balance_by_Account j in
 356                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 357                          = Filter.Filtered (ctx_filter_transaction ctx) in
 358                 liftM ((+++) Format.Message wrap) .
 359                 Format.journal_read cons
 360
 361 {-
 362 -- ** Type family 'Balance_by_Account'
 363
 364 type family Balance_by_Account (j:: * -> *) m
 365 type instance Balance_by_Account
 366    j (Balance.Expanded           as u (Polarized q))
 367  = j (Balance.Balance_by_Account as u (Polarized q))
 368 type instance Balance_by_Account
 369    (Const Forall_Journal_Balance_by_Account_Expanded) ()
 370  = (Const Forall_Journal_Balance_by_Account         ) ()
 371 -}
 372
 373 -- Instances 'Format.Journal_Filter'
 374
 375 instance
 376  ( Functor j
 377  , Format.Journal_Chart j
 378
 379  , as ~ Format.Journal_Account_Section j
 380  , Data as
 381  {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
 382  , NFData as
 383  , Ord as
 384  , Show as
 385
 386  , q ~ Format.Journal_Quantity j
 387  , Format.Journal_Quantity j ~ Decimal
 388  , H.Addable q
 389  , H.Zero q
 390
 391  , H.Unit u
 392  ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
 393         journal_filter ctx j =
 394                 case Filter.simplified $ ctx_filter_balance ctx of
 395                  Right True | ctx_redundant ctx -> j
 396                  Right True ->
 397                         TreeMap.filter_with_Path_and_Node
 398                          (\n _p -> is_worth n) <$> j
 399                  Right False -> const mempty <$> j
 400                  Left flt ->
 401                         (<$> j) $
 402                         TreeMap.map_Maybe_with_Path_and_Node
 403                          (\node account (H.Balance_by_Account_Sum bal) ->
 404                                 (if is_worth node bal then id else const Strict.Nothing) $
 405                                 case Map.mapMaybeWithKey
 406                                  (\unit qty ->
 407                                         if Filter.test flt
 408                                                  ( (H.chart_account_tags account (Format.journal_chart j), account)
 409                                                  , (unit, qty)
 410                                                  )
 411                                         then Just qty
 412                                         else Nothing
 413                                  ) bal of
 414                                  m | Map.null m -> Strict.Nothing
 415                                  m -> Strict.Just $ H.Balance_by_Account_Sum m
 416                          )
 417                 where
 418                         is_worth
 419                          :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
 420                          => TreeMap.Node k0 x0
 421                          -> t0 (H.Polarized a0)
 422                          -> Bool
 423                         is_worth _node bal =
 424                                 ctx_redundant ctx
 425                                 -- NOTE: worth if no descendant
 426                                 -- but Account's exclusive
 427                                 -- has at least a non-zero Amount
 428                                 || Foldable.any
 429                                          (not . H.quantity_null . H.depolarize)
 430                                          bal
 431 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
 432         journal_filter ctx
 433          (Const (Forall_Journal_Balance_by_Account j)) =
 434                 Const $ Forall_Journal_Balance_by_Account $
 435                 Format.journal_filter ctx j
 436
 437 -- Instances 'Format.Journal_Leijen_Table_Cells'
 438
 439 instance
 440  ( Format.Journal_Content j
 441  , Journal j
 442
 443  , as ~ Format.Journal_Account_Section j
 444  , Ord as
 445  , H.Addable (Format.Journal_Quantity j)
 446
 447  , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
 448
 449  , Balance_by_Account_Sum amt
 450  , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
 451  , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
 452  ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
 453         journal_leijen_table_cells jnl =
 454                 flip (TreeMap.foldr_with_Path
 455                  (\account balance rows ->
 456                         let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
 457                         Map.foldrWithKey
 458                          (\unit qty ->
 459                                 zipWith (:)
 460                                  [ cell_of $ (unit,) <$> H.polarized_positive qty
 461                                  , cell_of $ (unit,) <$> H.polarized_negative qty
 462                                  , cell_of (unit, H.depolarize qty)
 463                                  , cell_of account
 464                                  ]
 465                          )
 466                          rows bal
 467                  ))
 468                  (Format.journal_content jnl)
 469                 where
 470                         cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
 471                         cell_of = Leijen.Table.cell_of_forall_param jnl
 472 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
 473         journal_leijen_table_cells
 474          (Const (Forall_Journal_Balance_by_Account j)) =
 475                 Format.journal_leijen_table_cells j
 476
 477 -- ** Class 'Balance_by_Account_Sum'
 478
 479 -- | A class to get a 'H.Balance_Account_Sum'
 480 --   when operating on 'H.Balance_by_Account'
 481 --   or 'H.Balance_Expanded' 'Strict.inclusive' field.
 482 class Balance_by_Account_Sum amt where
 483         type Balance_by_Account_Sum_Unit     amt
 484         type Balance_by_Account_Sum_Quantity amt
 485         balance_by_account_sum
 486          :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
 487                                             (Balance_by_Account_Sum_Quantity amt)
 488 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
 489         type Balance_by_Account_Sum_Unit     (H.Balance_by_Account_Sum u q) = u
 490         type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
 491         balance_by_account_sum = id
 492 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
 493         type Balance_by_Account_Sum_Unit     (H.Balance_by_Account_Sum_Expanded u q) = u
 494         type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
 495         balance_by_account_sum = Strict.inclusive
 496
 497 -- * 'H.Balance_Expanded'
 498
 499 -- ** Type 'Format_Journal_Balance_by_Account_Expanded'
 500
 501 type Format_Journal_Balance_by_Account_Expanded
 502  = Format
 503    (   JCC.Journal Balance_by_Account_Expanded_JCC)
 504    (Ledger.Journal Balance_by_Account_Expanded_Ledger)
 505
 506 -- JCC
 507 type Balance_by_Account_Expanded_JCC
 508  = H.Balance_Expanded JCC.Account_Section
 509                     JCC.Unit
 510                     (H.Polarized JCC.Quantity)
 511 instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
 512         type Journal_Format   (JCC.Journal Balance_by_Account_Expanded_JCC)
 513          = Format_Journal_Balance_by_Account_Expanded
 514         journal_format = Format_JCC
 515
 516 -- Ledger
 517 type Balance_by_Account_Expanded_Ledger
 518  = H.Balance_Expanded Ledger.Account_Section
 519                       Ledger.Unit
 520                       (H.Polarized Ledger.Quantity)
 521 instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
 522         type Journal_Format   (Ledger.Journal Balance_by_Account_Expanded_Ledger)
 523          = Format_Journal_Balance_by_Account_Expanded
 524         journal_format = Format_Ledger
 525
 526 -- ** Class 'Journal_Balance_by_Account_Expanded'
 527
 528 class
 529  ( Format.Journal (j m)
 530  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
 531  , Format.Journal_Leijen_Table_Cells j m
 532  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
 533  , Format.Journal_Filter Context j m
 534  ) => Journal_Balance_by_Account_Expanded j m
 535
 536 instance Journal_Balance_by_Account_Expanded    JCC.Journal Balance_by_Account_Expanded_JCC
 537 instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
 538
 539 -- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
 540
 541 data    Forall_Journal_Balance_by_Account_Expanded
 542  = forall j m. Journal_Balance_by_Account_Expanded  j m
 543  =>     Forall_Journal_Balance_by_Account_Expanded (j m)
 544
 545 instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
 546         type Journal_Format   Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
 547         journal_format
 548          (Forall_Journal_Balance_by_Account_Expanded j) =
 549                 Format.journal_format j
 550
 551 -- Instances 'Format.Journal_Filter'
 552
 553 instance
 554  ( Functor j
 555  , Format.Journal_Chart j
 556  , as ~ Format.Journal_Account_Section j
 557  , Data as
 558  {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
 559  , NFData as
 560  , Ord as
 561  , Show as
 562  , q ~ Format.Journal_Quantity j
 563  , Format.Journal_Quantity j ~ Decimal
 564  , H.Addable q
 565  , H.Zero q
 566  , H.Unit u
 567  ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
 568         journal_filter ctx j =
 569                 case Filter.simplified $ ctx_filter_balance ctx of
 570                  Right True | ctx_redundant ctx -> j
 571                  Right True ->
 572                         TreeMap.filter_with_Path_and_Node
 573                          (const . is_worth) <$> j
 574                  Right False -> const mempty <$> j
 575                  Left flt ->
 576                         (<$> j) $
 577                         TreeMap.map_Maybe_with_Path_and_Node
 578                          (\node account bal ->
 579                                 (if is_worth node bal then id else const Strict.Nothing) $
 580                                 case Map.mapMaybeWithKey
 581                                  (\unit qty ->
 582                                         if Filter.test flt
 583                                                  ( (H.chart_account_tags account (Format.journal_chart j), account)
 584                                                  , (unit, qty)
 585                                                  )
 586                                         then Just qty
 587                                         else Nothing
 588                                  ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
 589                                  m | Map.null m -> Strict.Nothing
 590                                  m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
 591                          )
 592                 where
 593                         is_worth node bal =
 594                                 let descendants = TreeMap.nodes
 595                                          (TreeMap.node_descendants node) in
 596                                 ctx_redundant ctx
 597                                 -- NOTE: worth if no descendant
 598                                 -- but Account's inclusive
 599                                 -- has at least a non-zero Amount
 600                                 || (Map.null descendants &&
 601                                         Foldable.any
 602                                                  (not . H.quantity_null . H.depolarize)
 603                                                  (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
 604                                 -- NOTE: worth if Account's exclusive
 605                                 -- has at least a non-zero Amount
 606                                 || (Foldable.any
 607                                          (not . H.quantity_null . H.depolarize)
 608                                          (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
 609                                 -- NOTE: worth if Account has at least more than
 610                                 -- one descendant Account whose inclusive
 611                                 -- has at least a non-zero Amount
 612                                 || Map.size
 613                                          ( Map.filter
 614                                                  ( Strict.maybe False
 615                                                          ( Foldable.any
 616                                                                  (not . H.quantity_null . H.depolarize)
 617                                                          . H.unBalance_by_Account_Sum
 618                                                          . Strict.inclusive )
 619                                                  . TreeMap.node_value )
 620                                                  descendants
 621                                          ) > 1
 622 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
 623         journal_filter ctx
 624          (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
 625                 Const $ Forall_Journal_Balance_by_Account_Expanded $
 626                 Format.journal_filter ctx j
 627
 628 -- Instances 'Format.Journal_Leijen_Table_Cells'
 629
 630 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
 631         journal_leijen_table_cells
 632          (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
 633                 Format.journal_leijen_table_cells j
 634
 635 -- Instances H.Balance_by_Account -> H.Balance_Expanded
 636
 637 instance
 638  ( Functor j
 639  , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
 640
 641  -- NOTE: constraints from H.balance_expanded
 642  , Ord as
 643  , Ord u
 644  , H.Addable q
 645  ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
 646                           Forall_Journal_Balance_by_Account_Expanded where
 647         journal_wrap =
 648                 Forall_Journal_Balance_by_Account_Expanded .
 649                 fmap H.balance_expanded
 650
 651 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
 652                              Forall_Journal_Balance_by_Account_Expanded where
 653         journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665 -- * 'H.Balance_by_Unit'
 666
 667 type Format_Journal_Balance_by_Unit
 668  = Format
 669    (   JCC.Journal Balance_by_Unit_JCC)
 670    (Ledger.Journal Balance_by_Unit_Ledger)
 671
 672 -- JCC
 673 type Balance_by_Unit_JCC
 674  = H.Balance_by_Unit JCC.Account
 675                      JCC.Unit
 676                      (H.Polarized JCC.Quantity)
 677 instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
 678         type Journal_Format   (JCC.Journal Balance_by_Unit_JCC)
 679          = Format_Journal_Balance_by_Unit
 680         journal_format = Format_JCC
 681
 682 -- Ledger
 683 type Balance_by_Unit_Ledger
 684  = H.Balance_by_Unit Ledger.Account
 685                      Ledger.Unit
 686                      (H.Polarized Ledger.Quantity)
 687 instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
 688         type Journal_Format   (Ledger.Journal Balance_by_Unit_Ledger)
 689          = Format_Journal_Balance_by_Unit
 690         journal_format = Format_Ledger
 691
 692 -- ** Class 'Journal_Balance_by_Unit'
 693
 694 class
 695  ( Format.Journal (j m)
 696  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
 697  , Format.Journal_Leijen_Table_Cells j m
 698  -- , Journal_Equilibrium_Postings j m
 699  )
 700  => Journal_Balance_by_Unit j m
 701
 702 instance Journal_Balance_by_Unit    JCC.Journal Balance_by_Unit_JCC
 703 instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
 704
 705 -- ** Type 'Forall_Journal_Balance_by_Unit'
 706
 707 data    Forall_Journal_Balance_by_Unit
 708  = forall j m. Journal_Balance_by_Unit  j m
 709  =>     Forall_Journal_Balance_by_Unit (j m)
 710
 711 instance Format.Journal Forall_Journal_Balance_by_Unit where
 712         type Journal_Format   Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
 713         journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
 714
 715 -- Instances H.Balance_by_Account -> H.Balance_by_Unit
 716
 717 instance
 718  ( Functor j
 719  , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
 720
 721  -- NOTE: constraints from H.balance_by_unit_of_by_account
 722  , H.Account (H.Account_Path as)
 723  , Ord as
 724  , Ord u
 725  , H.Addable q
 726  ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
 727                           Forall_Journal_Balance_by_Unit where
 728         journal_wrap =
 729                 Forall_Journal_Balance_by_Unit .
 730                 fmap (flip H.balance_by_unit_of_by_account mempty)
 731
 732 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
 733                              Forall_Journal_Balance_by_Unit where
 734         journal_wrap
 735          (Forall_Journal_Balance_by_Account j) =
 736                 Format.journal_wrap j
 737
 738 -- Instances H.Balance_Expanded -> H.Balance_by_Unit
 739
 740 instance
 741  ( Functor j
 742  , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
 743
 744  -- NOTE: constraints from H.balance_by_unit_of_expanded
 745  , H.Account (H.Account_Path as)
 746  , Ord as
 747  , Ord u
 748  , H.Addable q
 749  ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
 750                           Forall_Journal_Balance_by_Unit where
 751         journal_wrap =
 752                 Forall_Journal_Balance_by_Unit .
 753                 fmap (flip H.balance_by_unit_of_expanded mempty)
 754
 755 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
 756                              Forall_Journal_Balance_by_Unit where
 757         journal_wrap
 758          (Forall_Journal_Balance_by_Account_Expanded j) =
 759                 Format.journal_wrap j
 760
 761 -- Instances 'Format.Journal_Leijen_Table_Cells'
 762
 763 instance
 764  ( Format.Journal_Content j
 765  , Journal j
 766
 767  , a ~ Format.Journal_Account j
 768  , H.Account a
 769  , u ~ Format.Journal_Unit j
 770  , Ord u
 771  , q ~ Format.Journal_Quantity j
 772  , H.Addable (Format.Journal_Quantity j)
 773  ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
 774         journal_leijen_table_cells jnl acc =
 775                 let H.Balance_by_Unit bal = Format.journal_content jnl in
 776                 Map.foldrWithKey
 777                  (\unit amt ->
 778                         let qty = H.balance_by_unit_sum_quantity amt in
 779                         zipWith (:)
 780                                 [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
 781                                 , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
 782                                 , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
 783                                 , Leijen.Table.cell
 784                                 ]
 785                  ) acc bal
 786 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
 787         journal_leijen_table_cells
 788          (Const (Forall_Journal_Balance_by_Unit j)) =
 789                 Format.journal_leijen_table_cells j
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799 -- * Class 'Journal'
 800
 801 class
 802  ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
 803  , W.ToDoc1 j [Format.Journal_Transaction j]
 804  ) => Journal (j:: * -> *) where
 805         journal_posting
 806          :: forall m. j m
 807          -> H.Account_Path (Format.Journal_Account_Section j)
 808          -> Map (Format.Journal_Unit j)
 809                 (Format.Journal_Quantity j)
 810          -> [Text] -- ^ Comments
 811          -> Format.Journal_Posting j
 812         journal_transaction
 813          :: forall m. j m
 814          -> Text -- ^ Wording
 815          -> (H.Date, [H.Date])
 816          -> Map (H.Account_Path (Format.Journal_Account_Section j))
 817                 [Format.Journal_Posting j]
 818          -> Format.Journal_Transaction j
 819
 820 instance Journal JCC.Journal where
 821         journal_posting _j acct
 822          posting_amounts
 823          posting_comments =
 824                 (JCC.posting acct)
 825                  { JCC.posting_amounts
 826                  , JCC.posting_comments
 827                  }
 828         journal_transaction _j
 829          transaction_wording
 830          transaction_dates
 831          transaction_postings =
 832                 JCC.transaction
 833                  { JCC.transaction_wording
 834                  , JCC.transaction_dates
 835                  , JCC.transaction_postings
 836                  }
 837 instance Journal Ledger.Journal where
 838         journal_posting _j acct
 839          posting_amounts
 840          posting_comments =
 841                 (Ledger.posting acct)
 842                  { Ledger.posting_amounts
 843                  , Ledger.posting_comments
 844                  }
 845         journal_transaction _j
 846          transaction_wording
 847          transaction_dates
 848          transaction_postings =
 849                 Ledger.transaction
 850                  { Ledger.transaction_wording
 851                  , Ledger.transaction_dates
 852                  , Ledger.transaction_postings
 853                  }
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867 -- * Class 'Journal_Equilibrium_Transaction'
 868
 869 class Journal_Equilibrium_Transaction j m where
 870         journal_equilibrium_transaction
 871          :: j m
 872          -> C.Context
 873          -> Context
 874          -> Lang.Exercise_OC
 875          -> H.Date
 876          -> W.Doc
 877
 878 instance
 879  ( Format.Journal_Content j
 880  , Journal j
 881
 882  , as ~ Format.Journal_Account_Section j
 883  , Format.Journal_Account_Section j ~ Text
 884  , Format.Journal_Account j ~ TreeMap.Path Text
 885  , Num quantity
 886  , quantity ~ Format.Journal_Quantity j
 887  , Ord unit
 888  , Ord quantity
 889  , H.Zero (Format.Journal_Quantity j)
 890  , H.Addable (Format.Journal_Quantity j)
 891  , unit ~ Format.Journal_Unit j
 892  ) => Journal_Equilibrium_Transaction
 893  j (H.Balance_by_Account as unit (H.Polarized quantity)) where
 894         journal_equilibrium_transaction
 895          j c ctx oc now =
 896                 let bal_by_account = Format.journal_content j in
 897                 let H.Balance_by_Unit bal_by_unit =
 898                         H.balance_by_unit_of_by_account bal_by_account mempty in
 899                 let postings =
 900                         Map.foldlWithKey
 901                          (\acc unit H.Balance_by_Unit_Sum{..} ->
 902                                 let qty =
 903                                         (case oc of
 904                                          Lang.Exercise_Closing -> id
 905                                          Lang.Exercise_Opening -> negate) $
 906                                         H.depolarize balance_by_unit_sum_quantity in
 907                                 case H.quantity_sign qty of
 908                                  LT ->
 909                                         let account = snd $ ctx_account_equilibrium ctx in
 910                                         Map.insertWith mappend account
 911                                          [journal_posting j account
 912                                                  (Map.singleton unit qty)
 913                                                  [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
 914                                          acc
 915                                  EQ -> acc
 916                                  GT ->
 917                                         let account = fst $ ctx_account_equilibrium ctx in
 918                                         Map.insertWith mappend account
 919                                          [journal_posting j account
 920                                                  (Map.singleton unit qty)
 921                                                  [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
 922                                          acc
 923                          )
 924                          Map.empty
 925                          bal_by_unit
 926                  in
 927                 W.toDoc1 j [
 928                 journal_transaction j
 929                  (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
 930                  (now{Time.utctDayTime=0}, []) $
 931                 Map.unionWith mappend postings $
 932                 TreeMap.flatten_with_Path
 933                  (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
 934                         [ journal_posting j posting_account
 935                                  (flip fmap amount_by_unit $
 936                                         (case oc of
 937                                          Lang.Exercise_Closing -> negate
 938                                          Lang.Exercise_Opening -> id)
 939                                         . H.depolarize)
 940                                  []
 941                         ]
 942                  )
 943                  bal_by_account
 944                  ]
 945
 946 instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
 947         journal_equilibrium_transaction
 948          (Const (Forall_Journal_Balance_by_Account j)) =
 949                 journal_equilibrium_transaction j
 950
 951 -}
 952
 953 {-
 954 instance
 955   ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
 956         ( Forall_Journal_Balance_by_Account
 957         , Forall_Journal_Balance_by_Unit ) where
 958         toDoc c
 959          ( Forall_Journal_Balance_by_Account bal_by_account
 960          , Forall_Journal_Balance_by_Unit    bal_by_unit
 961          ) =
 962                 toDoc c (bal_by_account, bal_by_unit)
 963 -}
 964
 965 -}