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