From 1654776f4ad0d2bebe126e0183c2be75073cb91c Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Mon, 14 May 2012 19:23:12 +0000
Subject: [PATCH] refactor test runner

---
 hledger-lib/Hledger/Utils.hs | 22 ++++++++++-----------
 hledger/Hledger/Cli/Main.hs  |  2 +-
 hledger/Hledger/Cli/Tests.hs | 37 +++++++++++++++++++++---------------
 3 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs
index def727ffd..3d083ee21 100644
--- a/hledger-lib/Hledger/Utils.hs
+++ b/hledger-lib/Hledger/Utils.hs
@@ -347,21 +347,21 @@ getCurrentLocalTime = do
 -- testing
 
 -- | Get a Test's label, or the empty string.
-tname :: Test -> String
-tname (TestLabel n _) = n
-tname _ = ""
+testName :: Test -> String
+testName (TestLabel n _) = n
+testName _ = ""
 
 -- | 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]
+flattenTests :: Test -> [Test]
+flattenTests (TestLabel _ t@(TestList _)) = flattenTests t
+flattenTests (TestList ts) = concatMap flattenTests ts
+flattenTests 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
+filterTests :: (Test -> Bool) -> Test -> Test
+filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts)
+filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts
+filterTests _ t = t
 
 -- | Simple way to assert something is some expected value, with no label.
 is :: (Eq a, Show a) => a -> a -> Assertion
diff --git a/hledger/Hledger/Cli/Main.hs b/hledger/Hledger/Cli/Main.hs
index cc4cfe6d6..7bf4f093c 100644
--- a/hledger/Hledger/Cli/Main.hs
+++ b/hledger/Hledger/Cli/Main.hs
@@ -75,7 +75,7 @@ main = do
        | (null matchedaddon) && "binary-filename" `in_` (rawopts_ opts) = putStrLn $ binaryfilename progname
        | null cmd                                        = putStr $ showModeHelp mainmode'
        | cmd `isPrefixOf` "add"                          = showModeHelpOr addmode      $ journalFilePathFromOpts opts >>= ensureJournalFileExists >> withJournalDo opts add
-       | cmd `isPrefixOf` "test"                         = showModeHelpOr testmode     $ runtests opts
+       | cmd `isPrefixOf` "test"                         = showModeHelpOr testmode     $ test' opts
        | any (cmd `isPrefixOf`) ["accounts","balance"]   = showModeHelpOr accountsmode $ withJournalDo opts balance
        | any (cmd `isPrefixOf`) ["entries","print"]      = showModeHelpOr entriesmode  $ withJournalDo opts print'
        | any (cmd `isPrefixOf`) ["postings","register"]  = showModeHelpOr postingsmode $ withJournalDo opts register
diff --git a/hledger/Hledger/Cli/Tests.hs b/hledger/Hledger/Cli/Tests.hs
index 20be46e08..ec0621955 100644
--- a/hledger/Hledger/Cli/Tests.hs
+++ b/hledger/Hledger/Cli/Tests.hs
@@ -37,22 +37,29 @@ import Hledger.Cli
 
 
 -- | Run unit tests and exit with success or failure.
-runtests :: CliOpts -> IO ()
-runtests opts = do
-  (hunitcounts,_) <- runtests' opts
-  if errors hunitcounts > 0 || (failures hunitcounts > 0)
+test' :: CliOpts -> IO ()
+test' opts = do
+  results <- runTests opts
+  if errors results > 0 || failures results > 0
    then exitFailure
    else exitWith ExitSuccess
 
--- | Run unit tests and exit on failure.
-runTestsOrExit :: CliOpts -> IO ()
-runTestsOrExit opts = do
-  (hunitcounts,_) <- runtests' opts
-  when (errors hunitcounts > 0 || (failures hunitcounts > 0)) $ exitFailure
+-- | Run all or just the matched unit tests and return their HUnit result counts.
+runTests :: CliOpts -> IO Counts
+runTests = liftM (fst . flip (,) 0) . runTestTT . flatTests
 
-runtests' :: Num b => CliOpts -> IO (Counts, b)
-runtests' opts = liftM (flip (,) 0) $ runTestTT ts
-    where
-      ts = TestList $ filter matchname $ tflatten tests_Hledger_Cli  -- show flat test names
-      -- ts = tfilter matchname $ TestList tests -- show hierarchical test names
-      matchname = matchpats (patterns_ $ reportopts_ opts) . tname
+-- | Run all or just the matched unit tests until the first failure or
+-- error, returning the name of the problem test if any.
+runTestsTillFailure :: CliOpts -> IO (Maybe String)
+runTestsTillFailure opts = undefined -- do
+  -- let ts = flatTests opts
+  --     results = liftM (fst . flip (,) 0) $ runTestTT $
+  --     firstproblem = find (\counts -> )
+
+-- | All or pattern-matched tests, as a flat list to show simple names.
+flatTests opts = TestList $ filter (matcherFromOpts opts) $ flattenTests tests_Hledger_Cli
+
+-- | All or pattern-matched tests, in the original suites to show hierarchical names.
+hierarchicalTests opts = filterTests (matcherFromOpts opts) tests_Hledger_Cli
+
+matcherFromOpts opts = matchpats (patterns_ $ reportopts_ opts) . testName