Moved all the testPass* functions into the TestMonad, using unsafePerformIO for running them inside QuickCheck

common/TestFramework.hs

@@ -22,6 +22,7 @@ module TestFramework where
 
 import Control.Monad.Error
 import Data.Generics
+import System.IO.Unsafe
 import Test.HUnit hiding (Testable)
 import Test.QuickCheck hiding (check)
 
@@ -34,14 +35,17 @@ instance Error Result where
 class Monad m => TestMonad m r | m -> r where
   runTest :: m () -> r
   testFailure :: String -> m ()
+  runIO :: IO a -> m a
 
 instance TestMonad IO Assertion where
   runTest = id
   testFailure = assertFailure
+  runIO = id
   
 instance TestMonad (Either Result) Result where
   runTest = either id (const $ Result (Just True) [] [])
   testFailure s = Left $ Result (Just False) [] [s]
+  runIO f = return (unsafePerformIO f)
 
 compareForResult :: TestMonad m r => String -> (a -> String) -> (a -> a -> Bool) -> a -> a -> m ()
 compareForResult msg showFunc cmpFunc exp act

common/TestUtils.hs

@@ -54,6 +54,7 @@ import Metadata (emptyMeta)
 import Pass
 import Pattern
 import PrettyShow
+import TestFramework
 import TreeUtils
 import Types
 import Utils
@@ -281,18 +282,18 @@ assertItemNotSame msg items key0 key1 = assertNotEqual msg ((Map.lookup key0 ite
 -- It takes an expected value, a transformed value (wrapped in the 'PassM' monad), an initial state-changing function, and returns the subsequent
 -- state, with either an assertion (if the pass failed) or the 'Items' (if the pass succeeded)
 testPassGetItems :: 
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                                     -- ^ The message\/test name to prefix on failure.
   -> a                                       -- ^ The expected outcome of the pass.  Will be used as a 'Pattern', to find the named items in the result of the pass.
   -> PassM b                                 -- ^ The actual pass.
   -> (State CompState ())                    -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> IO (CompState, Either Assertion Items)  -- ^ Returns the state, along with either an 'Assertion' (if the pass fails) or the 'Items' (if the pass succeeds).
+  -> m (CompState, Either (m ()) Items)        -- ^ Returns the state, along with either an 'Assertion' (if the pass fails) or the 'Items' (if the pass succeeds).
 testPassGetItems testName expected actualPass startStateTrans = 
        --passResult :: Either String b
     do passResult <- runPass actualPass startState
        case passResult of
-         (st, Left (_, err)) -> return (st, Left $ assertFailure (prefixErr $ "pass actually failed: " ++ err)) 
+         (st, Left (_, err)) -> return (st, Left $ testFailure (prefixErr $ "pass actually failed: " ++ err)) 
-         (st, Right resultItem) -> return (st, transformEither (mapM_ (assertFailure . prefixErr)) (id) $ getMatchedItems expected resultItem)
+         (st, Right resultItem) -> return (st, transformEither (mapM_ (testFailure . prefixErr)) (id) $ getMatchedItems expected resultItem)
        where
          startState :: CompState
          startState = execState startStateTrans emptyState
@@ -301,47 +302,47 @@ testPassGetItems testName expected actualPass startStateTrans =
          prefixErr err = testName ++ ": " ++ err
 
 -- | Runs a given AST pass and returns the subsequent state, along with either an error or the result.  This function is primarily intended for internal use by this module.
-runPass :: 
+runPass :: TestMonad m r =>
   PassM b                            -- ^ The actual pass.
   -> CompState                       -- ^ The state to use to run the pass.
-  -> IO (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass.
+  -> m (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass.
-runPass actualPass startState = (liftM (\((x,y),_) -> (y,x))) (runWriterT $ runStateT (runErrorT actualPass) startState)
+runPass actualPass startState = liftM (\((x,y),_) -> (y,x)) $ runIO (runWriterT $ runStateT (runErrorT actualPass) startState)
 
 -- | A test that runs a given AST pass and checks that it succeeds.
 testPass ::
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                    -- ^ The test name.
   -> a                      -- ^ The expected value.  Can either be an actual AST, or a 'Pattern' to match an AST.
   -> PassM b                -- ^ The actual pass.
   -> (State CompState ())   -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> Assertion
+  -> m ()
 --If Items are returned by testPassGetItems we return () [i.e. give an empty assertion], otherwise give back the assertion:
 testPass w x y z = join $ liftM (either (id) (\x -> return ())) $ (liftM snd) $ (testPassGetItems w x y z)
 
 -- | A test that runs a given AST pass and checks that it succeeds, and performs an additional check on the result
 testPassWithCheck ::
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                    -- ^ The test name.
   -> a                      -- ^ The expected value.  Can either be an actual AST, or a 'Pattern' to match an AST.
   -> PassM b                -- ^ The actual pass.
   -> (State CompState ())   -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> (b -> Assertion)
+  -> (b -> m ())
-  -> Assertion
+  -> m ()
 testPassWithCheck testName expected actualPass startStateTrans checkFunc =
   do passResult <- runPass actualPass (execState startStateTrans emptyState)
      case snd passResult of
-       Left (_,err) -> assertFailure (testName ++ "; pass actually failed: " ++ err)
+       Left (_,err) -> testFailure (testName ++ "; pass actually failed: " ++ err)
-       Right result -> (assertPatternMatch testName expected result) >> (checkFunc result)
+       Right result -> (testPatternMatch testName expected result) >> (checkFunc result)
 
 -- | A test that runs a given AST pass, checks that it succeeds, and checks the resulting 'Items' with a given function.
 testPassWithItemsCheck :: 
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                  -- ^ The test name.
   -> a                    -- ^ The expected value.  Can either be an actual AST, or a 'Pattern' to match an AST.
   -> PassM b              -- ^ The actual pass.
   -> (State CompState ()) -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> (Items -> Assertion) -- ^ A function to check the 'Items' once the pass succeeds.
+  -> (Items -> m ())      -- ^ A function to check the 'Items' once the pass succeeds.
-  -> Assertion
+  -> m ()
 testPassWithItemsCheck testName expected actualPass startStateTrans checkFunc =
   ((liftM snd) (testPassGetItems testName expected actualPass startStateTrans))
   >>= (\res ->
@@ -352,13 +353,13 @@ testPassWithItemsCheck testName expected actualPass startStateTrans checkFunc =
 
 -- | A test that runs a given AST pass, checks that it succeeds, and checks the resulting 'CompState' with a given function.
 testPassWithStateCheck :: 
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                      -- ^ The test name.
   -> a                        -- ^ The expected value.  Can either be an actual AST, or a 'Pattern' to match an AST.
   -> PassM b                  -- ^ The actual pass.
   -> (State CompState ())     -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> (CompState -> Assertion) -- ^ A function to check the 'CompState' once the pass succeeds.
+  -> (CompState -> m ())      -- ^ A function to check the 'CompState' once the pass succeeds.
-  -> Assertion
+  -> m ()
 testPassWithStateCheck testName expected actualPass startStateTrans checkFunc =
   (testPassGetItems testName expected actualPass startStateTrans)
   >>= (\x ->
@@ -369,13 +370,13 @@ testPassWithStateCheck testName expected actualPass startStateTrans checkFunc =
 
 -- | A test that runs a given AST pass, checks that it succeeds, and checks the resulting 'CompState' and 'Items' with a given function.
 testPassWithItemsStateCheck :: 
-  (Data a, Data b) => 
+  (Data a, Data b, TestMonad m r) =>
   String                              -- ^ The test name.
   -> a                                -- ^ The expected value.  Can either be an actual AST, or a 'Pattern' to match an AST.
   -> PassM b                          -- ^ The actual pass.
   -> (State CompState ())             -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> ((Items,CompState) -> Assertion) -- ^ A function to check the 'Items' and 'CompState' once the pass succeeds.
+  -> ((Items,CompState) -> m ())      -- ^ A function to check the 'Items' and 'CompState' once the pass succeeds.
-  -> Assertion
+  -> m ()
 testPassWithItemsStateCheck testName expected actualPass startStateTrans checkFunc =
   (testPassGetItems testName expected actualPass startStateTrans)
   >>= (\x ->
@@ -386,16 +387,16 @@ testPassWithItemsStateCheck testName expected actualPass startStateTrans checkFu
   
 -- | A test that checks that a given AST pass fails.  If the pass fails, the test succeeds.  If the pass succeeds, the test fails.
 testPassShouldFail :: 
-  (Show b, Data b) => 
+  (Show b, Data b, TestMonad m r) => 
   String                  -- ^ The test name.
   -> PassM b              -- ^ The actual pass.
   -> (State CompState ()) -- ^ A function to transform a 'CompState'.  Will be used on the 'emptyState' to get the initial state for the pass.
-  -> Assertion
+  -> m ()
 testPassShouldFail testName actualPass startStateTrans =
     do ret <- runPass actualPass (execState startStateTrans emptyState)
        case ret of
          (_,Left err) -> return ()
-         _ -> assertFailure $ testName ++ " pass succeeded when expected to fail, data: " ++ (pshow ret)
+         _ -> testFailure $ testName ++ " pass succeeded when expected to fail, data: " ++ (pshow ret)
 
 -- | Asserts that a particular variable is defined in the given 'CompState'.
 assertVarDef :: 

common/TreeUtils.hs

@@ -19,7 +19,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module TreeUtils (
   MatchErrors, 
   AnyDataItem(..), Items, castADI, 
-  assertPatternMatch, getMatchedItems, 
+  assertPatternMatch, testPatternMatch, getMatchedItems, 
   tag0, tag1, tag2, tag3, tag4, tag5, tag6, tag7, tag1d, tag2d, tag3d, tag4d, tag5d, tag6d, tag7d, 
   (@@),
   mkPattern, stopCaringPattern, namePattern, nameAndStopCaringPattern, 
@@ -37,6 +37,7 @@ import Test.HUnit hiding (State)
 
 import Pattern
 import qualified PrettyShow as PS
+import TestFramework
 
 type MatchErrors = [String]
 
@@ -170,13 +171,13 @@ sequenceS x = (liftM concat) (sequence x)
 
 -- | A function for checking that two Data items (expected, actual) match, where the expected item (LHS)
 --   may contain special Pattern values (such as DontCare, Named, etc)
-assertPatternMatch :: (Data y, Data z) => String -> y -> z -> Assertion
+testPatternMatch :: (Data y, Data z, TestMonad m r) => String -> y -> z -> m ()
-assertPatternMatch msg exp act = 
+testPatternMatch msg exp act = 
   --Sometimes it can be hard to understand the MatchErrors as they stand.  When you are told "1 expected, found 0" it's often hard
   --to know exactly which part of your huge match that refers to, especially if you can't see a 1 in your match.  So to add a little
   --bit of help, I append a pretty-printed version of the pattern and data to each error.
   sequence_ $ map (
-    assertFailure 
+    testFailure 
     . (append $ " while testing pattern:\n" ++ (PS.pshow exp) ++ "\n*** against actual:\n" ++ (PS.pshow act)) 
     . ((++) $ msg ++ " ")
   ) errors
@@ -184,6 +185,9 @@ assertPatternMatch msg exp act =
     errors = evalState (checkMatch (mkPattern exp) act) (Map.empty)
     append x y = y ++ x
 
+assertPatternMatch :: (Data y, Data z) => String -> y -> z -> Assertion
+assertPatternMatch = testPatternMatch
+
 -- | A function for getting the matched items from the patterns on the LHS
 --   Either returns the matched items, or a list of errors from the matching
 getMatchedItems :: (Data y, Data z) => y -> z -> Either MatchErrors Items