switch to Data.Tree

This commit is contained in:
Simon Michael 2007-03-10 03:16:19 +00:00
parent 93fa427e08
commit 8236f3f988
4 changed files with 20 additions and 29 deletions

View File

@ -43,13 +43,11 @@ aggregateTransactionsInAccountNamed l a =
-- a tree of Accounts -- a tree of Accounts
atacct = fst . node
addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
addDataToAccountNameTree l ant = addDataToAccountNameTree l ant =
Tree (mkAccount l aname, map (addDataToAccountNameTree l) (branches ant)) Node
where (mkAccount l $ rootLabel ant)
aname = antacctname ant (map (addDataToAccountNameTree l) $ subForest ant)
-- would be straightforward except we want to elide boring accounts when -- would be straightforward except we want to elide boring accounts when
-- displaying account trees: -- displaying account trees:
@ -74,24 +72,24 @@ showAccountTree l maxdepth indentlevel t
where where
boringacct = isBoringAccount2 l name boringacct = isBoringAccount2 l name
boringparents = takeWhile (isBoringAccount2 l) $ parentAccountNames name boringparents = takeWhile (isBoringAccount2 l) $ parentAccountNames name
bal = printf "%20s" $ show $ abalance $ atacct t bal = printf "%20s" $ show $ abalance $ rootLabel t
indent = replicate (indentlevel * 2) ' ' indent = replicate (indentlevel * 2) ' '
parentnames = concatMap (++ ":") $ map accountLeafName boringparents parentnames = concatMap (++ ":") $ map accountLeafName boringparents
leafname = accountLeafName name leafname = accountLeafName name
name = aname $ atacct t name = aname $ rootLabel t
subacctsindented i = subacctsindented i =
case maxdepth > 1 of case maxdepth > 1 of
True -> concatMap (showAccountTree l (maxdepth-1) (indentlevel+i)) $ branches t True -> concatMap (showAccountTree l (maxdepth-1) (indentlevel+i)) $ subForest t
False -> "" False -> ""
isBoringAccount :: Tree Account -> Bool isBoringAccount :: Tree Account -> Bool
isBoringAccount at = isBoringAccount at =
(length txns == 0) && ((length subaccts) == 1) && (not $ name == "top") (length txns == 0) && ((length subaccts) == 1) && (not $ name == "top")
where where
a = atacct at a = rootLabel at
name = aname a name = aname a
txns = atransactions a txns = atransactions a
subaccts = branches at subaccts = subForest at
isBoringAccount2 :: Ledger -> AccountName -> Bool isBoringAccount2 :: Ledger -> AccountName -> Bool
isBoringAccount2 l a isBoringAccount2 l a
@ -113,4 +111,4 @@ ledgerAccountsMatching l acctpats = undefined
showLedgerAccounts :: Ledger -> Int -> String showLedgerAccounts :: Ledger -> Int -> String
showLedgerAccounts l maxdepth = showLedgerAccounts l maxdepth =
concatMap (showAccountTree l maxdepth 0) (branches (ledgerAccountTree l)) concatMap (showAccountTree l maxdepth 0) (subForest (ledgerAccountTree l))

View File

@ -1,4 +1,3 @@
module AccountName module AccountName
where where
import Utils import Utils
@ -62,27 +61,25 @@ indentAccountName indentcorrection a =
-- first, here is a tree of AccountNames; Account and Account tree are -- first, here is a tree of AccountNames; Account and Account tree are
-- defined later. -- defined later.
antacctname = fst . node
accountNameTreeFrom_props = accountNameTreeFrom_props =
[ [
accountNameTreeFrom ["a"] == Tree ("top", [Tree ("a",[])]), accountNameTreeFrom ["a"] == Node "top" [Node "a" []],
accountNameTreeFrom ["a","b"] == Tree ("top", [Tree ("a", []), Tree ("b", [])]), accountNameTreeFrom ["a","b"] == Node "top" [Node "a" [], Node "b" []],
accountNameTreeFrom ["a","a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])]), accountNameTreeFrom ["a","a:b"] == Node "top" [Node "a" [Node "a:b" []]],
accountNameTreeFrom ["a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])]) accountNameTreeFrom ["a:b"] == Node "top" [Node "a" [Node "a:b" []]]
] ]
accountNameTreeFrom :: [AccountName] -> Tree AccountName accountNameTreeFrom :: [AccountName] -> Tree AccountName
accountNameTreeFrom accts = accountNameTreeFrom accts =
Tree ("top", accountsFrom (topAccountNames accts)) Node "top" (accountsFrom (topAccountNames accts))
where where
accountsFrom :: [AccountName] -> [Tree AccountName] accountsFrom :: [AccountName] -> [Tree AccountName]
accountsFrom [] = [] accountsFrom [] = []
accountsFrom as = [Tree (a, accountsFrom $ subs a) | a <- as] accountsFrom as = [Node a (accountsFrom $ subs a) | a <- as]
subs = (subAccountNamesFrom accts) subs = (subAccountNamesFrom accts)
showAccountNameTree :: Tree AccountName -> String showAccountNameTree :: Tree AccountName -> String
showAccountNameTree t = showAccountNameTree t =
topacct ++ "\n" ++ concatMap showAccountNameTree (branches t) topacct ++ "\n" ++ concatMap showAccountNameTree (subForest t)
where where
topacct = indentAccountName 0 $ antacctname t topacct = indentAccountName 0 $ rootLabel t

View File

@ -1,16 +1,10 @@
module BasicTypes
module BasicTypes
where where
import Utils import Utils
type Date = String type Date = String
-- generic tree. each node is a tuple of the node type and a
-- list of subtrees
newtype Tree a = Tree { node :: (a, [Tree a]) } deriving (Show,Eq)
branches = snd . node
-- amounts -- amounts
{- a simple amount is a currency, quantity pair: {- a simple amount is a currency, quantity pair:
0 0

View File

@ -1,6 +1,7 @@
module Utils ( module Utils (
module Utils, module Utils,
module Data.List, module Data.List,
module Data.Tree,
module Debug.Trace, module Debug.Trace,
module Text.Printf, module Text.Printf,
module Text.Regex, module Text.Regex,
@ -9,6 +10,7 @@ module Utils (
where where
import System.Directory import System.Directory
import Data.List import Data.List
import Data.Tree
import Debug.Trace import Debug.Trace
import Test.QuickCheck (quickCheck) import Test.QuickCheck (quickCheck)
import Text.Printf import Text.Printf