From 83d36dae63a9c5c3ca6ef3a71a59acc8511e032d Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sat, 22 Nov 2008 04:44:12 +0000 Subject: [PATCH] more tests cleanup, and start to move match functions to Utils --- Ledger/RawLedger.hs | 13 ++++--- Tests.hs | 82 +++++++++++++++++++++------------------------ Utils.hs | 50 +++++++++++++++++++++++++++ 3 files changed, 95 insertions(+), 50 deletions(-) diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs index 800182006..a41fb0018 100644 --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -86,14 +86,13 @@ filterRawLedgerTransactionsByRealness True (RawLedger ms ps es f) = where filtertxns e@Entry{etransactions=ts} = e{etransactions=filter isReal ts} -- | Check if a set of ledger account/description patterns matches the --- given account name or entry description, applying ledger's special --- cases. +-- given account name or entry description. Patterns are case-insensitive +-- regular expression strings; those beginning with - are anti-patterns. -- --- Patterns are case-insensitive regular expression strings, and those --- beginning with - are negative patterns. The special case is that --- account patterns match the full account name except in balance reports --- when the pattern does not contain : and is a positive pattern, where it --- matches only the leaf name. +-- 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. matchLedgerPatterns :: Bool -> [String] -> String -> Bool matchLedgerPatterns forbalancereport pats str = (null positives || any ismatch positives) && (null negatives || not (any ismatch negatives)) diff --git a/Tests.hs b/Tests.hs index 219025a65..fa09e1380 100644 --- a/Tests.hs +++ b/Tests.hs @@ -18,38 +18,12 @@ runtests args = do tests = [unittests, functests] deeptests = tfilter matchname $ TestList tests flattests = TestList $ filter matchname $ concatMap tflatten tests - matchname = Tests.matchpats args . tname + matchname = matchpats args . tname n = length ts where (TestList ts) = flattests s | null args = "" | otherwise = printf " matching %s" (intercalate ", " $ map (printf "\"%s\"") args) -matchpats pats str = (null positives || any match positives) && (null negatives || not (any match negatives)) - where - (negatives,positives) = partition isnegative pats - isnegative = (== [Ledger.negativepatternchar]) . take 1 - match "" = True - match pat = containsRegex (mkRegexWithOpts pat' True True) str - where - pat' = if isnegative pat then drop 1 pat else pat - --- | Get a Test's label, or the empty string. -tname :: Test -> String -tname (TestLabel n _) = n -tname _ = "" - --- | Flatten a Test containing TestLists into a list of single tests. -tflatten :: Test -> [Test] -tflatten (TestLabel _ t@(TestList _)) = tflatten t -tflatten (TestList ts) = concatMap tflatten ts -tflatten t = [t] - --- | Filter any TestLists in a Test, recursively, preserving the structure. -tfilter :: (Test -> Bool) -> Test -> Test -tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts -tfilter p (TestLabel l t) = TestLabel l (tfilter p t) -tfilter _ t = t - ------------------------------------------------------------------------------ unittests = TestList [ @@ -108,18 +82,16 @@ unittests = TestList [ , "setAmountDisplayPrefs" ~: do let l = setAmountDisplayPrefs $ rawLedgerWithAmounts ["1","2.00"] - -- should be using the greatest precision everywhere - assertequal [2,2] (rawLedgerPrecisions l) + assertequal [2,2] (rawLedgerPrecisions l) -- use greatest precision everywhere - ] - -rawLedgerWithAmounts as = - RawLedger - [] - [] - [nullentry{etransactions=[nullrawtxn{tamount=parse a}]} | a <- as] - "" - where parse = fromparse . parsewith transactionamount . (" "++) + ] where + rawLedgerWithAmounts as = + RawLedger + [] + [] + [nullentry{etransactions=[nullrawtxn{tamount=parse a}]} | a <- as] + "" + where parse = fromparse . parsewith transactionamount . (" "++) ------------------------------------------------------------------------------ @@ -248,12 +220,8 @@ registercommandtests = TestList [ $ showRegisterReport [] [] l ] --- | Assert a parsed thing equals some expected thing, or print a parse error. -assertparseequal :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion -assertparseequal expected parsed = either printParseError (assertequal expected) parsed - ------------------------------------------------------------------------------ --- data +-- test data rawtransaction1_str = " expenses:food:dining $10.00\n" @@ -560,3 +528,31 @@ timelog1 = TimeLog [ timelogentry2 ] +------------------------------------------------------------------------------ +-- test utils + +-- | Get a Test's label, or the empty string. +tname :: Test -> String +tname (TestLabel n _) = n +tname _ = "" + +-- | Flatten a Test containing TestLists into a list of single tests. +tflatten :: Test -> [Test] +tflatten (TestLabel _ t@(TestList _)) = tflatten t +tflatten (TestList ts) = concatMap tflatten ts +tflatten t = [t] + +-- | Filter TestLists in a Test, recursively, preserving the structure. +tfilter :: (Test -> Bool) -> Test -> Test +tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts) +tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts +tfilter _ t = t + +-- | Combine a list of TestLists into one. +tlistconcat :: [Test] -> Test +tlistconcat = foldr (\(TestList as) (TestList bs) -> TestList (as ++ bs)) (TestList []) + +-- | Assert a parsed thing equals some expected thing, or print a parse error. +assertparseequal :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion +assertparseequal expected parsed = either printParseError (assertequal expected) parsed + diff --git a/Utils.hs b/Utils.hs index 517b45541..70cbd14d3 100644 --- a/Utils.hs +++ b/Utils.hs @@ -41,3 +41,53 @@ myledger = do myaccount :: AccountName -> IO Account myaccount a = myledger >>= (return . fromMaybe nullacct . Map.lookup a . accountmap) +-- | 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 + +matchregex pat str = containsRegex (mkRegexWithOpts pat True True) str +isnegativepat pat = (== [Ledger.negativepatternchar]) $ take 1 pat +abspat pat = if isnegativepat pat then drop 1 pat else pat +positivepats = filter (not . isnegativepat) +negativepats = filter isnegativepat