suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Neil Brown 2008-03-05 16:06:14 +00:00
parent d02b771572
commit 256ce80ccb
3 changed files with 40 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
common/TestFramework.hs
View File

@ -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

55
common/TestUtils.hs
View File

@ -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, Right resultItem) -> return (st, transformEither (mapM_ (assertFailure . prefixErr)) (id) $ getMatchedItems expected resultItem)
(st, Left (_, err)) -> return (st, Left $ testFailure (prefixErr $ "pass actually failed: " ++ err))
(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.
runPass actualPass startState = (liftM (\((x,y),_) -> (y,x))) (runWriterT $ runStateT (runErrorT actualPass) startState)
-> 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)) $ runIO (runWriterT $ runStateT (runErrorT actualPass) startState)
-- | A test that runs a given AST pass and checks that it succeeds.
testPass ::
(Data a, Data b) =>
testPass ::
(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)
-> Assertion
-> (b -> m ())
-> 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)
Right result -> (assertPatternMatch testName expected result) >> (checkFunc result)
Left (_,err) -> testFailure (testName ++ "; pass actually failed: " ++ err)
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.
-> Assertion
-> (Items -> m ()) -- ^ A function to check the 'Items' once the pass succeeds.
-> 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.
-> Assertion
-> (CompState -> m ()) -- ^ A function to check the 'CompState' once the pass succeeds.
-> 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.
-> Assertion
-> ((Items,CompState) -> m ()) -- ^ A function to check the 'Items' and 'CompState' once the pass succeeds.
-> 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 ::

12
common/TreeUtils.hs
View File

@ -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
assertPatternMatch msg exp act =
testPatternMatch :: (Data y, Data z, TestMonad m r) => String -> y -> z -> m ()
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