LslPlus-0.2.0: src/Language/Lsl/UnitTestEnv.hs
module Language.Lsl.UnitTestEnv(
simStep,
simFunc,
hasFunc,
SimpleWorld,
TestEvent(..),
ExecutionInfo(..),
ExecCommand(..),
FrameInfo,
TestResult) where
import Control.Monad(liftM2)
import Control.Monad.State(MonadState(..),State(..),StateT(..),evalState)
import Control.Monad.Error(ErrorT(..))
import Data.List(find,intersperse)
import Data.Maybe(isJust)
import Language.Lsl.Internal.Breakpoint(Breakpoint,BreakpointManager,checkBreakpoint,emptyBreakpointManager,
replaceBreakpoints,setStepBreakpoint,setStepOverBreakpoint,setStepOutBreakpoint,
breakpointFile,breakpointLine)
import Language.Lsl.Internal.CodeHelper(renderCall)
import Language.Lsl.Internal.FuncSigs(funcSigs)
import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs)
import Language.Lsl.Syntax hiding (State)
import qualified Language.Lsl.Syntax as L
import Language.Lsl.Internal.Type(LSLValue,lslValString,lslShowVal,defaultValue)
import Language.Lsl.Internal.Evaluation(EvalResult(..))
import Language.Lsl.Internal.Exec(
EvalState,ExecutionInfo(..),FrameInfo,ScriptImage(..),evalSimple,runEval,scriptImage,setupSimple,initStateSimple,frameInfo)
import Language.Lsl.Internal.TestResult(TestResult(..))
import Language.Lsl.UnitTest(EntryPoint(..),LSLUnitTest(..),ExpectationMode(..),FuncCallExpectations(..),expectedReturns,removeExpectation)
import Language.Lsl.Internal.Util(findM,ctx)
--trace1 v = trace ("->>" ++ (show v)) v
data SimpleWorld = SimpleWorld {
maxTick :: Int,
tick :: Int,
msgLog :: [(Int,String)],
wScripts :: [(String,Validity CompiledLSLScript)],
wLibrary :: [(String,Validity LModule)],
expectations :: FuncCallExpectations,
breakpointManager :: BreakpointManager
}
type SimpleWorldM = ErrorT String (State SimpleWorld)
simpleWorldM = ErrorT . State
getTick :: SimpleWorldM Int
getTick = get >>= return . tick
getMaxTick :: SimpleWorldM Int
getMaxTick = get >>= return . maxTick
getMsgLog :: SimpleWorldM [(Int,String)]
getMsgLog = get >>= return . msgLog
getWScripts :: SimpleWorldM [(String, Validity CompiledLSLScript)]
getWScripts = get >>= return . wScripts
getWLibrary :: SimpleWorldM [(String, Validity LModule)]
getWLibrary = get >>= return . wLibrary
getExpectations :: SimpleWorldM FuncCallExpectations
getExpectations = get >>= return . expectations
getBreakpointManager :: SimpleWorldM BreakpointManager
getBreakpointManager = get >>= return . breakpointManager
setTick t = do w <- get; put (w { tick = t })
setMsgLog l = do w <- get; put (w { msgLog = l })
setExpectations e = do w <- get; put (w { expectations = e })
setBreakpointManager bpm = do w <- get; put (w { breakpointManager = bpm })
modifyMsgLog f = do w <- get; put (w { msgLog = f (msgLog w) })
checkBp bp sm =
do bpm <- getBreakpointManager
let (result,bpm',sm') = checkBreakpoint bp bpm sm
setBreakpointManager bpm'
return (result,sm')
logMsg s = do
tick <- getTick
modifyMsgLog ((tick,s):)
doPredef n i a =
do logMsg $ "call: " ++ renderCall n a
case lookup n internalLLFuncs of
Just f -> do
result@(m, v) <- f i a
logMsg ("return: " ++ lslShowVal v)
return result
Nothing -> do
fce <- getExpectations
let allowed = Nice == expectationMode fce
case expectedReturns n a fce of
Nothing -> handleUnexpected allowed
Just (m, v) -> do
logMsg ("return: " ++ lslShowVal v)
setExpectations $ removeExpectation m fce
return (EvalIncomplete,v)
where handleUnexpected allowed =
if allowed then
do (_,rt,_) <- ctx ("finding predef " ++ n) $
findM (\ (n',_,_) -> n' == n) funcSigs
return $ (EvalIncomplete, defaultValue rt)
else fail ("unexpected call: " ++ renderCall n a)
mkScript (LModule globdefs vars) =
LSLScript (varsToGlobdefs ++ globdefs) [L.State (nullCtx "default") []]
where varsToGlobdefs = map (\ v -> GV v Nothing) vars
getValidScript name =
do scripts <- getWScripts
case lookup name scripts of
Nothing -> return (Left $ "No such script: " ++ name)
Just (Left s) -> return $ Left $ "Invalid script: " ++ name
Just (Right script) -> return $ Right script
convertEntryPoint (ScriptFunc scriptName funcName) =
do script <- getValidScript scriptName
return $ liftM2 (,) script (Right [funcName])
convertEntryPoint (ScriptHandler scriptName stateName handlerName) =
do script <- getValidScript scriptName
return $ liftM2 (,) script (Right [stateName,handlerName])
convertEntryPoint (ModuleFunc moduleName funcName) =
do lib <- getWLibrary
case lookup moduleName lib of
Nothing -> return (Left $ "No such module: " ++ moduleName)
Just (Left s) -> return (Left $ "Invalid module: " ++ moduleName)
Just (Right lmodule) ->
case compileLSLScript' lib (mkScript lmodule) of
Left _ -> return $ Left "Invalid entry point (internal error?)"
Right script -> return $ Right (script,[funcName])
checkResults (ms1, val, globs, w) unitTest =
let name = unitTestName unitTest
ms0 = expectedNewState unitTest
expectedR = expectedReturn unitTest in
if ((expectationMode $ expectations w) `elem` [Strict,Exhaust]) &&
(not (null (callList $ expectations w))) then
FailureResult name ("some expected function calls not made: " ++
concat (intersperse ", " $ map (fst.fst) $ callList $ expectations w))
(msgLog w)
else case (ms0, ms1) of
(Nothing, Just st) ->
FailureResult name ("expected no state change, but changed to " ++ st) (msgLog w)
(Just st, Nothing) ->
FailureResult name ("expected state change to " ++ st ++ ", but no change occurred") (msgLog w)
(ms0, ms1) | ms0 /= ms1 -> let (Just s0, Just s1) = (ms0,ms1) in
FailureResult name ("expected state change to " ++ s0 ++
", but acutally changed to " ++ s1) (msgLog w)
| otherwise ->
if expectedR /= Nothing && expectedR /= Just val then
let (Just val') = expectedR in
FailureResult name ("expected return value was " ++ (lslValString val') ++
", but actually was " ++ (lslValString val)) (msgLog w)
else
case find (`notElem` globs) (expectedGlobalVals unitTest) of
Just (globname,val) ->
case lookup globname globs of
Nothing ->
FailureResult name ("expected global " ++ globname ++ " to have final value of " ++
(lslValString val) ++ ", but no such global was found")
(msgLog w)
Just val' ->
FailureResult name ("expected global " ++ globname ++ " to have final value of " ++
(lslValString val) ++ ", but actually had value of " ++
(lslValString val')) (msgLog w)
Nothing -> SuccessResult name (msgLog w)
--------------------------------------------------
-- 'Interactive' testing
data TestEvent = TestComplete TestResult | TestSuspended ExecutionInfo | AllComplete
data ExecCommand = ExecContinue [Breakpoint] | ExecStep [Breakpoint] | ExecStepOver [Breakpoint] |
ExecStepOut [Breakpoint]
breakpointsFromCommand (ExecContinue bps) = bps
breakpointsFromCommand (ExecStep bps) = bps
breakpointsFromCommand (ExecStepOver bps) = bps
breakpointsFromCommand (ExecStepOut bps) = bps
hasFunc :: [(String,Validity LModule)] -> (String,String) -> Either String Bool
hasFunc lib (moduleName,functionName) =
case converted of
Left s -> Left ("no such module: " ++ moduleName)
Right (Left s) -> Left ("no such module: " ++ moduleName)
Right (Right (script,path)) -> Right $ isJust (findFunc functionName $ scriptFuncs script)
where converted = evalState (runErrorT (convertEntryPoint ep)) world
ep = ModuleFunc moduleName functionName
world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib,
expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager }
simFunc :: [(String,Validity LModule)] -> (String,String) -> [(String,LSLValue)] -> [LSLValue] -> Either String (LSLValue,[(String,LSLValue)])
simFunc lib (moduleName,functionName) globs args =
let world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib,
expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager }
ep = ModuleFunc moduleName functionName
init = runState (runErrorT (
do converted <- convertEntryPoint ep
case converted of
Left s -> fail s
Right (script,path) ->
do result <- runEval (setupSimple path globs args) exec
case result of
(Left s, _) -> fail s
(Right (), exec') -> return exec'
where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world
in case init of
(Left s, world') -> Left s
(Right exec,world') ->
case (runState $ runErrorT $ (runStateT $ runErrorT $ evalSimple 10000) exec) world of
(Left s,_) -> Left s
(Right r, _) ->
case r of
(Left s,_) -> Left s
(Right (EvalComplete newState, Just val), exec') -> Right (val,glob $ scriptImage exec')
(Right (EvalComplete newState, _),_) -> Left "execution error"
(Right (EvalIncomplete,_),_) -> Left "execution error: timeout"
(Right _,_) -> Left "execution error"
simSome exec world = runState (runErrorT (
do maxTick <- getMaxTick
(runStateT $ runErrorT $ evalSimple maxTick) exec)) world
-- no more tests, not currently executing
simStep _ _ ([], Nothing) _ = (AllComplete,([],Nothing))
-- not currently executing, more tests
simStep scripts lib (unitTest:tests, Nothing) command =
let world = (SimpleWorld { maxTick = 10000, tick = 0, msgLog = [],
wScripts = scripts, wLibrary = lib, expectations = (expectedCalls unitTest),
breakpointManager = emptyBreakpointManager})
ep = entryPoint unitTest
globs = initialGlobs unitTest
args = arguments unitTest
name = unitTestName unitTest
init = runState (runErrorT (
do converted <- convertEntryPoint ep
case converted of
Left s -> fail s
Right (script,path) ->
do result <- runEval (setupSimple path globs args) exec
case result of
(Left s, _) -> fail s
(Right (),exec') -> return exec'
where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world
in case init of
(Left s,world') -> (TestComplete $ ErrorResult name s [],(tests, Nothing))
(Right exec,world') -> simStep scripts lib (unitTest:tests, Just (world',exec)) command
-- currently executing
simStep _ _ (unitTest:tests, Just (world,exec)) command =
let name = unitTestName unitTest
breakpoints = breakpointsFromCommand command
world' = world { breakpointManager = replaceBreakpoints breakpoints (breakpointManager world) }
updateStepManager f ex = let img = scriptImage ex
stepMgr = stepManager img in ex { scriptImage = img { stepManager = f stepMgr } }
execNew = case command of
ExecStep _ -> updateStepManager setStepBreakpoint exec
ExecStepOver _ -> updateStepManager setStepOverBreakpoint exec
ExecStepOut _ -> updateStepManager setStepOutBreakpoint exec
_ -> exec
in
case simSome execNew world' of
(Left s,world'') -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing))
(Right res,world'') ->
case res of
(Left s,_) -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing))
(Right (EvalComplete newState,Just val), exec') -> (TestComplete checkedResult, (tests,Nothing))
where checkedResult = checkResults (newState, val, glob $ scriptImage exec', world'') unitTest
(Right (EvalIncomplete,_),_) -> (TestComplete $ Timeout name (msgLog world''),(tests,Nothing))
(Right (BrokeAt bp,_),exec') ->
(TestSuspended (ExecutionInfo file line frames),(unitTest:tests,Just (world'',exec')))
where file = breakpointFile bp
line = breakpointLine bp
frames = frameInfo (scriptImage exec')