cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TupleSections #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hcompta.CLI.Command.Balance where
  13
  14 import           Control.Applicative ((<*), Const(..), Applicative(..))
  15 import           Control.Arrow (first, (+++), (&&&), (***))
  16 import           Control.DeepSeq (NFData)
  17 import           Control.Monad (Monad(..), liftM, mapM)
  18 import           Control.Monad.IO.Class (liftIO)
  19 import           Data.Bool
  20 import           Data.Data
  21 import           Data.Decimal (Decimal)
  22 import           Data.Either (Either(..), partitionEithers)
  23 import           Data.Eq (Eq(..))
  24 import           Data.Foldable (Foldable(..), any)
  25 import           Data.Function (($), (.), const, on)
  26 import           Data.Functor (Functor(..), (<$>))
  27 import           Data.List ((++), repeat)
  28 -- import           Data.List.NonEmpty (NonEmpty(..))
  29 import           Data.Map.Strict (Map)
  30 import qualified Data.Map.Strict as Map
  31 import           Data.Maybe (Maybe(..))
  32 import           Data.Monoid (Monoid(..))
  33 import           Data.Ord (Ord(..), Ordering(..))
  34 import qualified Data.Strict.Maybe as Strict
  35 import           Data.String (String)
  36 import           Data.Text (Text)
  37 import qualified Data.Time.Clock as Time
  38 import           Data.Tuple (fst, snd)
  39 import           Prelude (Bounded(..), FilePath, IO, Num(..), id, flip, unlines, zipWith)
  40 import           System.Console.GetOpt
  41                  ( ArgDescr(..)
  42                  , OptDescr(..)
  43                  , usageInfo
  44                  )
  45 import           System.Environment as Env (getProgName)
  46 import           System.Exit (exitSuccess)
  47 import qualified System.IO as IO
  48 import qualified Text.Parsec
  49 import           Text.Show (Show(..))
  50
  51 import           Hcompta.Account (Account_Tags)
  52 import qualified Hcompta.Account as Account
  53 import qualified Hcompta.Balance as Balance
  54 import qualified Hcompta.CLI.Args as Args
  55 import qualified Hcompta.CLI.Context as C
  56 import qualified Hcompta.CLI.Env as CLI.Env
  57 import           Hcompta.CLI.Format (Format(..), Formats)
  58 import qualified Hcompta.CLI.Format as Format
  59 import           Hcompta.CLI.Format.JCC ()
  60 import           Hcompta.CLI.Format.Ledger ()
  61 import qualified Hcompta.CLI.Lang as Lang
  62 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
  63 import qualified Hcompta.CLI.Write as Write
  64 import qualified Hcompta.Chart as Chart
  65 import           Hcompta.Date (Date)
  66 import qualified Hcompta.Date as Date
  67 import qualified Hcompta.Filter as Filter
  68 import qualified Hcompta.Filter.Amount as Filter.Amount
  69 import qualified Hcompta.Filter.Read as Filter.Read
  70 import qualified Hcompta.Format.JCC as JCC
  71 import qualified Hcompta.Format.Ledger      as Ledger
  72 import qualified Hcompta.Format.Ledger.Read as Ledger
  73 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  74 import qualified Hcompta.Lib.Leijen as W
  75 import qualified Hcompta.Lib.Parsec as R
  76 import           Hcompta.Lib.TreeMap (TreeMap)
  77 import qualified Hcompta.Lib.TreeMap as TreeMap
  78 import           Hcompta.Polarize (Polarized)
  79 import qualified Hcompta.Polarize as Polarize
  80 import qualified Hcompta.Posting as Posting
  81 import qualified Hcompta.Quantity as Quantity
  82 import           Hcompta.Unit (Unit(..))
  83
  84 -- type Sum = (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
  85
  86 data Context
  87  =   Context
  88  { ctx_filter_transaction :: forall t.
  89                              ( Filter.Transaction t
  90                              , Filter.Amount_Quantity
  91                                (Posting.Posting_Amount
  92                                (Filter.Transaction_Posting t))
  93                                ~ Filter.Amount.Quantity
  94                              ) => Filter.Simplified
  95                                   (Filter.Filter_Bool
  96                                   (Filter.Filter_Transaction t))
  97  , ctx_filter_balance     :: forall b.
  98                              ( Filter.Balance b
  99                              , Filter.Amount_Quantity
 100                                (Filter.Balance_Amount b)
 101                                ~ Filter.Amount.Quantity
 102                              ) => Filter.Simplified
 103                                   (Filter.Filter_Bool
 104                                   (Filter.Filter_Balance b))
 105  -- , ctx_filter_posting      :: CLI.Format.Filter_Posting
 106  , ctx_heritage            :: Bool
 107  , ctx_input               :: [FilePath]
 108  , ctx_input_format        :: Formats
 109  , ctx_output              :: [(Write.Mode, FilePath)]
 110  , ctx_output_format       :: (Maybe Formats, Output_Format)
 111  , ctx_reduce_date         :: Bool
 112  , ctx_redundant           :: Bool
 113  , ctx_total_by_unit       :: Bool
 114  , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
 115  } -- deriving (Show)
 116
 117 data Output_Format
 118  =   Output_Format_Table
 119  |   Output_Format_Transaction Lang.Exercise_OC
 120  deriving (Eq, Show)
 121
 122 context :: C.Context -> Context
 123 context c =
 124         Context
 125          { ctx_filter_transaction  = Filter.Simplified $ Right True
 126          , ctx_filter_balance      = Filter.Simplified $ Right True
 127          -- , ctx_filter_posting      = mempty
 128          , ctx_heritage            = True
 129          , ctx_input               = []
 130          , ctx_input_format        = mempty
 131          , ctx_output              = []
 132          , ctx_output_format       = (Nothing, Output_Format_Table)
 133          , ctx_reduce_date         = True
 134          , ctx_redundant           = False
 135          , ctx_total_by_unit       = True
 136          , ctx_account_equilibrium =
 137                 let e = C.translate c Lang.Account_Equilibrium
 138                 in (e, e)
 139          }
 140
 141 usage :: C.Context -> IO String
 142 usage c = do
 143         bin <- Env.getProgName
 144         return $ unlines $
 145                 [ C.translate c Lang.Section_Description
 146                 , "  "++C.translate c Lang.Help_Command_Balance
 147                 , ""
 148                 , C.translate c Lang.Section_Syntax
 149                 , "  "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++
 150                                      " ["++C.translate c Lang.Type_File_Journal++"] [...]"
 151                 , ""
 152                 , usageInfo (C.translate c Lang.Section_Options) (options c)
 153                 ]
 154
 155 options :: C.Context -> Args.Options Context
 156 options c =
 157         [ Option "b" ["filter-balance"]
 158          (ReqArg (\s ctx -> do
 159                 filter <-
 160                         R.runParserT_with_Error
 161                          Filter.Read.filter_balance
 162                          Filter.Read.context "" s
 163                 case filter of
 164                  Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
 165                  Right flt ->
 166                         return $
 167                                 ctx{ctx_filter_balance =
 168                                         Filter.and (ctx_filter_balance ctx) $
 169                                         (Filter.simplify $
 170                                                 Filter.Read.get_Forall_Filter_Balance_Decimal <$> flt)
 171                                  }) $
 172                 C.translate c Lang.Type_Filter_Balance) $
 173                 C.translate c Lang.Help_Option_Filter_Balance
 174         {-, Option "p" ["filter-posting"]
 175          (ReqArg (\s ctx -> do
 176                 read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
 177                 case read of
 178                  Left ko -> Write.fatal c ko
 179                  Right filter -> return $
 180                         ctx{ctx_filter_posting =
 181                                 (ctx_filter_posting ctx <>) $
 182                                 CLI.Format.All
 183                                  (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
 184                                  (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
 185                          }) $
 186                 C.translate c Lang.Type_Filter_Posting) $
 187                 C.translate c Lang.Help_Option_Filter_Posting
 188         -}
 189         , Option "t" ["filter-transaction"]
 190          (ReqArg (\s ctx -> do
 191                 filter <-
 192                         R.runParserT_with_Error
 193                          Filter.Read.filter_transaction
 194                          Filter.Read.context "" s
 195                 case filter of
 196                  Left ko -> Write.fatal c ko
 197                  Right flt ->
 198                         return $
 199                                 ctx{ctx_filter_transaction =
 200                                         Filter.and (ctx_filter_transaction ctx) $
 201                                         (Filter.simplify $
 202                                                 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
 203                                  }) $
 204                 C.translate c Lang.Type_Filter_Transaction) $
 205                 C.translate c Lang.Help_Option_Filter_Transaction
 206         , Option "h" ["help"]
 207          (NoArg (\_ctx -> do
 208                 usage c >>= IO.hPutStr IO.stderr
 209                 exitSuccess)) $
 210                 C.translate c Lang.Help_Option_Help
 211         , Option "i" ["input"]
 212          (ReqArg (\s ctx -> do
 213                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 214                 C.translate c Lang.Type_File_Journal) $
 215                 C.translate c Lang.Help_Option_Input
 216         , Option "f" ["input-format"]
 217          (OptArg (\arg ctx -> do
 218                 ctx_input_format <- case arg of
 219                  Nothing       -> return $ Format_JCC ()
 220                  Just "jcc"    -> return $ Format_JCC ()
 221                  Just "ledger" -> return $ Format_Ledger ()
 222                  Just _        -> Write.fatal c $
 223                         W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
 224                 return $ ctx{ctx_input_format})
 225           "[jcc|ledger]")
 226           "input format"
 227         , Option "o" ["output"]
 228          (ReqArg (\s ctx -> do
 229                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
 230                 C.translate c Lang.Type_File) $
 231                 C.translate c Lang.Help_Option_Output
 232         , Option "O" ["overwrite"]
 233          (ReqArg (\s ctx -> do
 234                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 235                 C.translate c Lang.Type_File) $
 236                 C.translate c Lang.Help_Option_Overwrite
 237         {- NOTE: not used so far.
 238         , Option "" ["reduce-date"]
 239          (OptArg (\arg ctx -> do
 240                 ctx_reduce_date <- case arg of
 241                  Nothing    -> return $ True
 242                  Just "yes" -> return $ True
 243                  Just "no"  -> return $ False
 244                  Just _     -> Write.fatal c $
 245                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 246                 return $ ctx{ctx_reduce_date})
 247           "[yes|no]")
 248          "use advanced date reducer to speed up filtering"
 249         -}
 250         , Option "" ["redundant"]
 251          (OptArg (\arg ctx -> do
 252                 ctx_redundant <- case arg of
 253                  Nothing    -> return $ True
 254                  Just "yes" -> return $ True
 255                  Just "no"  -> return $ False
 256                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Redundant
 257                 return $ ctx{ctx_redundant})
 258           "[no|yes]") $
 259                 C.translate c Lang.Help_Option_Balance_Redundant
 260         , Option "" ["heritage"]
 261          (OptArg (\arg ctx -> do
 262                 ctx_heritage <- case arg of
 263                  Nothing    -> return $ True
 264                  Just "yes" -> return $ True
 265                  Just "no"  -> return $ False
 266                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Heritage
 267                 return $ ctx{ctx_heritage})
 268           "[yes|no]") $
 269                 C.translate c Lang.Help_Option_Balance_Heritage
 270         , Option "" ["total"]
 271          (OptArg (\arg ctx -> do
 272                 ctx_total_by_unit <- case arg of
 273                  Nothing    -> return $ True
 274                  Just "yes" -> return $ True
 275                  Just "no"  -> return $ False
 276                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Total
 277                 return $ ctx{ctx_total_by_unit})
 278           "[yes|no]") $
 279                 C.translate c Lang.Help_Option_Balance_Total
 280         , Option "F" ["output-format"]
 281          (ReqArg (\arg ctx -> do
 282                 ctx_output_format <- case arg of
 283                  "table"        -> return $ (Nothing                , Output_Format_Table)
 284                  "table.jcc"    -> return $ (Just $ Format_JCC    (), Output_Format_Table)
 285                  "table.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Table)
 286                  "open"         -> return $ (Nothing                , Output_Format_Transaction Lang.Exercise_Opening)
 287                  "open.jcc"     -> return $ (Just $ Format_JCC    (), Output_Format_Transaction Lang.Exercise_Opening)
 288                  "open.ledger"  -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Opening)
 289                  "close"        -> return $ (Nothing                , Output_Format_Transaction Lang.Exercise_Closing)
 290                  "close.jcc"    -> return $ (Just $ Format_JCC    (), Output_Format_Transaction Lang.Exercise_Closing)
 291                  "close.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Closing)
 292                  _              -> Write.fatal c Lang.Error_Option_Balance_Format
 293                 return $ ctx{ctx_output_format})
 294           "[table|close|open][.jcc|.ledger]") $
 295                 C.translate c Lang.Help_Option_Balance_Format
 296         , Option "" ["eq"]
 297          (ReqArg (\arg ctx -> do
 298                 ctx_account_equilibrium <-
 299                         fmap (\e -> (e, e)) $
 300                         case Text.Parsec.runParser
 301                                  (Ledger.read_account <* Text.Parsec.eof)
 302                                  () "" arg of
 303                          Right acct -> return acct
 304                          _          -> Write.fatal c Lang.Error_Option_Equilibrium
 305                 return $ ctx{ctx_account_equilibrium}) $
 306                 C.translate c Lang.Type_Account) $
 307                 C.translate c Lang.Help_Option_Equilibrium
 308         , Option "" ["eq-credit"]
 309          (ReqArg (\arg ctx -> do
 310                 ctx_account_equilibrium <-
 311                         fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
 312                         case Text.Parsec.runParser
 313                                  (Ledger.read_account <* Text.Parsec.eof)
 314                                  () "" arg of
 315                          Right acct -> return acct
 316                          _          -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
 317                 return $ ctx{ctx_account_equilibrium}) $
 318                 C.translate c Lang.Type_Account) $
 319                 C.translate c Lang.Help_Option_Equilibrium_Credit
 320         , Option "" ["eq-debit"]
 321          (ReqArg (\arg ctx -> do
 322                 ctx_account_equilibrium <-
 323                         fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
 324                         case Text.Parsec.runParser
 325                                  (Ledger.read_account <* Text.Parsec.eof)
 326                                  () "" arg of
 327                          Right acct -> return acct
 328                          _          -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
 329                 return $ ctx{ctx_account_equilibrium}) $
 330                 C.translate c Lang.Type_Account) $
 331                 C.translate c Lang.Help_Option_Equilibrium_Debit
 332         ]
 333
 334 run :: C.Context -> [String] -> IO ()
 335 run c args = do
 336         (ctx, inputs) <-
 337                 first (\x ->
 338                         case ctx_output x of
 339                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 340                          _  -> x) <$>
 341                 Args.parse c usage options (context c, args)
 342         input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
 343         read_journals <- mapM (liftIO . journal_read ctx) input_paths
 344         case partitionEithers read_journals of
 345          (errs@(_:_), _journals) -> Write.fatals c errs
 346          ([], (journals::[Forall_Journal_Balance_by_Account])) -> do
 347                 let bal_by_account =
 348                         mconcat $
 349                         fmap Format.journal_flatten $
 350                         case fst $ ctx_output_format ctx of
 351                          Just f -> Format.journal_empty f:journals
 352                          Nothing -> journals
 353                 now <- Date.now
 354                 with_color <- Write.with_color c IO.stdout
 355                 W.displayIO IO.stdout $
 356                         W.renderPretty with_color 1.0 maxBound $
 357                         case snd $ ctx_output_format ctx of
 358                          Output_Format_Table ->
 359                                 toDoc () $ Leijen.Table.table_of (c, ctx) bal_by_account
 360                          Output_Format_Transaction oc ->
 361                                 journal_equilibrium_transaction
 362                                  (Const bal_by_account::Const Forall_Journal_Balance_by_Account ())
 363                                  c ctx oc now
 364                 {-
 365                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 366                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 367                 Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 368                 let sty = Write.style { Write.style_pretty = True }
 369                 -}
 370
 371 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
 372         table_of (c, ctx) bal_by_account =
 373                 let lang = C.lang c in
 374                 let (rows_by_account, rows_by_unit) =
 375                         case ctx_heritage ctx of
 376                          True  -> rows_of_balance_by_account $ expand bal_by_account
 377                          False -> rows_of_balance_by_account          bal_by_account in
 378                 zipWith id
 379                  [ Leijen.Table.column (Lang.translate lang Lang.Title_Debit)   Leijen.Table.Align_Right
 380                  , Leijen.Table.column (Lang.translate lang Lang.Title_Credit)  Leijen.Table.Align_Right
 381                  , Leijen.Table.column (Lang.translate lang Lang.Title_Balance) Leijen.Table.Align_Right
 382                  , Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
 383                  ] $
 384                 rows_by_account $
 385                 (if ctx_total_by_unit ctx
 386                  then zipWith (:)
 387                          [ Leijen.Table.Cell_Line '=' 0
 388                          , Leijen.Table.Cell_Line '=' 0
 389                          , Leijen.Table.Cell_Line '=' 0
 390                          , Leijen.Table.Cell_Line ' ' 0
 391                          ] . rows_by_unit
 392                  else id) $
 393                 repeat []
 394                 where
 395                         expand
 396                          :: Forall_Journal_Balance_by_Account
 397                          -> Forall_Journal_Balance_by_Account_Expanded
 398                         expand = Format.journal_wrap
 399                         rows_of_balance_by_account
 400                          :: ( Format.Journal_Filter Context (Const bal_by_account) ()
 401                             , Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
 402                             , Format.Journal_Leijen_Table_Cells (Const bal_by_account) ()
 403                             )
 404                          => bal_by_account
 405                          -> ( [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]]
 406                             , [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]] )
 407                         rows_of_balance_by_account =
 408                                 (***) Format.journal_leijen_table_cells
 409                                       Format.journal_leijen_table_cells .
 410                                 (&&&) id sum_by_unit .
 411                                 Format.journal_filter ctx .
 412                                 Const
 413                                 where
 414                                         sum_by_unit
 415                                          :: Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
 416                                          => Const bal_by_account ()
 417                                          -> Const Forall_Journal_Balance_by_Unit ()
 418                                         sum_by_unit = Const . Format.journal_wrap . getConst
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429 -- * 'Balance.Balance_by_Account'
 430
 431 -- ** Type 'Format_Balance_by_Account'
 432
 433 type Format_Journal_Balance_by_Account
 434  = Format
 435    (   JCC.Journal Balance_by_Account_JCC)
 436    (Ledger.Journal Balance_by_Account_Ledger)
 437
 438 -- JCC
 439 type Balance_by_Account_JCC
 440  = Balance.Balance_by_Account JCC.Account_Section
 441                               JCC.Unit
 442                               (Polarized JCC.Quantity)
 443 instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
 444         type Journal_Format   (JCC.Journal Balance_by_Account_JCC)
 445          = Format_Journal_Balance_by_Account
 446         journal_format = Format_JCC
 447
 448 -- Ledger
 449 type Balance_by_Account_Ledger
 450  = Balance.Balance_by_Account Ledger.Account_Section
 451                               Ledger.Unit
 452                               (Polarized Ledger.Quantity)
 453 instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
 454         type Journal_Format   (Ledger.Journal Balance_by_Account_Ledger)
 455          = Format_Journal_Balance_by_Account
 456         journal_format = Format_Ledger
 457
 458 -- ** Class 'Journal_Balance_by_Account'
 459
 460 class
 461  ( Format.Journal (j m)
 462  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
 463  , Format.Journal_Read j
 464  , Format.Journal_Monoid (j m)
 465  , Format.Journal_Leijen_Table_Cells j m
 466  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
 467  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
 468  , Format.Journal_Filter Context j m
 469  , Journal_Equilibrium_Transaction j m
 470  ) => Journal_Balance_by_Account j m
 471
 472 instance Journal_Balance_by_Account    JCC.Journal Balance_by_Account_JCC
 473 instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
 474
 475 -- ** Type 'Forall_Journal_Balance_by_Account'
 476
 477 data    Forall_Journal_Balance_by_Account
 478  = forall j m. Journal_Balance_by_Account  j m
 479  =>     Forall_Journal_Balance_by_Account (j m)
 480
 481 instance Format.Journal Forall_Journal_Balance_by_Account where
 482         type Journal_Format   Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
 483         journal_format
 484          (Forall_Journal_Balance_by_Account j) =
 485                 Format.journal_format j
 486 instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
 487         journal_empty f =
 488                 case f of
 489                  Format_JCC    () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
 490                  Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
 491 instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
 492         journal_flatten
 493          (Forall_Journal_Balance_by_Account j) =
 494                 Forall_Journal_Balance_by_Account $
 495                 Format.journal_flatten j
 496         journal_fold f (Forall_Journal_Balance_by_Account j) =
 497                 Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
 498 instance Monoid Forall_Journal_Balance_by_Account where
 499         mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
 500         mappend x y =
 501                 case (mappend `on` Format.journal_format) x y of
 502                  Format_JCC    j -> Forall_Journal_Balance_by_Account j
 503                  Format_Ledger j -> Forall_Journal_Balance_by_Account j
 504         mconcat js =
 505                 case js of
 506                  [] -> mempty
 507                  j:jn -> foldl' mappend j jn
 508
 509 -- ** 'journal_read'
 510
 511 type Journal_Filter_Simplified transaction
 512  = Filter.Simplified
 513    (Filter.Filter_Bool
 514    (Filter.Filter_Transaction transaction))
 515 type Journal_Read_Cons txn
 516  = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
 517 journal_read
 518  :: Context -> FilePath
 519  -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
 520 journal_read ctx =
 521         case ctx_input_format ctx of
 522          Format_JCC () ->
 523                 let wrap (j::JCC.Journal Balance_by_Account_JCC)
 524                          = Forall_Journal_Balance_by_Account j in
 525                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 526                          = Filter.Filtered (ctx_filter_transaction ctx) in
 527                 liftM ((+++) Format.Message wrap) .
 528                 Format.journal_read cons
 529          Format_Ledger () ->
 530                 let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
 531                          = Forall_Journal_Balance_by_Account j in
 532                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 533                          = Filter.Filtered (ctx_filter_transaction ctx) in
 534                 liftM ((+++) Format.Message wrap) .
 535                 Format.journal_read cons
 536
 537 {-
 538 -- ** Type family 'Balance_by_Account'
 539
 540 type family Balance_by_Account (j:: * -> *) m
 541 type instance Balance_by_Account
 542    j (Balance.Expanded           as u (Polarized q))
 543  = j (Balance.Balance_by_Account as u (Polarized q))
 544 type instance Balance_by_Account
 545    (Const Forall_Journal_Balance_by_Account_Expanded) ()
 546  = (Const Forall_Journal_Balance_by_Account         ) ()
 547 -}
 548
 549 -- Instances 'Format.Journal_Filter'
 550
 551 instance
 552  ( Functor j
 553  , Format.Journal_Chart j
 554
 555  , as ~ Format.Journal_Account_Section j
 556  , Data as
 557  , Filter.Account (Account_Tags, TreeMap.Path as)
 558  , NFData as
 559  , Ord as
 560  , Show as
 561
 562  , q ~ Format.Journal_Quantity j
 563  , Format.Journal_Quantity j ~ Decimal
 564  , Quantity.Addable q
 565  , Quantity.Zero q
 566
 567  , Unit u
 568  ) => Format.Journal_Filter Context j (Balance.Balance_by_Account as u (Polarized q)) where
 569         journal_filter ctx j =
 570                 case Filter.simplified $ ctx_filter_balance ctx of
 571                  Right True | ctx_redundant ctx -> j
 572                  Right True ->
 573                         TreeMap.filter_with_Path_and_Node
 574                          (\n _p -> is_worth n) <$> j
 575                  Right False -> const mempty <$> j
 576                  Left flt ->
 577                         TreeMap.map_Maybe_with_Path_and_Node
 578                          (\node account (Balance.Account_Sum 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                                                  ( (Chart.account_tags account (Format.journal_chart j), account)
 584                                                  , (unit, qty)
 585                                                  )
 586                                         then Just qty
 587                                         else Nothing
 588                                  ) bal of
 589                                  m | Map.null m -> Strict.Nothing
 590                                  m -> Strict.Just $ Balance.Account_Sum m
 591                          ) <$> j
 592                 where
 593                         is_worth
 594                          :: (Ord k0, Foldable t0, Quantity.Addable a0, Quantity.Zero a0)
 595                          => TreeMap.Node k0 x0
 596                          -> t0 (Polarized a0)
 597                          -> Bool
 598                         is_worth _node bal =
 599                                 ctx_redundant ctx
 600                                 -- NOTE: worth if no descendant
 601                                 -- but Account's exclusive
 602                                 -- has at least a non-zero Amount
 603                                 || Data.Foldable.any
 604                                          (not . Quantity.quantity_null . Polarize.depolarize)
 605                                          bal
 606 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
 607         journal_filter ctx
 608          (Const (Forall_Journal_Balance_by_Account j)) =
 609                 Const $ Forall_Journal_Balance_by_Account $
 610                 Format.journal_filter ctx j
 611
 612 -- Instances 'Format.Journal_Leijen_Table_Cells'
 613
 614 instance
 615  ( Format.Journal_Content j
 616  , Journal j
 617
 618  , as ~ Format.Journal_Account_Section j
 619  , Ord as
 620  , Quantity.Addable (Format.Journal_Quantity j)
 621
 622  , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
 623
 624  , Balance_Account_Sum amt
 625  , Balance_Account_Sum_Unit amt ~ Format.Journal_Unit j
 626  , Balance_Account_Sum_Quantity amt ~ Polarized (Format.Journal_Quantity j)
 627  ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
 628         journal_leijen_table_cells jnl =
 629                 flip (TreeMap.foldr_with_Path
 630                  (\account balance rows ->
 631                         let Balance.Account_Sum bal = balance_by_account_sum balance in
 632                         Map.foldrWithKey
 633                          (\unit qty ->
 634                                 zipWith (:)
 635                                  [ cell_of $ (unit,) <$> Polarize.polarized_positive qty
 636                                  , cell_of $ (unit,) <$> Polarize.polarized_negative qty
 637                                  , cell_of (unit, Polarize.depolarize qty)
 638                                  , cell_of account
 639                                  ]
 640                          )
 641                          rows bal
 642                  ))
 643                  (Format.journal_content jnl)
 644                 where
 645                         cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
 646                         cell_of = Leijen.Table.cell_of_forall_param jnl
 647 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
 648         journal_leijen_table_cells
 649          (Const (Forall_Journal_Balance_by_Account j)) =
 650                 Format.journal_leijen_table_cells j
 651
 652 -- ** Class 'Balance_Account_Sum'
 653
 654 -- | A class to get a 'Balance.Account_Sum'
 655 --   when operating on 'Balance.Balance_by_Account'
 656 --   or 'Balance.Expanded' 'Balance.inclusive' field.
 657 class Balance_Account_Sum amt where
 658         type Balance_Account_Sum_Unit     amt
 659         type Balance_Account_Sum_Quantity amt
 660         balance_by_account_sum
 661          :: amt -> Balance.Account_Sum (Balance_Account_Sum_Unit amt)
 662                                        (Balance_Account_Sum_Quantity amt)
 663 instance Balance_Account_Sum (Balance.Account_Sum u q) where
 664         type Balance_Account_Sum_Unit     (Balance.Account_Sum u q) = u
 665         type Balance_Account_Sum_Quantity (Balance.Account_Sum u q) = q
 666         balance_by_account_sum = id
 667 instance Balance_Account_Sum (Balance.Account_Sum_Expanded u q) where
 668         type Balance_Account_Sum_Unit     (Balance.Account_Sum_Expanded u q) = u
 669         type Balance_Account_Sum_Quantity (Balance.Account_Sum_Expanded u q) = q
 670         balance_by_account_sum = Balance.inclusive
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681 -- * 'Balance.Expanded'
 682
 683 -- ** Type 'Format_Journal_Balance_by_Account_Expanded'
 684
 685 type Format_Journal_Balance_by_Account_Expanded
 686  = Format
 687    (   JCC.Journal Balance_by_Account_Expanded_JCC)
 688    (Ledger.Journal Balance_by_Account_Expanded_Ledger)
 689
 690 -- JCC
 691 type Balance_by_Account_Expanded_JCC
 692  = Balance.Expanded JCC.Account_Section
 693                     JCC.Unit
 694                     (Polarized JCC.Quantity)
 695 instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
 696         type Journal_Format   (JCC.Journal Balance_by_Account_Expanded_JCC)
 697          = Format_Journal_Balance_by_Account_Expanded
 698         journal_format = Format_JCC
 699
 700 -- Ledger
 701 type Balance_by_Account_Expanded_Ledger
 702  = Balance.Expanded Ledger.Account_Section
 703                     Ledger.Unit
 704                     (Polarized Ledger.Quantity)
 705 instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
 706         type Journal_Format   (Ledger.Journal Balance_by_Account_Expanded_Ledger)
 707          = Format_Journal_Balance_by_Account_Expanded
 708         journal_format = Format_Ledger
 709
 710 -- ** Class 'Journal_Balance_by_Account_Expanded'
 711
 712 class
 713  ( Format.Journal (j m)
 714  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
 715  , Format.Journal_Leijen_Table_Cells j m
 716  , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
 717  , Format.Journal_Filter Context j m
 718  ) => Journal_Balance_by_Account_Expanded j m
 719
 720 instance Journal_Balance_by_Account_Expanded    JCC.Journal Balance_by_Account_Expanded_JCC
 721 instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
 722
 723 -- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
 724
 725 data    Forall_Journal_Balance_by_Account_Expanded
 726  = forall j m. Journal_Balance_by_Account_Expanded  j m
 727  =>     Forall_Journal_Balance_by_Account_Expanded (j m)
 728
 729 instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
 730         type Journal_Format   Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
 731         journal_format
 732          (Forall_Journal_Balance_by_Account_Expanded j) =
 733                 Format.journal_format j
 734
 735 -- Instances 'Format.Journal_Filter'
 736
 737 instance
 738  ( Functor j
 739  , Format.Journal_Chart j
 740  , as ~ Format.Journal_Account_Section j
 741  , Data as
 742  , Filter.Account (Account_Tags, TreeMap.Path as)
 743  , NFData as
 744  , Ord as
 745  , Show as
 746  , q ~ Format.Journal_Quantity j
 747  , Format.Journal_Quantity j ~ Decimal
 748  , Quantity.Addable q
 749  , Quantity.Zero q
 750  , Unit u
 751  ) => Format.Journal_Filter Context j (Balance.Expanded as u (Polarized q)) where
 752         journal_filter ctx j =
 753                 case Filter.simplified $ ctx_filter_balance ctx of
 754                  Right True | ctx_redundant ctx -> j
 755                  Right True ->
 756                         TreeMap.filter_with_Path_and_Node
 757                          (const . is_worth) <$> j
 758                  Right False -> const mempty <$> j
 759                  Left flt ->
 760                         TreeMap.map_Maybe_with_Path_and_Node
 761                          (\node account bal ->
 762                                 (if is_worth node bal then id else const Strict.Nothing) $
 763                                 case Map.mapMaybeWithKey
 764                                  (\unit qty ->
 765                                         if Filter.test flt
 766                                                  ( (Chart.account_tags account (Format.journal_chart j), account)
 767                                                  , (unit, qty)
 768                                                  )
 769                                         then Just qty
 770                                         else Nothing
 771                                  ) (Balance.get_Account_Sum $ Balance.inclusive bal) of
 772                                  m | Map.null m -> Strict.Nothing
 773                                  m -> Strict.Just $ bal{Balance.inclusive=Balance.Account_Sum m}
 774                          ) <$> j
 775                 where
 776                         is_worth node bal =
 777                                 let descendants = TreeMap.nodes
 778                                          (TreeMap.node_descendants node) in
 779                                 ctx_redundant ctx
 780                                 -- NOTE: worth if no descendant
 781                                 -- but Account's inclusive
 782                                 -- has at least a non-zero Amount
 783                                 || (Map.null descendants
 784                                          && Data.Foldable.any
 785                                                  (not . Quantity.quantity_null . Polarize.depolarize)
 786                                                  (Balance.get_Account_Sum $ Balance.inclusive bal))
 787                                 -- NOTE: worth if Account's exclusive
 788                                 -- has at least a non-zero Amount
 789                                 || (Data.Foldable.any
 790                                          (not . Quantity.quantity_null . Polarize.depolarize)
 791                                          (Balance.get_Account_Sum $ Balance.exclusive bal))
 792                                 -- NOTE: worth if Account has at least more than
 793                                 -- one descendant Account whose inclusive
 794                                 -- has at least a non-zero Amount
 795                                 || Map.size
 796                                          ( Map.filter
 797                                                  ( Strict.maybe False
 798                                                          ( Data.Foldable.any
 799                                                                  (not . Quantity.quantity_null . Polarize.depolarize)
 800                                                          . Balance.get_Account_Sum
 801                                                          . Balance.inclusive )
 802                                                  . TreeMap.node_value )
 803                                                  descendants
 804                                          ) > 1
 805 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
 806         journal_filter ctx
 807          (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
 808                 Const $ Forall_Journal_Balance_by_Account_Expanded $
 809                 Format.journal_filter ctx j
 810
 811 -- Instances 'Format.Journal_Leijen_Table_Cells'
 812
 813 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
 814         journal_leijen_table_cells
 815          (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
 816                 Format.journal_leijen_table_cells j
 817
 818 -- Instances Balance.Balance_by_Account -> Balance.Expanded
 819
 820 instance
 821  ( Functor j
 822  , Journal_Balance_by_Account_Expanded j (Balance.Expanded as u q)
 823
 824  -- NOTE: constraints from Balance.expanded
 825  , Ord as
 826  , Ord u
 827  , Quantity.Addable q
 828  ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
 829                           Forall_Journal_Balance_by_Account_Expanded where
 830         journal_wrap =
 831                 Forall_Journal_Balance_by_Account_Expanded .
 832                 fmap Balance.expanded
 833
 834 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
 835                              Forall_Journal_Balance_by_Account_Expanded where
 836         journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848 -- * 'Balance.Balance_by_Unit'
 849
 850 type Format_Journal_Balance_by_Unit
 851  = Format
 852    (   JCC.Journal Balance_by_Unit_JCC)
 853    (Ledger.Journal Balance_by_Unit_Ledger)
 854
 855 -- JCC
 856 type Balance_by_Unit_JCC
 857  = Balance.Balance_by_Unit JCC.Account
 858                            JCC.Unit
 859                            (Polarized JCC.Quantity)
 860 instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
 861         type Journal_Format   (JCC.Journal Balance_by_Unit_JCC)
 862          = Format_Journal_Balance_by_Unit
 863         journal_format = Format_JCC
 864
 865 -- Ledger
 866 type Balance_by_Unit_Ledger
 867  = Balance.Balance_by_Unit Ledger.Account
 868                            Ledger.Unit
 869                            (Polarized Ledger.Quantity)
 870 instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
 871         type Journal_Format   (Ledger.Journal Balance_by_Unit_Ledger)
 872          = Format_Journal_Balance_by_Unit
 873         journal_format = Format_Ledger
 874
 875 -- ** Class 'Journal_Balance_by_Unit'
 876
 877 class
 878  ( Format.Journal (j m)
 879  , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
 880  , Format.Journal_Leijen_Table_Cells j m
 881  -- , Journal_Equilibrium_Postings j m
 882  )
 883  => Journal_Balance_by_Unit j m
 884
 885 instance Journal_Balance_by_Unit    JCC.Journal Balance_by_Unit_JCC
 886 instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
 887
 888 -- ** Type 'Forall_Journal_Balance_by_Unit'
 889
 890 data    Forall_Journal_Balance_by_Unit
 891  = forall j m. Journal_Balance_by_Unit  j m
 892  =>     Forall_Journal_Balance_by_Unit (j m)
 893
 894 instance Format.Journal Forall_Journal_Balance_by_Unit where
 895         type Journal_Format   Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
 896         journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
 897
 898 -- Instances Balance.Balance_by_Account -> Balance.Balance_by_Unit
 899
 900 instance
 901  ( Functor j
 902  , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
 903
 904  -- NOTE: constraints from Balance.by_unit_of_by_account
 905  , Account.Account (Account.Account_Path as)
 906  , Ord as
 907  , Ord u
 908  , Quantity.Addable q
 909  ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
 910                           Forall_Journal_Balance_by_Unit where
 911         journal_wrap =
 912                 Forall_Journal_Balance_by_Unit .
 913                 fmap (flip Balance.by_unit_of_by_account mempty)
 914
 915 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
 916                              Forall_Journal_Balance_by_Unit where
 917         journal_wrap
 918          (Forall_Journal_Balance_by_Account j) =
 919                 Format.journal_wrap j
 920
 921 -- Instances Balance.Expanded -> Balance.Balance_by_Unit
 922
 923 instance
 924  ( Functor j
 925  , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
 926
 927  -- NOTE: constraints from Balance.by_unit_of_expanded
 928  , Account.Account (Account.Account_Path as)
 929  , Ord as
 930  , Ord u
 931  , Quantity.Addable q
 932  ) => Format.Journal_Wrap (j (Balance.Expanded as u q))
 933                           Forall_Journal_Balance_by_Unit where
 934         journal_wrap =
 935                 Forall_Journal_Balance_by_Unit .
 936                 fmap (flip Balance.by_unit_of_expanded mempty)
 937
 938 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
 939                              Forall_Journal_Balance_by_Unit where
 940         journal_wrap
 941          (Forall_Journal_Balance_by_Account_Expanded j) =
 942                 Format.journal_wrap j
 943
 944 -- Instances 'Format.Journal_Leijen_Table_Cells'
 945
 946 instance
 947  ( Format.Journal_Content j
 948  , Journal j
 949
 950  , a ~ Format.Journal_Account j
 951  , Account.Account a
 952  , u ~ Format.Journal_Unit j
 953  , Ord u
 954  , q ~ Format.Journal_Quantity j
 955  , Quantity.Addable (Format.Journal_Quantity j)
 956  ) => Format.Journal_Leijen_Table_Cells j (Balance.Balance_by_Unit a u (Polarized q)) where
 957         journal_leijen_table_cells jnl acc =
 958                 let Balance.Balance_by_Unit bal = Format.journal_content jnl in
 959                 Map.foldrWithKey
 960                  (\unit amt ->
 961                         let qty = Balance.unit_sum_quantity amt in
 962                         zipWith (:)
 963                                 [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_positive qty
 964                                 , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_negative qty
 965                                 , Leijen.Table.cell_of_forall_param jnl (unit, Polarize.depolarize qty)
 966                                 , Leijen.Table.cell
 967                                 ]
 968                  ) acc bal
 969 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
 970         journal_leijen_table_cells
 971          (Const (Forall_Journal_Balance_by_Unit j)) =
 972                 Format.journal_leijen_table_cells j
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982 -- * Class 'Journal'
 983
 984 class
 985  ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
 986  , W.Leijen_of_forall_param j [Format.Journal_Transaction j]
 987  ) => Journal (j:: * -> *) where
 988         journal_posting
 989          :: forall m. j m
 990          -> Account.Account_Path (Format.Journal_Account_Section j)
 991          -> Map (Format.Journal_Unit j)
 992                 (Format.Journal_Quantity j)
 993          -> [Text] -- ^ Comments
 994          -> Format.Journal_Posting j
 995         journal_transaction
 996          :: forall m. j m
 997          -> Text -- ^ Wording
 998          -> (Date, [Date])
 999          -> Map (Account.Account_Path (Format.Journal_Account_Section j))
1000                 [Format.Journal_Posting j]
1001          -> Format.Journal_Transaction j
1002
1003 instance Journal JCC.Journal where
1004         journal_posting _j acct
1005          posting_amounts
1006          posting_comments =
1007                 (JCC.posting acct)
1008                  { JCC.posting_amounts
1009                  , JCC.posting_comments
1010                  }
1011         journal_transaction _j
1012          transaction_wording
1013          transaction_dates
1014          transaction_postings =
1015                 JCC.transaction
1016                  { JCC.transaction_wording
1017                  , JCC.transaction_dates
1018                  , JCC.transaction_postings
1019                  }
1020 instance Journal Ledger.Journal where
1021         journal_posting _j acct
1022          posting_amounts
1023          posting_comments =
1024                 (Ledger.posting acct)
1025                  { Ledger.posting_amounts
1026                  , Ledger.posting_comments
1027                  }
1028         journal_transaction _j
1029          transaction_wording
1030          transaction_dates
1031          transaction_postings =
1032                 Ledger.transaction
1033                  { Ledger.transaction_wording
1034                  , Ledger.transaction_dates
1035                  , Ledger.transaction_postings
1036                  }
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050 -- * Class 'Journal_Equilibrium_Transaction'
1051
1052 class Journal_Equilibrium_Transaction j m where
1053         journal_equilibrium_transaction
1054          :: j m
1055          -> C.Context
1056          -> Context
1057          -> Lang.Exercise_OC
1058          -> Date
1059          -> W.Doc
1060
1061 instance
1062  ( Format.Journal_Content j
1063  , Journal j
1064
1065  , as ~ Format.Journal_Account_Section j
1066  , Format.Journal_Account_Section j ~ Text
1067  , Format.Journal_Account j ~ TreeMap.Path Text
1068  , Num quantity
1069  , quantity ~ Format.Journal_Quantity j
1070  , Ord unit
1071  , Ord quantity
1072  , Quantity.Zero (Format.Journal_Quantity j)
1073  , Quantity.Addable (Format.Journal_Quantity j)
1074  , unit ~ Format.Journal_Unit j
1075  ) => Journal_Equilibrium_Transaction
1076  j (Balance.Balance_by_Account as unit (Polarized quantity)) where
1077         journal_equilibrium_transaction
1078          j c ctx oc now =
1079                 let bal_by_account = Format.journal_content j in
1080                 let Balance.Balance_by_Unit bal_by_unit =
1081                         Balance.by_unit_of_by_account bal_by_account mempty in
1082                 let postings =
1083                         Map.foldlWithKey
1084                          (\acc unit Balance.Unit_Sum{Balance.unit_sum_quantity} ->
1085                                 let qty =
1086                                         (case oc of
1087                                          Lang.Exercise_Closing -> id
1088                                          Lang.Exercise_Opening -> negate) $
1089                                         Polarize.depolarize unit_sum_quantity in
1090                                 case Quantity.quantity_sign qty of
1091                                  LT ->
1092                                         let account = snd $ ctx_account_equilibrium ctx in
1093                                         Map.insertWith mappend account
1094                                          [journal_posting j account
1095                                                  (Map.singleton unit qty)
1096                                                  [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
1097                                          acc
1098                                  EQ -> acc
1099                                  GT ->
1100                                         let account = fst $ ctx_account_equilibrium ctx in
1101                                         Map.insertWith mappend account
1102                                          [journal_posting j account
1103                                                  (Map.singleton unit qty)
1104                                                  [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
1105                                          acc
1106                          )
1107                          Map.empty
1108                          bal_by_unit
1109                  in
1110                 W.leijen_of_forall_param j [
1111                 journal_transaction j
1112                  (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
1113                  (now{Time.utctDayTime=0}, []) $
1114                 Map.unionWith mappend postings $
1115                 TreeMap.flatten_with_Path
1116                  (\posting_account (Balance.Account_Sum amount_by_unit) ->
1117                         [ journal_posting j posting_account
1118                                  (flip fmap amount_by_unit $
1119                                         (case oc of
1120                                          Lang.Exercise_Closing -> negate
1121                                          Lang.Exercise_Opening -> id)
1122                                         . Polarize.depolarize)
1123                                  []
1124                         ]
1125                  )
1126                  bal_by_account
1127                  ]
1128
1129 instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
1130         journal_equilibrium_transaction
1131          (Const (Forall_Journal_Balance_by_Account j)) =
1132                 journal_equilibrium_transaction j
1133
1134 {-
1135 instance
1136   ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
1137         ( Forall_Journal_Balance_by_Account
1138         , Forall_Journal_Balance_by_Unit ) where
1139         toDoc c
1140          ( Forall_Journal_Balance_by_Account bal_by_account
1141          , Forall_Journal_Balance_by_Unit    bal_by_unit
1142          ) =
1143                 toDoc c (bal_by_account, bal_by_unit)
1144 -}