92 lines
3.3 KiB
Haskell
92 lines
3.3 KiB
Haskell
module AccountName
|
|
where
|
|
import Utils
|
|
import BasicTypes
|
|
|
|
-- AccountNames are strings like "assets:cash:petty"; from these we build
|
|
-- the chart of accounts, which should be a simple hierarchy.
|
|
type AccountName = String
|
|
|
|
accountNameComponents :: AccountName -> [String]
|
|
accountNameComponents = splitAtElement ':'
|
|
|
|
accountNameFromComponents :: [String] -> AccountName
|
|
accountNameFromComponents = concat . intersperse ":"
|
|
|
|
accountLeafName :: AccountName -> String
|
|
accountLeafName = last . accountNameComponents
|
|
|
|
accountNameLevel :: AccountName -> Int
|
|
accountNameLevel = length . accountNameComponents
|
|
|
|
-- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
|
|
expandAccountNames :: [AccountName] -> [AccountName]
|
|
expandAccountNames as = nub $ concat $ map expand as
|
|
where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as)
|
|
|
|
-- ["a:b:c","d:e"] -> ["a","d"]
|
|
topAccountNames :: [AccountName] -> [AccountName]
|
|
topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
|
|
|
|
parentAccountName :: AccountName -> AccountName
|
|
parentAccountName a = accountNameFromComponents $ init $ 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))
|
|
|
|
subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
|
|
subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
|
|
|
|
matchAccountName :: String -> AccountName -> Bool
|
|
matchAccountName s a =
|
|
case matchRegex (mkRegex s) a of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
|
|
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
|
|
-- structures to eg display the account tree with boring accounts elided.
|
|
-- first, here is a tree of AccountNames; Account and Account tree are
|
|
-- defined later.
|
|
|
|
accountNameTreeFrom_props =
|
|
[
|
|
accountNameTreeFrom ["a"] == Node "top" [Node "a" []],
|
|
accountNameTreeFrom ["a","b"] == Node "top" [Node "a" [], Node "b" []],
|
|
accountNameTreeFrom ["a","a:b"] == Node "top" [Node "a" [Node "a:b" []]],
|
|
accountNameTreeFrom ["a:b"] == Node "top" [Node "a" [Node "a:b" []]]
|
|
]
|
|
accountNameTreeFrom :: [AccountName] -> Tree AccountName
|
|
accountNameTreeFrom accts =
|
|
Node "top" (accountsFrom (topAccountNames accts))
|
|
where
|
|
accountsFrom :: [AccountName] -> [Tree AccountName]
|
|
accountsFrom [] = []
|
|
accountsFrom as = [Node a (accountsFrom $ subs a) | a <- as]
|
|
subs = (subAccountNamesFrom accts)
|
|
|
|
showAccountNameTree :: Tree AccountName -> String
|
|
showAccountNameTree t =
|
|
topacct ++ "\n" ++ concatMap showAccountNameTree (branches t)
|
|
where
|
|
topacct = indentAccountName 0 $ root t
|
|
|
|
filterAccountNameTree :: [String] -> Tree AccountName -> Tree AccountName
|
|
filterAccountNameTree pats =
|
|
treefilter matchany
|
|
where
|
|
matchany a = any (match a) pats
|
|
match a pat = matchAccountName pat $ accountLeafName a
|
|
|