177 lines
7.3 KiB
Haskell
177 lines
7.3 KiB
Haskell
{-|
|
|
|
|
'AccountName's are strings like @assets:cash:petty@.
|
|
From a set of these we derive the account hierarchy.
|
|
|
|
-}
|
|
|
|
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
|
|
|
|
-- | ["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)
|
|
|
|
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
|
|
|
|
-- | We could almost get by with just the AccountName manipulations
|
|
-- above, but we need smarter structures to eg display the account
|
|
-- tree with boring accounts elided. This converts a list of
|
|
-- AccountName to a tree (later we will convert that to a tree of
|
|
-- 'Account'.)
|
|
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)
|
|
|
|
-- | Elide an account name to fit in the specified width.
|
|
-- From the ledger 2.6 news:
|
|
--
|
|
-- @
|
|
-- What Ledger now does is that if an account name is too long, it will
|
|
-- start abbreviating the first parts of the account name down to two
|
|
-- letters in length. If this results in a string that is still too
|
|
-- long, the front will be elided -- not the end. For example:
|
|
--
|
|
-- Expenses:Cash ; OK, not too long
|
|
-- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit
|
|
-- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated
|
|
-- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash
|
|
-- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided!
|
|
-- @
|
|
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
|
|
|
|
|
|
-- -- | Check if a set of ledger account/description patterns matches the
|
|
-- -- given account name or entry description. Patterns are case-insensitive
|
|
-- -- regular expression strings; those beginning with - are anti-patterns.
|
|
-- --
|
|
-- -- Call with forbalancereport=True to mimic ledger's balance report
|
|
-- -- matching. Account patterns usually match the full account name, but in
|
|
-- -- balance reports when the pattern does not contain : and is not an
|
|
-- -- anti-pattern, it matches only the leaf name.
|
|
-- matchpats :: Bool -> [String] -> String -> Bool
|
|
-- matchpats forbalancereport pats str =
|
|
-- (null positives || any ismatch positives) && (null negatives || not (any ismatch negatives))
|
|
-- where
|
|
-- isnegative = (== negativepatternchar) . head
|
|
-- (negatives,positives) = partition isnegative pats
|
|
-- ismatch pat = containsRegex (mkRegexWithOpts pat' True True) matchee
|
|
-- where
|
|
-- pat' = if isnegative pat then drop 1 pat else pat
|
|
-- matchee = if forbalancereport && not (':' `elem` pat) && not (isnegative pat)
|
|
-- then accountLeafName str
|
|
-- else str
|
|
|
|
-- | Check if a set of ledger account/description patterns matches the
|
|
-- given account name or entry description. Patterns are case-insensitive
|
|
-- regular expression strings; those beginning with - are anti-patterns.
|
|
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
|
|
|
|
-- | Similar to matchpats, but follows the special behaviour of ledger
|
|
-- 2.6's balance command: positive patterns which do not contain : match
|
|
-- the account leaf name, other patterns match the full account name.
|
|
matchpats_balance :: [String] -> String -> Bool
|
|
matchpats_balance pats str = match_positive_pats pats str && (not $ match_negative_pats 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) matchee
|
|
-- where
|
|
-- matchee = if not (':' `elem` pat) && not (isnegativepat pat)
|
|
-- then accountLeafName str
|
|
-- else str
|
|
|
|
-- | Do the positives in these patterns permit a match for this string ?
|
|
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
|
|
|
|
-- | Do the negatives in these patterns prevent a match for this string ?
|
|
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
|
|
|