module Ledger.AccountName
where
import Ledger.Utils
import Ledger.Types
sepchar = ':'
accountNameComponents :: AccountName -> [String]
accountNameComponents = splitAtElement sepchar
accountNameFromComponents :: [String] -> AccountName
accountNameFromComponents = concat . intersperse [sepchar]
accountLeafName :: AccountName -> String
accountLeafName = last . accountNameComponents
accountNameLevel :: AccountName -> Int
accountNameLevel "" = 0
accountNameLevel a = (length $ filter (==sepchar) a) + 1
expandAccountNames :: [AccountName] -> [AccountName]
expandAccountNames as = nub $ concat $ map expand as
where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as)
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)
isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
p `isAccountNamePrefixOf` s = ((p ++ [sepchar]) `isPrefixOf` s)
isSubAccountNameOf :: AccountName -> AccountName -> Bool
s `isSubAccountNameOf` p =
(p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
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)
elideAccountName :: Int -> AccountName -> AccountName
elideAccountName width s =
elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
where
elideparts :: Int -> [String] -> [String] -> [String]
elideparts width done ss
| (length $ accountNameFromComponents $ done++ss) <= width = done++ss
| length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)
| otherwise = done++ss
matchpats :: [String] -> String -> Bool
matchpats pats str =
(null positives || any match positives) && (null negatives || not (any match negatives))
where
(negatives,positives) = partition isnegativepat pats
match "" = True
match pat = matchregex (abspat pat) str
matchpats_balance :: [String] -> String -> Bool
matchpats_balance pats str = match_positive_pats pats str && (not $ match_negative_pats pats str)
match_positive_pats :: [String] -> String -> Bool
match_positive_pats pats str = (null ps) || (any match ps)
where
ps = positivepats pats
match "" = True
match p = matchregex (abspat p) matchee
where
matchee | ':' `elem` p = str
| otherwise = accountLeafName str
match_negative_pats :: [String] -> String -> Bool
match_negative_pats pats str = (not $ null ns) && (any match ns)
where
ns = map abspat $ negativepats pats
match "" = True
match p = matchregex (abspat p) str
negativepatternchar = '-'
isnegativepat pat = (== [negativepatternchar]) $ take 1 pat
abspat pat = if isnegativepat pat then drop 1 pat else pat
positivepats = filter (not . isnegativepat)
negativepats = filter isnegativepat
matchregex pat str = containsRegex (mkRegexWithOpts pat True True) str