cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TupleSections #-}
   7 module Hcompta.CLI.Command.Balance where
   8
   9 import           Control.Applicative ((<*), Const(..))
  10 import           Control.Arrow (first)
  11 import           Control.Monad (Monad(..), forM_, liftM, mapM)
  12 import           Control.Monad.IO.Class (liftIO)
  13 import           Control.Monad.Trans.Except (runExceptT)
  14 import           Data.Bool
  15 import           Data.Either (Either(..), partitionEithers)
  16 import           Data.Eq (Eq(..))
  17 import           Data.Foldable (Foldable(..), any)
  18 import           Data.Functor (Functor(..), (<$>))
  19 import           Data.List ((++), repeat)
  20 import qualified Data.Map.Strict as Data.Map
  21 import           Data.Maybe (Maybe(..), maybe)
  22 import           Data.Monoid (Monoid(..), (<>))
  23 import           Data.Ord (Ord(..), Ordering(..))
  24 import qualified Data.Strict.Maybe as Strict
  25 import           Data.String (String)
  26 import           Data.Tuple (fst, snd)
  27 import qualified Data.Time.Clock as Time
  28 import           Prelude (($), (.), FilePath, IO, Num(..), const, id, flip, unlines, zipWith)
  29 import qualified Text.Parsec
  30 import           Text.Show (Show(..))
  31 import           System.Console.GetOpt
  32                  ( ArgDescr(..)
  33                  , OptDescr(..)
  34                  , usageInfo
  35                  )
  36 import           System.Environment as Env (getProgName)
  37 import           System.Exit (exitSuccess)
  38 import qualified System.IO as IO
  39
  40 import           Hcompta.Account (Account)
  41 import qualified Hcompta.Account as Account
  42 import qualified Hcompta.Account.Read as Account.Read
  43 import           Hcompta.Amount (Amount)
  44 import qualified Hcompta.Amount as Amount
  45 import           Hcompta.Amount.Unit (Unit)
  46 import qualified Hcompta.Amount.Write as Amount.Write
  47 import qualified Hcompta.Balance as Balance
  48 import           Hcompta.Chart (Chart)
  49 import qualified Hcompta.Chart as Chart
  50 import qualified Hcompta.CLI.Args as Args
  51 import qualified Hcompta.CLI.Context as C
  52 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  53 import qualified Hcompta.CLI.Lang as Lang
  54 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  55 import qualified Hcompta.CLI.Write as Write
  56 import qualified Hcompta.Date as Date
  57 import qualified Hcompta.Filter as Filter
  58 import qualified Hcompta.Filter.Read as Filter.Read
  59 import qualified Hcompta.Format.Ledger as Ledger
  60 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  61 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  62 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  63 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  64 import qualified Hcompta.Lib.Leijen as W
  65 import           Hcompta.Lib.TreeMap (TreeMap)
  66 import qualified Hcompta.Lib.TreeMap as TreeMap
  67 import qualified Hcompta.Posting as Posting
  68 import qualified Hcompta.Tag as Tag
  69
  70 data Ctx
  71  =   Ctx
  72  { ctx_filter_balance      :: Filter.Simplified
  73                               (Filter.Filter_Bool
  74                               (Filter.Filter_Balance
  75                               ((Account, Tag.Tags), Amount.Sum Amount)))
  76  , ctx_filter_posting      :: Filter.Simplified
  77                               (Filter.Filter_Bool
  78                               (Filter.Filter_Posting
  79                               (Chart, Ledger.Posting)))
  80  , ctx_filter_transaction  :: Filter.Simplified
  81                               (Filter.Filter_Bool
  82                               (Filter.Filter_Transaction
  83                               (Chart, Ledger.Transaction)))
  84  , ctx_heritage            :: Bool
  85  , ctx_input               :: [FilePath]
  86  , ctx_output              :: [(Write.Mode, FilePath)]
  87  , ctx_reduce_date         :: Bool
  88  , ctx_redundant           :: Bool
  89  , ctx_total_by_unit       :: Bool
  90  , ctx_format_output       :: Format_Output
  91  , ctx_account_equilibrium :: (Account, Account)
  92  } deriving (Show)
  93
  94 data Format_Output
  95  =   Format_Output_Table
  96  |   Format_Output_Transaction Lang.Exercise_OC
  97  deriving (Eq, Show)
  98
  99 nil :: C.Context -> Ctx
 100 nil c =
 101         Ctx
 102          { ctx_filter_balance      = mempty
 103          , ctx_filter_posting      = mempty
 104          , ctx_filter_transaction  = mempty
 105          , ctx_heritage            = True
 106          , ctx_input               = []
 107          , ctx_output              = []
 108          , ctx_reduce_date         = True
 109          , ctx_redundant           = False
 110          , ctx_total_by_unit       = True
 111          , ctx_format_output       = Format_Output_Table
 112          , ctx_account_equilibrium =
 113                 let e = C.translate c Lang.Account_Equilibrium
 114                 in (e, e)
 115          }
 116
 117 usage :: C.Context -> IO String
 118 usage c = do
 119         bin <- Env.getProgName
 120         return $ unlines $
 121                 [ C.translate c Lang.Section_Description
 122                 , "  "++C.translate c Lang.Help_Command_Balance
 123                 , ""
 124                 , C.translate c Lang.Section_Syntax
 125                 , "  "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++
 126                                      " ["++C.translate c Lang.Type_File_Journal++"] [...]"
 127                 , ""
 128                 , usageInfo (C.translate c Lang.Section_Options) (options c)
 129                 ]
 130
 131 options :: C.Context -> Args.Options Ctx
 132 options c =
 133         [ Option "b" ["filter-balance"]
 134          (ReqArg (\s ctx -> do
 135                 ctx_filter_balance <-
 136                         liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
 137                                 liftIO $ Filter.Read.read Filter.Read.filter_balance s
 138                                 >>= \f -> case f of
 139                                  Left  ko -> Write.fatal c ko
 140                                  Right ok -> return ok
 141                 return $ ctx{ctx_filter_balance}) $
 142                 C.translate c Lang.Type_Filter_Balance) $
 143                 C.translate c Lang.Help_Option_Filter_Balance
 144         , Option "p" ["filter-posting"]
 145          (ReqArg (\s ctx -> do
 146                 ctx_filter_posting <-
 147                         liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
 148                         liftIO $ Filter.Read.read Filter.Read.filter_posting s
 149                         >>= \f -> case f of
 150                          Left  ko -> Write.fatal c ko
 151                          Right ok -> return ok
 152                 return $ ctx{ctx_filter_posting}) $
 153                 C.translate c Lang.Type_Filter_Posting) $
 154                 C.translate c Lang.Help_Option_Filter_Posting
 155         , Option "t" ["filter-transaction"]
 156          (ReqArg (\s ctx -> do
 157                 ctx_filter_transaction <-
 158                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 159                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 160                         >>= \f -> case f of
 161                          Left  ko -> Write.fatal c ko
 162                          Right ok -> return ok
 163                 return $ ctx{ctx_filter_transaction}) $
 164                 C.translate c Lang.Type_Filter_Transaction) $
 165                 C.translate c Lang.Help_Option_Filter_Transaction
 166         , Option "h" ["help"]
 167          (NoArg (\_ctx -> do
 168                 usage c >>= IO.hPutStr IO.stderr
 169                 exitSuccess)) $
 170                 C.translate c Lang.Help_Option_Help
 171         , Option "i" ["input"]
 172          (ReqArg (\s ctx -> do
 173                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 174                 C.translate c Lang.Type_File_Journal) $
 175                 C.translate c Lang.Help_Option_Input
 176         , Option "o" ["output"]
 177          (ReqArg (\s ctx -> do
 178                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
 179                 C.translate c Lang.Type_File) $
 180                 C.translate c Lang.Help_Option_Output
 181         , Option "O" ["overwrite"]
 182          (ReqArg (\s ctx -> do
 183                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 184                 C.translate c Lang.Type_File) $
 185                 C.translate c Lang.Help_Option_Overwrite
 186         {- NOTE: not used so far.
 187         , Option "" ["reduce-date"]
 188          (OptArg (\arg ctx -> do
 189                 ctx_reduce_date <- case arg of
 190                  Nothing    -> return $ True
 191                  Just "yes" -> return $ True
 192                  Just "no"  -> return $ False
 193                  Just _     -> Write.fatal c $
 194                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 195                 return $ ctx{ctx_reduce_date})
 196           "[yes|no]")
 197          "use advanced date reducer to speed up filtering"
 198         -}
 199         , Option "" ["redundant"]
 200          (OptArg (\arg ctx -> do
 201                 ctx_redundant <- case arg of
 202                  Nothing    -> return $ True
 203                  Just "yes" -> return $ True
 204                  Just "no"  -> return $ False
 205                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Redundant
 206                 return $ ctx{ctx_redundant})
 207           "[no|yes]") $
 208                 C.translate c Lang.Help_Option_Balance_Redundant
 209         , Option "" ["heritage"]
 210          (OptArg (\arg ctx -> do
 211                 ctx_heritage <- case arg of
 212                  Nothing    -> return $ True
 213                  Just "yes" -> return $ True
 214                  Just "no"  -> return $ False
 215                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Heritage
 216                 return $ ctx{ctx_heritage})
 217           "[yes|no]") $
 218                 C.translate c Lang.Help_Option_Balance_Heritage
 219         , Option "" ["total"]
 220          (OptArg (\arg ctx -> do
 221                 ctx_total_by_unit <- case arg of
 222                  Nothing    -> return $ True
 223                  Just "yes" -> return $ True
 224                  Just "no"  -> return $ False
 225                  Just _     -> Write.fatal c Lang.Error_Option_Balance_Total
 226                 return $ ctx{ctx_total_by_unit})
 227           "[yes|no]") $
 228                 C.translate c Lang.Help_Option_Balance_Total
 229         , Option "f" ["format"]
 230          (ReqArg (\arg ctx -> do
 231                 ctx_format_output <- case arg of
 232                  "table" -> return $ Format_Output_Table
 233                  "open"  -> return $ Format_Output_Transaction Lang.Exercise_Opening
 234                  "close" -> return $ Format_Output_Transaction Lang.Exercise_Closing
 235                  _       -> Write.fatal c Lang.Error_Option_Balance_Format
 236                 return $ ctx{ctx_format_output})
 237           "[table|close|open]") $
 238                 C.translate c Lang.Help_Option_Balance_Format
 239         , Option "" ["eq"]
 240          (ReqArg (\arg ctx -> do
 241                 ctx_account_equilibrium <-
 242                         fmap (\e -> (e, e)) $
 243                         case Text.Parsec.runParser
 244                                  (Account.Read.account <* Text.Parsec.eof)
 245                                  () "" arg of
 246                          Right acct -> return acct
 247                          _          -> Write.fatal c Lang.Error_Option_Equilibrium
 248                 return $ ctx{ctx_account_equilibrium}) $
 249                 C.translate c Lang.Type_Account) $
 250                 C.translate c Lang.Help_Option_Equilibrium
 251         , Option "" ["eq-credit"]
 252          (ReqArg (\arg ctx -> do
 253                 ctx_account_equilibrium <-
 254                         fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
 255                         case Text.Parsec.runParser
 256                                  (Account.Read.account <* Text.Parsec.eof)
 257                                  () "" arg of
 258                          Right acct -> return acct
 259                          _          -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
 260                 return $ ctx{ctx_account_equilibrium}) $
 261                 C.translate c Lang.Type_Account) $
 262                 C.translate c Lang.Help_Option_Equilibrium_Credit
 263         , Option "" ["eq-debit"]
 264          (ReqArg (\arg ctx -> do
 265                 ctx_account_equilibrium <-
 266                         fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
 267                         case Text.Parsec.runParser
 268                                  (Account.Read.account <* Text.Parsec.eof)
 269                                  () "" arg of
 270                          Right acct -> return acct
 271                          _          -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
 272                 return $ ctx{ctx_account_equilibrium}) $
 273                 C.translate c Lang.Type_Account) $
 274                 C.translate c Lang.Help_Option_Equilibrium_Debit
 275         ]
 276
 277 run :: C.Context -> [String] -> IO ()
 278 run c args = do
 279         (ctx, inputs) <-
 280                 first (\x ->
 281                         case ctx_output x of
 282                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 283                          _  -> x) <$>
 284                 Args.parse c usage options (nil c, args)
 285         read_journals <-
 286                 liftM Data.Either.partitionEithers $ do
 287                 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
 288                 >>= do
 289                         mapM $ \path -> do
 290                                 liftIO $ runExceptT $ Ledger.Read.file
 291                                  (Ledger.Read.context ( ctx_filter_transaction ctx
 292                                                       , ctx_filter_posting     ctx )
 293                                                       Ledger.journal)
 294                                  path
 295                                 >>= \x -> case x of
 296                                  Left  ko -> return $ Left (path, ko)
 297                                  Right ok -> return $ Right ok
 298         case read_journals of
 299          (errs@(_:_), _journals) ->
 300                 forM_ errs $ \(_path, err) -> do
 301                         Write.fatal c $ err
 302          ([], journals) -> do
 303                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 304                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 305                 Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 306                 let lang = C.lang c
 307                 case ctx_format_output ctx of
 308                  Format_Output_Transaction oc -> do
 309                         now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now
 310                         let sty = Write.style
 311                                  { Write.style_pretty = True -- ctx_align ctx
 312                                  }
 313                         Write.write c sty (ctx_output ctx) $ do
 314                         Ledger.Write.transactions $ do
 315                                 let (chart, bal) = ledger_balance_by_account ctx journals
 316                                 let balance_by_account = ledger_balance_by_account_filter ctx (chart, bal)
 317                                 let Balance.Balance_by_Unit balance_by_unit =
 318                                         ledger_balance_by_unit ctx balance_by_account
 319                                 let equilibrium_postings =
 320                                         Data.Map.foldlWithKey
 321                                          (\acc unit bu ->
 322                                                 let amt =
 323                                                         (case oc of
 324                                                          Lang.Exercise_Closing -> id
 325                                                          Lang.Exercise_Opening -> negate) $
 326                                                         Amount.sum_balance $
 327                                                         Balance.unit_sum_amount bu in
 328                                                 case Amount.sign amt of
 329                                                  LT ->
 330                                                         (Ledger.posting $ snd $ ctx_account_equilibrium ctx)
 331                                                          { Ledger.posting_amounts  = Data.Map.singleton unit amt
 332                                                          , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]
 333                                                          }:acc
 334                                                  EQ -> acc
 335                                                  GT ->
 336                                                         (Ledger.posting $ fst $ ctx_account_equilibrium ctx)
 337                                                          { Ledger.posting_amounts  = Data.Map.singleton unit amt
 338                                                          , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]
 339                                                          }:acc
 340                                          )
 341                                          mempty
 342                                          balance_by_unit
 343                                 [Ledger.transaction
 344                                  { Ledger.transaction_description=
 345                                         Lang.translate lang (Lang.Description_Exercise oc)
 346                                  , Ledger.transaction_dates=(now, [])
 347                                  , Ledger.transaction_postings=
 348                                         Data.Map.unionWith mappend
 349                                          (Ledger.posting_by_Account equilibrium_postings)
 350                                          (TreeMap.flatten_with_Path
 351                                                  (\posting_account (Balance.Account_Sum amount_by_unit) ->
 352                                                         [(Ledger.posting posting_account)
 353                                                          { Ledger.posting_amounts =
 354                                                                 flip fmap amount_by_unit $
 355                                                                         (case oc of
 356                                                                          Lang.Exercise_Closing -> negate
 357                                                                          Lang.Exercise_Opening -> id)
 358                                                                         . Amount.sum_balance
 359                                                          }
 360                                                         ]
 361                                                  )
 362                                                  balance_by_account
 363                                          )
 364                                  }]
 365                  Format_Output_Table -> do
 366                         let ( table_balance_by_account
 367                                   , Balance.Balance_by_Unit balance_by_unit
 368                                   ) =
 369                                 let (ch, bal) = ledger_balance_by_account ctx journals in
 370                                 if ctx_heritage ctx
 371                                 then
 372                                         let balance_filtered = ledger_balance_by_account_expanded ctx ch bal in
 373                                         ( table_by_account ctx Balance.inclusive balance_filtered
 374                                         , ledger_balance_by_unit_expanded ctx    balance_filtered
 375                                         )
 376                                 else
 377                                         let balance_filtered = ledger_balance_by_account_filter ctx (ch, bal) in
 378                                         ( table_by_account       ctx id balance_filtered
 379                                         , ledger_balance_by_unit ctx    balance_filtered
 380                                         )
 381                         let sty = Write.style { Write.style_pretty = True }
 382                         Write.write c sty (ctx_output ctx) $ do
 383                         toDoc () $ do
 384                         zipWith id
 385                          [ Table.column (Lang.translate lang Lang.Title_Debit)   Table.Align_Right
 386                          , Table.column (Lang.translate lang Lang.Title_Credit)  Table.Align_Right
 387                          , Table.column (Lang.translate lang Lang.Title_Balance) Table.Align_Right
 388                          , Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left
 389                          ] $ do
 390                                 table_balance_by_account $ do
 391                                 case ctx_total_by_unit ctx of
 392                                  False -> repeat []
 393                                  True -> do
 394                                         zipWith (:)
 395                                          [ Table.Cell_Line '=' 0
 396                                          , Table.Cell_Line '=' 0
 397                                          , Table.Cell_Line '=' 0
 398                                          , Table.Cell_Line ' ' 0
 399                                          ] $ do
 400                                         flip table_by_unit (repeat []) $
 401                                                 Data.Map.map
 402                                                  Balance.unit_sum_amount
 403                                                  balance_by_unit
 404
 405 ledger_balance_by_account
 406  :: Ctx
 407  -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount))
 408                             (Chart, Ledger.Transaction)) ]
 409  -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount))
 410 ledger_balance_by_account _ctx =
 411         Data.Foldable.foldl'
 412          (flip (\j ->
 413                 flip mappend $
 414                 (Ledger.journal_chart j,) $
 415                 Ledger.Journal.fold
 416                  (\Ledger.Journal
 417                          { Ledger.journal_sections=Const b
 418                          } -> mappend b
 419                  ) j mempty
 420          ))
 421          mempty
 422
 423 ledger_balance_by_account_filter
 424  :: Ctx
 425  -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount))
 426  -> Balance.Balance_by_Account (Amount.Sum Amount)
 427 ledger_balance_by_account_filter ctx (chart, balance) =
 428         case Filter.simplified $ ctx_filter_balance ctx of
 429          Right True ->
 430                 if ctx_redundant ctx
 431                 then balance
 432                 else TreeMap.filter_with_Path_and_Node (const . is_worth) balance
 433          Right False -> mempty
 434          Left flt ->
 435                 TreeMap.filter_with_Path_and_Node
 436                  (\node acct bal ->
 437                         (is_worth node bal &&) $
 438                         Data.Foldable.any
 439                          (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $
 440                         Balance.get_Account_Sum bal)
 441                  balance
 442         where
 443                 is_worth node bal =
 444                         let _descendants = TreeMap.nodes
 445                                  (TreeMap.node_descendants node) in
 446                         ctx_redundant ctx
 447                         -- NOTE: worth if no descendant
 448                         -- but Account's exclusive
 449                         -- has at least a non-zero Amount
 450                         || Data.Foldable.any
 451                                  (not . Amount.is_zero . Amount.sum_balance)
 452                                  (Balance.get_Account_Sum bal)
 453
 454 ledger_balance_by_account_expanded
 455  :: Ctx
 456  -> Chart
 457  -> Balance.Balance_by_Account (Amount.Sum Amount)
 458  -> Balance.Expanded           (Amount.Sum Amount)
 459 ledger_balance_by_account_expanded ctx chart =
 460         case Filter.simplified $ ctx_filter_balance ctx of
 461          Right True  ->
 462                 if ctx_redundant ctx
 463                 then id
 464                 else TreeMap.filter_with_Path_and_Node (const . is_worth)
 465          Right False -> const mempty
 466          Left flt ->
 467                 TreeMap.filter_with_Path_and_Node
 468                  (\node acct bal ->
 469                         (is_worth node bal &&) $
 470                         Data.Foldable.any
 471                          (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $
 472                                 Balance.get_Account_Sum $
 473                                 Balance.inclusive bal)
 474         . Balance.expanded
 475         where
 476                 is_worth node bal =
 477                         let descendants = TreeMap.nodes
 478                                  (TreeMap.node_descendants node) in
 479                         ctx_redundant ctx
 480                         -- NOTE: worth if no descendant
 481                         -- but Account's inclusive
 482                         -- has at least a non-zero Amount
 483                         || (Data.Map.null descendants
 484                                  && Data.Foldable.any
 485                                          (not . Amount.is_zero . Amount.sum_balance)
 486                                          (Balance.get_Account_Sum $ Balance.inclusive bal))
 487                         -- NOTE: worth if Account's exclusive
 488                         -- has at least a non-zero Amount
 489                         || (Data.Foldable.any
 490                                  (not . Amount.is_zero . Amount.sum_balance)
 491                                  (Balance.get_Account_Sum $ Balance.exclusive bal))
 492                         -- NOTE: worth if Account has at least more than
 493                         -- one descendant Account whose inclusive
 494                         -- has at least a non-zero Amount
 495                         || Data.Map.size
 496                                  ( Data.Map.filter
 497                                          ( Strict.maybe False
 498                                                  ( Data.Foldable.any
 499                                                          (not . Amount.is_zero . Amount.sum_balance)
 500                                                  . Balance.get_Account_Sum
 501                                                  . Balance.inclusive )
 502                                          . TreeMap.node_value )
 503                                          descendants
 504                                  ) > 1
 505
 506 ledger_balance_by_unit
 507  :: Ctx
 508  -> Balance.Balance_by_Account (Amount.Sum Amount)
 509  -> Balance.Balance_by_Unit    (Amount.Sum Amount)
 510 ledger_balance_by_unit _ctx =
 511         flip Balance.by_unit_of_by_account mempty
 512
 513 ledger_balance_by_unit_expanded
 514  :: Ctx
 515  -> Balance.Expanded        (Amount.Sum Amount)
 516  -> Balance.Balance_by_Unit (Amount.Sum Amount)
 517 ledger_balance_by_unit_expanded _ctx =
 518         flip Balance.by_unit_of_expanded mempty
 519
 520 table_by_account
 521  :: Ctx
 522  -> (amount -> Balance.Account_Sum (Amount.Sum Amount))
 523  -> TreeMap Account.Account_Section amount
 524  -> [[Table.Cell]]
 525  -> [[Table.Cell]]
 526 table_by_account _ctx get_Account_Sum =
 527         let posting_type = Posting.Posting_Type_Regular in
 528         flip $ TreeMap.foldr_with_Path
 529          (\account balance rows ->
 530                 foldr
 531                  (\(amount_positive, amount_negative, amount) ->
 532                         zipWith (:)
 533                                 [ Table.cell
 534                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 535                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 536                                  }
 537                                 , Table.cell
 538                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 539                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 540                                  }
 541                                 , Table.cell
 542                                  { Table.cell_content = Amount.Write.amount        $ amount
 543                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 544                                  }
 545                                 , Table.cell
 546                                  { Table.cell_content = Ledger.Write.account        posting_type account
 547                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 548                                  }
 549                                 ]
 550                  )
 551                  rows $
 552                 let bal = Balance.get_Account_Sum $ get_Account_Sum balance in
 553                 Data.Map.foldrWithKey
 554                  (\unit amount acc ->
 555                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 556                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 557                         , Amount.sum_balance amount
 558                         ) : acc
 559                  ) [] $ bal
 560          )
 561
 562 table_by_unit
 563  :: Data.Map.Map Unit (Amount.Sum Amount)
 564  -> [[Table.Cell]]
 565  -> [[Table.Cell]]
 566 table_by_unit =
 567         flip $ foldr
 568          (\amount_sum ->
 569                 zipWith (:)
 570                         [ let amt = Amount.sum_positive amount_sum in
 571                                 Table.cell
 572                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 573                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 574                                  }
 575                         , let amt = Amount.sum_negative amount_sum in
 576                                 Table.cell
 577                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 578                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 579                                  }
 580                         , let amt = Amount.sum_balance amount_sum in
 581                                 Table.cell
 582                                  { Table.cell_content = Amount.Write.amount        amt
 583                                  , Table.cell_width   = Amount.Write.amount_length amt
 584                                  }
 585                         , Table.cell
 586                                  { Table.cell_content = W.empty
 587                                  , Table.cell_width   = 0
 588                                  }
 589                         ]
 590          )