elide boring accounts in balance report, like ledger

Account.hs

@@ -47,52 +47,66 @@ addDataToAccountNameTree l ant =
         where 
           aname = antacctname ant
 
-showAccountTreeWithBalances :: Ledger -> Int -> Tree Account -> String
-showAccountTreeWithBalances l depth at = (showAccountTreesWithBalances l depth) (branches at)
-
-showAccountTreesWithBalances :: Ledger -> Int -> [Tree Account] -> String
-showAccountTreesWithBalances _ 0 _ = ""
-showAccountTreesWithBalances l depth ats =
-    concatMap showAccountBranch ats
-        where
-          showAccountBranch :: Tree Account -> String
-          showAccountBranch at = 
-              topacct ++ "\n" ++ subaccts
---               case boring of
---                 True  -> 
---                 False -> 
-              where
-                topacct = (showAmount bal) ++ "  " ++ (indentAccountName name)
-                showAmount amt = printf "%20s" (show amt)
-                name = aname $ atacct at
-                txns = atransactions $ atacct at
-                bal = abalance $ atacct at
-                subaccts = (showAccountTreesWithBalances l (depth - 1)) $ branches at
-                boring = (length txns == 0) && ((length subaccts) == 1)
-
--- we want to elide boring accounts in the account tree
---
--- a (2 txns)
---   b (boring acct - 0 txns, exactly 1 sub)
---     c (5 txns)
+-- would be straightforward except we want to elide boring accounts when
+-- displaying account trees:
+-- a (0 txns, only 1 subacct)
+--   b (another boring acct.)
+--     c
 --       d
--- to:
--- a (2 txns)
---   b:c (5 txns)
---     d
+-- becomes:
+-- a:b:c
+--   d
+showAccountTree :: Ledger -> Int -> Int -> Tree Account -> String
+showAccountTree _ 0 _ _ = ""
+showAccountTree l maxdepth indentlevel t
+    -- if this acct is boring, don't show it (unless this is as deep as we're going)
+    | (boringacct && (maxdepth > 1)) = subacctsindented 0
 
--- elideAccountTree at = at
+    -- otherwise show normal indented account name with balance
+    -- if this acct has one or more boring parents, prepend their names
+    | otherwise = 
+        bal ++ "  " ++ indent ++ parentnames ++ leafname ++ "\n" ++ (subacctsindented 1)
 
-elideAccountTree :: Tree Account -> Tree Account
-elideAccountTree = id
+    where
+      boringacct = isBoringAccount2 l name
+      boringparents = takeWhile (isBoringAccount2 l) $ parentAccountNames name
+      bal = printf "%20s" $ show $ abalance $ atacct t
+      indent = replicate (indentlevel * 2) ' '
+      parentnames = concatMap (++ ":") $ map accountLeafName boringparents
+      leafname = accountLeafName name
+      name = aname $ atacct t
+      subacctsindented i = 
+          case maxdepth > 1 of
+            True -> concatMap (showAccountTree l (maxdepth-1) (indentlevel+i)) $ branches t
+            False -> ""
+
+isBoringAccount :: Tree Account -> Bool
+isBoringAccount at = 
+    (length txns == 0) && ((length subaccts) == 1) && (not $ name == "top")
+        where
+          a = atacct at
+          name = aname a
+          txns = atransactions a
+          subaccts = branches at
+
+isBoringAccount2 :: Ledger -> AccountName -> Bool
+isBoringAccount2 l a
+    | a == "top" = False
+    | (length txns == 0) && ((length subs) == 1) = True
+    | otherwise = False
+    where
+      txns = transactionsInAccountNamed l a
+      subs = subAccountNamesFrom (ledgerAccountNames l) a
 
 ledgerAccountTree :: Ledger -> Tree Account
-ledgerAccountTree l = elideAccountTree $ addDataToAccountNameTree l (ledgerAccountNameTree l)
+ledgerAccountTree l = addDataToAccountNameTree l (ledgerAccountNameTree l)
+
+-- ledgerAccountTreeForAccount :: Ledger -> AccountName -> Tree Account
+-- ledgerAccountTreeForAccount l a = addDataToAccountNameTree l (ledgerAccountNameTree l)
 
 ledgerAccountsMatching :: Ledger -> [String] -> [Account]
 ledgerAccountsMatching l acctpats = undefined
 
 showLedgerAccounts :: Ledger -> Int -> String
-showLedgerAccounts l depth = 
-    showAccountTreeWithBalances l depth (ledgerAccountTree l)
-
+showLedgerAccounts l maxdepth = 
+    concatMap (showAccountTree l maxdepth 0) (branches (ledgerAccountTree l))

AccountName.hs

@@ -29,11 +29,15 @@ expandAccountNames as = nub $ concat $ map expand as
 topAccountNames :: [AccountName] -> [AccountName]
 topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
 
-parentAccountName :: AccountName -> Maybe AccountName
+parentAccountName :: AccountName -> AccountName
 parentAccountName a = 
-    case accountNameLevel a > 1 of
-      True -> Just $ accountNameFromComponents $ rtail $ accountNameComponents a
-      False -> Nothing
+    accountNameFromComponents $ rtail $ accountNameComponents a
+
+parentAccountNames :: AccountName -> [AccountName]
+parentAccountNames a = parentAccountNames' $ parentAccountName a
+    where
+      parentAccountNames' "" = []
+      parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a)
 
 s `isSubAccountNameOf` p = 
     ((p ++ ":") `isPrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
@@ -47,8 +51,10 @@ matchAccountName s a =
       Nothing -> False
       otherwise -> True
 
-indentAccountName :: AccountName -> String
-indentAccountName a = replicate (((accountNameLevel a) - 1) * 2) ' ' ++ (accountLeafName a)
+indentAccountName ::  Int -> AccountName -> String
+indentAccountName indentcorrection a = 
+    replicate (indentlevel * 2) ' ' ++ (accountLeafName a)
+    where indentlevel = ((accountNameLevel a) - 1) + indentcorrection
 
 
 -- We could almost get by with just the above, but we need smarter
@@ -75,14 +81,8 @@ accountNameTreeFrom accts =
           subs = (subAccountNamesFrom accts)
 
 showAccountNameTree :: Tree AccountName -> String
-showAccountNameTree at = showAccountNameTrees $ branches at
-
-showAccountNameTrees :: [Tree AccountName] -> String
-showAccountNameTrees ats =
-    concatMap showAccountNameBranch ats
+showAccountNameTree t =
+    topacct  ++ "\n" ++ concatMap showAccountNameTree (branches t)
         where
-          showAccountNameBranch at = topacct ++ "\n" ++ subaccts
-              where
-                topacct = indentAccountName $ antacctname at
-                subaccts = showAccountNameTrees $ branches at
+          topacct = indentAccountName 0 $ antacctname t
 

Ledger.hs

@@ -15,9 +15,9 @@ data Ledger = Ledger {
 
 instance Show Ledger where
     show l = printf "Ledger with %d normal, %d modifier, %d periodic entries"
-             (show $ length $ modifier_entries l)
-             (show $ length $ periodic_entries l)
-             (show $ length $ entries l)
+             (length $ modifier_entries l)
+             (length $ periodic_entries l)
+             (length $ entries l)
 
 ledgerTransactions :: Ledger -> [EntryTransaction]
 ledgerTransactions l = entryTransactionsFrom $ entries l

TODO

@@ -1,6 +1,4 @@
 basic features
- balance
-  elide boring accounts
  handle mixed amounts and currencies
  print
  entry

hledger.hs

@@ -4,7 +4,7 @@ hledger - ledger-compatible money management utilities (& haskell study)
 GPLv3, (c) Simon Michael & contributors, 
 John Wiegley's ledger is at http://newartisans.com/ledger.html
 
-The model/type/class hierarchy is roughly like this:
+modules/models are organized roughly like this:
 
 hledger
  Options
@@ -95,7 +95,7 @@ printBalance opts args ledger = do
 --                   False -> depthOption opts
   putStr $ case showsubs of
              True -> showLedgerAccounts ledger 999
-             False -> showLedgerAccounts ledger (getDepth opts)
+             False -> showLedgerAccounts ledger 1
       where 
         showsubs = (ShowSubs `elem` opts)
         (acctpats,_) = ledgerPatternArgs args