ddbec737f2
For some reason, the usage check tests are now very slow to run (perhaps because of all the operator definitions added to each one?), which needs further investigation.
648 lines
29 KiB
Haskell
648 lines
29 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007, 2008 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
{-|
|
|
|
|
This TestUtil module contains useful helper functions for testing. Examples of their use can be found in "RainPassTest" and "RainParseTest".
|
|
Unless otherwise stated, all functions use empty meta tags (see 'emptyMeta').
|
|
|
|
See also the 'TreeUtil.assertPatternMatch' function.
|
|
|
|
|
|
The Tock test framework is built on top of HUnit. HUnit is a very simple test framework that is supplied by default with GHC:
|
|
<http://www.haskell.org/ghc/docs/latest/html/libraries/HUnit/Test-HUnit-Base.html>. The only useful things to know are that:
|
|
|
|
> Assertion :: IO ()
|
|
> assertFailure :: String -> Assertion
|
|
> assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
|
|
|
|
'assertFailure' is an assertion that fails with the given text message. 'assertEqual' checks if two things of the same type are equal.
|
|
If they are not equal, it shows them (using 'show') with the given message prefixed.
|
|
|
|
-}
|
|
|
|
module TestUtils where
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Writer
|
|
import Data.Generics
|
|
import qualified Data.Map as Map
|
|
import System.Random
|
|
import Test.HUnit hiding (State,Testable)
|
|
import Test.QuickCheck
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import Metadata (emptyMeta)
|
|
import Pass
|
|
import Pattern
|
|
import PrettyShow
|
|
import TestFramework
|
|
import TreeUtils
|
|
import Types
|
|
import Utils
|
|
|
|
--{{{ utilities for QuickCheck tests
|
|
|
|
data QuickCheckLevel = QC_Low | QC_Medium | QC_High | QC_Extensive
|
|
deriving (Show, Eq, Ord)
|
|
|
|
type QuickCheckTest = QuickCheckLevel -> Test
|
|
|
|
type LabelledQuickCheckTest = (String, QuickCheckTest)
|
|
|
|
-- | Adjust the size of a QuickCheck test depending on the check level.
|
|
scaleQC :: Testable a => (Int,Int,Int,Int) -> a -> QuickCheckTest
|
|
scaleQC (low,med,high,ext) test level
|
|
= case level of
|
|
QC_Low -> run low test
|
|
QC_Medium -> run med test
|
|
QC_High -> run high test
|
|
QC_Extensive -> run ext test
|
|
where
|
|
run :: Testable a => Int -> a -> Test
|
|
run n = testCheck $ defaultConfig { configMaxTest = n }
|
|
|
|
-- | Run a QuickCheck test as an HUnit test.
|
|
testCheck :: Testable a => Config -> a -> Test
|
|
testCheck config property =
|
|
TestCase $ do rnd <- newStdGen
|
|
tests config (evaluate property) rnd 0 0 []
|
|
where
|
|
-- | The 'tests' function from QuickCheck, modified to throw assertion
|
|
-- failures when something goes wrong. (This is taken from MissingH.)
|
|
tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
|
|
tests config gen rnd0 ntest nfail stamps
|
|
| ntest == configMaxTest config = return ()
|
|
| nfail == configMaxFail config
|
|
= assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests"
|
|
| otherwise
|
|
= case ok result of
|
|
Nothing ->
|
|
tests config gen rnd1 ntest (nfail+1) stamps
|
|
Just True ->
|
|
tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
|
|
Just False ->
|
|
assertFailure $ "Falsifiable, after " ++ show ntest
|
|
++ " tests:\n" ++ unlines (arguments result)
|
|
where
|
|
result = generate (configSize config ntest) rnd2 gen
|
|
(rnd1,rnd2) = split rnd0
|
|
|
|
--}}}
|
|
--{{{ building AST fragments and patterns
|
|
|
|
-- | Wraps a structured process into a complete AST fragment.
|
|
wrapProcSeq :: A.Structured A.Process -> A.AST
|
|
wrapProcSeq x = A.Spec emptyMeta (A.Specification emptyMeta (simpleName "foo")
|
|
$ A.Proc emptyMeta (A.PlainSpec, A.PlainRec) [] $ Just $ A.Seq emptyMeta x) (A.Several emptyMeta [])
|
|
|
|
|
|
-- | Helper function to generate an array dimension.
|
|
dimension :: Int -> A.Dimension
|
|
dimension n = makeDimension emptyMeta n
|
|
|
|
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
|
|
simpleName :: String -> A.Name
|
|
simpleName s = A.Name { A.nameName = s, A.nameMeta = emptyMeta }
|
|
|
|
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
|
|
procName :: String -> A.Name
|
|
procName = simpleName
|
|
|
|
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
|
|
typeName :: String -> A.Name
|
|
typeName = simpleName
|
|
|
|
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
|
|
funcName :: String -> A.Name
|
|
funcName = simpleName
|
|
|
|
-- | Creates a 'Pattern' to match a 'A.Name' instance.
|
|
-- @'assertPatternMatch' ('simpleNamePattern' x) ('simpleName' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
simpleNamePattern :: String -> Pattern
|
|
simpleNamePattern s = tag2 A.Name DontCare s
|
|
|
|
-- | Creates a 'Pattern' to match a 'A.Name' instance.
|
|
-- @'assertPatternMatch' ('procNamePattern' x) ('procName' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
procNamePattern :: String -> Pattern
|
|
procNamePattern s = tag2 A.Name DontCare s
|
|
|
|
-- | Creates a 'A.Variable' with the given 'String' as the name.
|
|
variable :: String -> A.Variable
|
|
variable e = A.Variable emptyMeta $ simpleName e
|
|
|
|
-- | Creates a 'Pattern' to match a 'A.Variable' instance.
|
|
-- @'assertPatternMatch' ('variablePattern' x) ('variable' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
variablePattern :: String -> Pattern
|
|
variablePattern e = tag2 A.Variable DontCare (simpleNamePattern e)
|
|
|
|
-- | Creates an 'A.Expression' that has the 'A.ExprVariable' constructor with the given 'String' as the variable name.
|
|
exprVariable :: String -> A.Expression
|
|
exprVariable e = A.ExprVariable emptyMeta $ variable e
|
|
|
|
-- | Creates an 'A.Expression' that has the 'A.ExprVariable' constructor with the given 'String' as the variable name in a 'A.DirectedVariable' with the given direction.
|
|
exprDirVariable :: A.Direction -> String -> A.Expression
|
|
exprDirVariable dir e = A.ExprVariable emptyMeta $ A.DirectedVariable emptyMeta dir $ variable e
|
|
|
|
-- | Creates a 'Pattern' to match an 'A.Expression' instance.
|
|
-- @'assertPatternMatch' ('exprVariablePattern' x) ('exprVariable' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
exprVariablePattern :: String -> Pattern
|
|
exprVariablePattern e = tag2 A.ExprVariable DontCare $ variablePattern e
|
|
|
|
-- | Creates a char (Byte) literal with the given char
|
|
charLiteral :: Char -> A.Expression
|
|
charLiteral c = A.Literal emptyMeta A.Byte $ A.ByteLiteral emptyMeta [c]
|
|
|
|
-- | Creates an integer literal 'A.Expression' with the given integer.
|
|
integerLiteral :: A.Type -> Integer -> A.Expression
|
|
integerLiteral t n = A.Literal emptyMeta t $ A.IntLiteral emptyMeta (show n)
|
|
|
|
-- | Creates an 'A.Int' literal with the given integer.
|
|
intLiteral :: Integer -> A.Expression
|
|
intLiteral n = integerLiteral A.Int n
|
|
|
|
-- | Creates an 'A.Byte' literal with the given integer.
|
|
byteLiteral :: Integer -> A.Expression
|
|
byteLiteral n = integerLiteral A.Byte n
|
|
|
|
-- | Create an 'A.Bool' literal.
|
|
boolLiteral :: Bool -> A.Expression
|
|
boolLiteral b = if b then A.True emptyMeta else A.False emptyMeta
|
|
|
|
-- | Creates a 'Pattern' to match an 'A.Expression' instance.
|
|
-- @'assertPatternMatch' ('intLiteralPattern' x) ('intLiteral' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
intLiteralPattern :: Integer -> Pattern
|
|
intLiteralPattern = (stopCaringPattern emptyMeta) . mkPattern . intLiteral
|
|
|
|
|
|
-- | Creates an integer literal 'A.Expression' with the given integer.
|
|
int64Literal :: Integer -> A.Expression
|
|
int64Literal = integerLiteral A.Int64
|
|
|
|
int32Literal :: Integer -> A.Expression
|
|
int32Literal = integerLiteral A.Int32
|
|
|
|
-- | Creates a 'Pattern' to match an 'A.Expression' instance.
|
|
-- @'assertPatternMatch' ('intLiteralPattern' x) ('intLiteral' x)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
int64LiteralPattern :: Integer -> Pattern
|
|
int64LiteralPattern = (stopCaringPattern emptyMeta) . mkPattern . int64Literal
|
|
|
|
-- | Creates a pair of variable lists, given a pair of variable-name lists as input.
|
|
makeNamesWR :: ([String],[String]) -> ([A.Variable],[A.Variable])
|
|
makeNamesWR (x,y) = (map variable x,map variable y)
|
|
|
|
-- | Creates a simple assignment ('A.Assign') 'A.Process', given two variable names.
|
|
makeSimpleAssign :: String -> String -> A.Process
|
|
makeSimpleAssign dest src = A.Assign emptyMeta [A.Variable emptyMeta $ simpleName dest] (A.ExpressionList emptyMeta [exprVariable src])
|
|
|
|
-- | Creates a 'Pattern' to match a 'A.Process' instance.
|
|
-- @'assertPatternMatch' ('makeSimpleAssignPattern' x y) ('makeSimpleAssign' x y)@ will always succeed.
|
|
-- All meta tags are ignored.
|
|
makeSimpleAssignPattern :: String -> String -> Pattern
|
|
makeSimpleAssignPattern lhs rhs = stopCaringPattern emptyMeta $ mkPattern $ makeSimpleAssign lhs rhs
|
|
|
|
-- | Turns a list of 'A.Process' into a 'A.Seq' with those processes in order, with empty meta tags.
|
|
makeSeq :: [A.Process] -> A.Process
|
|
makeSeq procList = A.Seq emptyMeta $ A.Several emptyMeta (map (A.Only emptyMeta) procList)
|
|
|
|
-- | Turns a list of 'A.Process' into a 'A.Par' with those processes in order (with type 'A.PlainPar'), with empty meta tags.
|
|
makePar :: [A.Process] -> A.Process
|
|
makePar procList = A.Par emptyMeta A.PlainPar $ A.Several emptyMeta (map (A.Only emptyMeta) procList)
|
|
|
|
-- | Wraps the given process in a replicated 'A.Par' of the form PAR i = 0 FOR 3.
|
|
makeRepPar :: A.Process -> A.Process
|
|
makeRepPar proc = A.Par emptyMeta A.PlainPar $ A.Spec emptyMeta
|
|
(A.Specification emptyMeta (simpleName "i") (A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 3)
|
|
(intLiteral 1)))) (A.Only emptyMeta proc)
|
|
|
|
-- | Creates an assignment to the given 'A.Variable' from the given 'A.Expression.'
|
|
makeAssign :: A.Variable -> A.Expression -> A.Process
|
|
makeAssign v e = A.Assign emptyMeta [v] $ A.ExpressionList emptyMeta [e]
|
|
|
|
-- | Creates a 'Pattern' to match a 'A.Process' instance.
|
|
-- @'assertPatternMatch' ('makeAssignPattern' (mkPattern x) (mkPattern y)) ('makeAssign' x y)@ will always succeed.
|
|
-- All meta tags are ignored
|
|
makeAssignPattern :: Pattern -> Pattern -> Pattern
|
|
makeAssignPattern v e = tag3 A.Assign DontCare [v] $ tag2 A.ExpressionList DontCare [e]
|
|
|
|
-- | Creates a literal string expression from the given 'String'.
|
|
makeLiteralStringRain :: String -> A.Expression
|
|
makeLiteralStringRain str = A.Literal emptyMeta (A.List A.Byte) (A.ArrayListLiteral emptyMeta $
|
|
A.Several emptyMeta (map (A.Only emptyMeta . makeLiteralChar) str))
|
|
where
|
|
makeLiteralChar :: Char -> A.Expression
|
|
makeLiteralChar c = A.Literal emptyMeta A.Byte (A.ByteLiteral emptyMeta [c] {-(show (fromEnum c))-})
|
|
|
|
-- | Creates a 'Pattern' to match an 'A.Expression' instance.
|
|
-- @'assertPatternMatch' ('makeLiteralStringPattern' x) ('makeLiteralString' x)@ will always succeed.
|
|
-- All meta tags are ignored
|
|
makeLiteralStringRainPattern :: String -> Pattern
|
|
makeLiteralStringRainPattern = (stopCaringPattern emptyMeta) . mkPattern . makeLiteralStringRain
|
|
|
|
-- | Creates a 'Pattern' to match an 'A.Expression' instance.
|
|
-- All meta tags are ignored
|
|
makeLiteralCharPattern :: Char -> Pattern
|
|
makeLiteralCharPattern c = tag3 A.Literal DontCare A.Byte (tag2 A.ByteLiteral DontCare [c])
|
|
|
|
data ExprHelper =
|
|
Dy ExprHelper String ExprHelper
|
|
| Mon (String, A.Type) ExprHelper
|
|
| Cast A.Type ExprHelper
|
|
| Var String
|
|
| DirVar A.Direction String
|
|
| Lit A.Expression
|
|
| EHTrue
|
|
| Func String [ExprHelper]
|
|
|
|
buildExprPattern :: ExprHelper -> Pattern
|
|
buildExprPattern = (stopCaringPattern emptyMeta) . mkPattern . buildExpr
|
|
|
|
buildExpr :: ExprHelper -> A.Expression
|
|
buildExpr (Dy lhs op rhs) = A.FunctionCall emptyMeta (A.Name emptyMeta
|
|
$ occamDefaultOperator op [A.Int, A.Int]) [buildExpr lhs, buildExpr rhs]
|
|
buildExpr (Mon (op, t) rhs) = A.FunctionCall emptyMeta (A.Name emptyMeta $ occamDefaultOperator op [t]) [buildExpr rhs]
|
|
buildExpr (Cast ty rhs) = A.Conversion emptyMeta A.DefaultConversion ty (buildExpr rhs)
|
|
buildExpr (Var n) = A.ExprVariable emptyMeta $ variable n
|
|
buildExpr (DirVar dir n) = A.ExprVariable emptyMeta $ (A.DirectedVariable emptyMeta dir $ variable n)
|
|
buildExpr (Lit e) = e
|
|
buildExpr EHTrue = A.True emptyMeta
|
|
buildExpr (Func f es) = A.FunctionCall emptyMeta (simpleName f) (map buildExpr es)
|
|
|
|
-- | A simple definition of a variable
|
|
simpleDef :: String -> A.SpecType -> A.NameDef
|
|
simpleDef n sp = A.NameDef {A.ndMeta = emptyMeta, A.ndName = n, A.ndOrigName = n,
|
|
A.ndNameSource = A.NameUser,
|
|
A.ndSpecType = sp, A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
|
|
|
|
-- | A simple definition of a declared variable
|
|
simpleDefDecl :: String -> A.Type -> A.NameDef
|
|
simpleDefDecl n t = simpleDef n (A.Declaration emptyMeta t)
|
|
|
|
-- | A pattern that will match simpleDef, with a different abbreviation mode
|
|
simpleDefPattern :: String -> A.AbbrevMode -> Pattern -> Pattern
|
|
simpleDefPattern n am sp = tag6 A.NameDef DontCare n n sp am A.Unplaced
|
|
|
|
--}}}
|
|
--{{{ defining things
|
|
|
|
-- | Define something in the initial state.
|
|
defineThing :: CSM m => String -> A.SpecType -> A.AbbrevMode -> A.NameSource -> m ()
|
|
defineThing s st am ns = defineName (simpleName s) $
|
|
A.NameDef {
|
|
A.ndMeta = emptyMeta,
|
|
A.ndName = s,
|
|
A.ndOrigName = s,
|
|
A.ndSpecType = st,
|
|
A.ndAbbrevMode = am,
|
|
A.ndNameSource = ns,
|
|
A.ndPlacement = A.Unplaced
|
|
}
|
|
|
|
-- | Define a @VAL IS@ constant.
|
|
defineConst :: String -> A.Type -> A.Expression -> State CompState ()
|
|
defineConst s t e
|
|
= defineThing s (A.Is emptyMeta A.ValAbbrev t $ A.ActualExpression e)
|
|
A.ValAbbrev A.NameUser
|
|
|
|
-- | Define an @IS@ abbreviation.
|
|
defineIs :: String -> A.Type -> A.Variable -> State CompState ()
|
|
defineIs s t v
|
|
= defineThing s (A.Is emptyMeta A.Abbrev t $ A.ActualVariable v) A.Abbrev A.NameUser
|
|
|
|
-- | Define something original.
|
|
defineOriginal :: CSM m => String -> A.Type -> m ()
|
|
defineOriginal s t
|
|
= defineThing s (A.Declaration emptyMeta t) A.Original A.NameUser
|
|
|
|
-- | Define a variable.
|
|
defineVariable :: CSM m => String -> A.Type -> m ()
|
|
defineVariable = defineOriginal
|
|
|
|
-- | Define a channel.
|
|
defineChannel :: String -> A.Type -> State CompState ()
|
|
defineChannel = defineOriginal
|
|
|
|
-- | Define a timer.
|
|
defineTimer :: String -> A.Type -> State CompState ()
|
|
defineTimer = defineOriginal
|
|
|
|
-- | Define a user data type.
|
|
defineUserDataType :: String -> A.Type -> State CompState ()
|
|
defineUserDataType s t
|
|
= defineThing s (A.DataType emptyMeta t) A.Original A.NameUser
|
|
|
|
-- | Define a record type.
|
|
-- (The fields are unscoped names, and thus don't need defining.)
|
|
defineRecordType :: String -> [(String, A.Type)] -> State CompState ()
|
|
defineRecordType s fs
|
|
= defineThing s st A.Original A.NameUser
|
|
where
|
|
st = A.RecordType emptyMeta (A.RecordAttr False False) [(simpleName s, t) | (s, t) <- fs]
|
|
|
|
-- | Define a function.
|
|
defineFunction :: String -> [A.Type] -> [(String, A.Type)]
|
|
-> State CompState ()
|
|
defineFunction s rs as
|
|
= defineThing s st A.Original A.NameUser
|
|
where
|
|
st = A.Function emptyMeta (A.PlainSpec, A.PlainRec) rs fs (Just $ Right $ A.Skip emptyMeta)
|
|
fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as]
|
|
|
|
-- | Define a proc.
|
|
defineProc :: CSM m => String -> [(String, A.AbbrevMode, A.Type)] -> m ()
|
|
defineProc s as
|
|
= defineThing s st A.Original A.NameUser
|
|
where
|
|
st = A.Proc emptyMeta (A.PlainSpec, A.PlainRec) fs $ Just $ A.Skip emptyMeta
|
|
fs = [A.Formal am t (simpleName s) | (s, am, t) <- as]
|
|
|
|
-- | Define a protocol.
|
|
defineProtocol :: String -> [A.Type] -> State CompState ()
|
|
defineProtocol s ts
|
|
= defineThing s (A.Protocol emptyMeta ts) A.Original A.NameUser
|
|
|
|
-- | Define a variant protocol.
|
|
defineProtocolCase :: String -> [(A.Name, [A.Type])] -> State CompState ()
|
|
defineProtocolCase s ntss
|
|
= defineThing s (A.ProtocolCase emptyMeta ntss) A.Original A.NameUser
|
|
|
|
--}}}
|
|
--{{{ custom assertions
|
|
|
|
-- | Asserts a comparison using a custom comparison function.
|
|
-- @'assertCompareCustom' msg (==) x y@ will function the same (except for slightly different messages on failure) as @'assertEqual' msg x y@.
|
|
assertCompareCustom ::
|
|
Show a =>
|
|
String -- ^ The message\/test name to prefix on failure.
|
|
-> (a -> a -> Bool) -- ^ The comparison function. A return of True means the Assertion will succeed, False means the Assertion will fail.
|
|
-> a -- ^ The expected\/yardstick value.
|
|
-> a -- ^ The actual value from running the test.
|
|
-> Assertion
|
|
assertCompareCustom preface cmp expected actual =
|
|
unless (cmp actual expected) (assertFailure msg)
|
|
where msg = (if null preface then "" else preface ++ "\n") ++
|
|
"expected: " ++ show expected ++ "\n*** got: " ++ show actual
|
|
|
|
-- | Asserts that the two given items are not equal.
|
|
-- Similar to assertEqual, but with the condition reversed.
|
|
assertNotEqual ::
|
|
(Show a,Eq a) =>
|
|
String -- ^ The message\/test name to prefix on failure.
|
|
-> a -- ^ The expected\/yardstick value that the actual value should not equal.
|
|
-> a -- ^ The actual value from running the test.
|
|
-> Assertion
|
|
assertNotEqual msg = assertCompareCustom msg (/=)
|
|
|
|
-- | Asserts that two items in the Items set (by two given keys) are not the same, typically checking that an item has been transformed somehow.
|
|
-- This function is often used with 'testPassGetItems' or 'testPassWithCheck' or 'testPassWithItemsStateCheck'.
|
|
assertItemNotSame ::
|
|
String -- ^ The message\/test name to prefix on failur
|
|
-> Items -- ^ The set of items after running the test.
|
|
-> String -- ^ The key of the untransformed original item
|
|
-> String -- ^ The key of the new transformed item
|
|
-> Assertion
|
|
assertItemNotSame msg items key0 key1 = assertNotEqual msg ((Map.lookup key0 items) :: Maybe AnyDataItem) ((Map.lookup key1 items) :: Maybe AnyDataItem)
|
|
|
|
-- | Asserts that a particular variable is defined in the given 'CompState'.
|
|
assertVarDef ::
|
|
String -- ^ The message\/test name to prefix on failure.
|
|
-> CompState -- ^ The 'CompState' in which to check for the variable being defined
|
|
-> String -- ^ The name of the variable to check for.
|
|
-> Pattern -- ^ The expected value of the definition. Expected to be a 'Pattern' that will match a 'A.NameDef'.
|
|
-> Assertion
|
|
assertVarDef prefix state varName varDef
|
|
= case (Map.lookup varName (csNames state)) of
|
|
Nothing -> assertFailure $ prefix ++ " variable was not recorded: " ++ varName
|
|
Just actVarDef -> assertPatternMatch (prefix ++ " variable definition not as expected for " ++ varName) varDef actVarDef
|
|
|
|
checkTempVarTypes :: String -> [(String, A.Type)] -> (Items, CompState) -> Assertion
|
|
checkTempVarTypes testName vars is = mapM_ (checkTempVarType testName is) vars
|
|
where
|
|
checkTempVarType :: String -> (Items, CompState) -> (String, A.Type) -> Assertion
|
|
checkTempVarType testName (items, state) (key, t)
|
|
= do (A.Name _ nm) <- castOrFail testName key items
|
|
case Map.lookup nm (csNames state) of
|
|
Nothing -> assertFailure (testName ++ ": item with key \"" ++ key ++ "\" was not recorded in the state")
|
|
Just nd -> evalStateT (
|
|
do mtSpec <- typeOfSpec (A.ndSpecType nd)
|
|
case mtSpec of
|
|
Just tSpec -> liftIO $ assertEqual (testName ++ ": type not as expected for key \"" ++ key ++ "\"") t tSpec
|
|
Nothing -> liftIO $ assertFailure (testName ++ ": spec does not have identifiable type for key \"" ++ key ++ "\": " ++ show (A.ndSpecType nd))
|
|
) state
|
|
|
|
assertEither :: (Eq a, Eq e, Show a, Show e, TestMonad m r) => String -> a -> Either e a -> m ()
|
|
assertEither testName exp = testEqual testName (Right exp)
|
|
|
|
assertEitherFail :: String -> Either String a -> Assertion
|
|
assertEitherFail testName result
|
|
= case result of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure $ testName ++ "; test expected to fail but passed"
|
|
|
|
checkRight :: (Show a, TestMonad m r) => Either a b -> m b
|
|
checkRight (Left err) = testFailure ("Not Right: " ++ show err) >> return undefined
|
|
checkRight (Right x) = return x
|
|
|
|
--}}}
|
|
--{{{ canned tests
|
|
|
|
-- | Tests a given AST pass. This function is primarily intended for internal use by this module.
|
|
-- 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, 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.
|
|
-> Pass
|
|
-> b
|
|
-> (State CompState ()) -- ^ A function to transform a 'CompState'. Will be used on the 'emptyState' to get the initial state for the pass.
|
|
-> 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 src startStateTrans =
|
|
--passResult :: Either String b
|
|
do passResult <- runPass actualPass src startState
|
|
case passResult of
|
|
(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
|
|
|
|
prefixErr :: String -> String
|
|
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 :: (Data b, TestMonad m r) =>
|
|
Pass -> b -- ^ The actual pass.
|
|
-> CompState -- ^ The state to use to run the pass.
|
|
-> m (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass.
|
|
runPass actualPass src startState = liftM revPair $
|
|
runIO (runPassM startState $ passCode actualPass src)
|
|
|
|
runPass' :: TestMonad m r =>
|
|
PassM b -> CompState -> m (CompState, Either ErrorReport b)
|
|
runPass' actualPass startState
|
|
= runIO (runPassM startState actualPass) >>* revPair
|
|
|
|
-- | A test that runs a given AST pass and checks that it succeeds.
|
|
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.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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.
|
|
-> m ()
|
|
--If Items are returned by testPassGetItems we return () [i.e. give an empty assertion], otherwise give back the assertion:
|
|
testPass w x x' y z = join $ testPassGetItems w x x' y z >>* (either id (const $ return ()) . snd)
|
|
|
|
testPass' ::
|
|
(Data a, Show a, Eq a, Data b, TestMonad m r) =>
|
|
String -> a -> PassM b -> State CompState () -> m ()
|
|
testPass' name exp act st
|
|
= runPass' act (execState st emptyState)
|
|
>>= \x -> case snd x of
|
|
Left err -> testFailure $ name ++ " expected to pass but failed: " ++
|
|
show err
|
|
Right x' -> testPatternMatch name exp x'
|
|
|
|
-- | 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, TestMonad m r) =>
|
|
String -- ^ The test name.
|
|
-> a -- ^ The expected value. Can either be an actual AST, or a 'Pattern' to match an AST.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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 -> m ())
|
|
-> m ()
|
|
testPassWithCheck testName expected actualPass src startStateTrans checkFunc =
|
|
do passResult <- runPass actualPass src (execState startStateTrans emptyState)
|
|
case snd passResult of
|
|
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, TestMonad m r) =>
|
|
String -- ^ The test name.
|
|
-> a -- ^ The expected value. Can either be an actual AST, or a 'Pattern' to match an AST.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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 -> m ()) -- ^ A function to check the 'Items' once the pass succeeds.
|
|
-> m ()
|
|
testPassWithItemsCheck testName expected actualPass src startStateTrans checkFunc =
|
|
((liftM snd) (testPassGetItems testName expected actualPass src startStateTrans))
|
|
>>= (\res ->
|
|
case res of
|
|
Left assert -> assert
|
|
Right items -> checkFunc items
|
|
)
|
|
|
|
-- | 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, TestMonad m r) =>
|
|
String -- ^ The test name.
|
|
-> a -- ^ The expected value. Can either be an actual AST, or a 'Pattern' to match an AST.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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 -> m ()) -- ^ A function to check the 'CompState' once the pass succeeds.
|
|
-> m ()
|
|
testPassWithStateCheck testName expected actualPass src startStateTrans checkFunc =
|
|
(testPassGetItems testName expected actualPass src startStateTrans)
|
|
>>= (\x ->
|
|
case x of
|
|
(_,Left assert) -> assert
|
|
(st,Right _) -> checkFunc st
|
|
)
|
|
|
|
-- | 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, TestMonad m r) =>
|
|
String -- ^ The test name.
|
|
-> a -- ^ The expected value. Can either be an actual AST, or a 'Pattern' to match an AST.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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) -> m ()) -- ^ A function to check the 'Items' and 'CompState' once the pass succeeds.
|
|
-> m ()
|
|
testPassWithItemsStateCheck testName expected actualPass src startStateTrans checkFunc =
|
|
(testPassGetItems testName expected actualPass src startStateTrans)
|
|
>>= (\x ->
|
|
case x of
|
|
(_,Left assert) -> assert
|
|
(st,Right items) -> checkFunc (items,st)
|
|
)
|
|
|
|
-- | 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, TestMonad m r) =>
|
|
String -- ^ The test name.
|
|
-> Pass -- ^ The actual pass.
|
|
-> b -- ^ The source for 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.
|
|
-> m ()
|
|
testPassShouldFail testName actualPass src startStateTrans =
|
|
do ret <- runPass actualPass src (execState startStateTrans emptyState)
|
|
case ret of
|
|
(_,Left err) -> return ()
|
|
(state, Right output) -> testFailure $ testName ++ " pass succeeded when expected to fail; output: " ++ pshow output
|
|
|
|
testPassShouldFail' ::
|
|
(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.
|
|
-> m ()
|
|
testPassShouldFail' testName actualPass startStateTrans =
|
|
do ret <- runPass' actualPass (execState startStateTrans emptyState)
|
|
case ret of
|
|
(_,Left err) -> return ()
|
|
(state, Right output) -> testFailure $ testName ++ " pass succeeded when expected to fail; output: " ++ pshow output
|
|
|
|
|
|
--}}}
|
|
--{{{ miscellaneous utilities
|
|
|
|
markRainTest :: State CompState ()
|
|
markRainTest = modify (\cs -> cs { csFrontend = FrontendRain })
|
|
|
|
castOrFail :: (Typeable b) => String -> String -> Items -> IO b
|
|
castOrFail testName key items =
|
|
case castADI (Map.lookup key items) of
|
|
Just y -> return y
|
|
Nothing -> do assertFailure (testName ++ ": could not find item")
|
|
-- Need this line so the types match:
|
|
fail ""
|
|
|
|
instance Die (StateT CompState IO) where
|
|
dieReport (_,s) = liftIO $ do assertFailure s
|
|
fail s
|
|
|
|
--}}}
|