diff --git a/LslPlus.cabal b/LslPlus.cabal --- a/LslPlus.cabal +++ b/LslPlus.cabal @@ -1,5 +1,5 @@ Name: LslPlus -version: 0.3.1 +version: 0.3.2 Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, @@ -66,8 +66,6 @@ Language.Lsl.Internal.Util Language.Lsl.Internal.WorldState Language.Lsl.Internal.XmlCreate - Language.Lsl.NewUnitTest - Language.Lsl.NewUnitTestEnv Language.Lsl.Parse Language.Lsl.QQ Language.Lsl.Render diff --git a/src/Data/Generics/Extras/Schemes.hs b/src/Data/Generics/Extras/Schemes.hs --- a/src/Data/Generics/Extras/Schemes.hs +++ b/src/Data/Generics/Extras/Schemes.hs @@ -1,7 +1,11 @@ {-# LANGUAGE Rank2Types #-} module Data.Generics.Extras.Schemes ( downup, - everythingTwice + downupSkipping, + everythingTwice, + everythingButTwice, + everythingBut, + everywhereButM ) where ------------------------------------------------------------------------------ @@ -10,6 +14,10 @@ import Data.Generics.Aliases import Control.Monad +everythingButTwice :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r -> GenericQ r +everythingButTwice q k def f g x | q x = def + | otherwise = (foldl k (f x) (gmapQ (everythingButTwice q k def f g) x) `k` (g x)) + everythingTwice :: (r -> r -> r) -> GenericQ r -> GenericQ r -> GenericQ r everythingTwice k f g x = foldl k (f x) (gmapQ (everythingTwice k f g) x) `k` (g x) @@ -20,3 +28,21 @@ downup down up x = do x' <- down x x'' <- gmapM (downup down up) x' up x'' + +downupSkipping :: Monad m => GenericQ Bool -> GenericM m -> GenericM m -> GenericM m +downupSkipping skip down up x | skip x = return x + | otherwise = do x' <- down x + x'' <- gmapM (downupSkipping skip down up) x' + up x'' + +-- | Monadic variation on everywhere +everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m + +-- Bottom-up order is also reflected in order of do-actions +everywhereButM p f x | p x = return x + | otherwise = do x' <- gmapM (everywhereButM p f) x + f x' + +everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r +everythingBut p k def f x | p x = def + | otherwise = foldl k (f x) (gmapQ (everythingBut p k def f) x) diff --git a/src/Language/Lsl/Internal/BuiltInModules.hs b/src/Language/Lsl/Internal/BuiltInModules.hs --- a/src/Language/Lsl/Internal/BuiltInModules.hs +++ b/src/Language/Lsl/Internal/BuiltInModules.hs @@ -3,8 +3,14 @@ import Language.Lsl.Syntax import Language.Lsl.QQ(lslm) +import Language.Lsl.Internal.Constants(lslPlusAvatarKey,lslPlusAvatarPos,lslPlusAvatarRot,lslPlusAvatarName) avEventGenAST = [$lslm|$module + integer LSLPLUS_AVATAR_KEY = $integer:lslPlusAvatarKey; + integer LSLPLUS_AVATAR_POS = $integer:lslPlusAvatarPos; + integer LSLPLUS_AVATAR_ROT = $integer:lslPlusAvatarRot; + integer LSLPLUS_AVATAR_NAME= $integer:lslPlusAvatarName; + string mkTouch(string primKey, float duration) { return "AvatarTouch {avatarTouchPrimKey = \"" + primKey + "\", avatarTouchDuration = " + (string) duration + "}"; } diff --git a/src/Language/Lsl/Internal/Constants.hs b/src/Language/Lsl/Internal/Constants.hs --- a/src/Language/Lsl/Internal/Constants.hs +++ b/src/Language/Lsl/Internal/Constants.hs @@ -574,3 +574,10 @@ case findConstant s of Nothing -> False _ -> True + + +-- non LSL (lslPlus only) constants +lslPlusAvatarKey = 0 +lslPlusAvatarPos = 1 +lslPlusAvatarRot = 2 +lslPlusAvatarName = 3 diff --git a/src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs b/src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs --- a/src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs +++ b/src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs @@ -24,7 +24,7 @@ (er,contents5) <- findElement expectedReturnElement contents4 (gb,contents6) <- findElement initialBindingsElement contents5 (fb,[]) <- findElement finalBindingsElement contents6 - return $ LSLUnitTest { + return LSLUnitTest { unitTestName = nm, entryPoint = ep, initialGlobs = gb, @@ -136,7 +136,7 @@ "normal" -> return Normal s -> fail ("illegal mode " ++ s) (calls,[]) <- findElement callsElement contents1 - return $ FuncCallExpectations { + return FuncCallExpectations { expectationMode = mode, callList = filter (not . null . fst . fst) calls } diff --git a/src/Language/Lsl/Internal/Exec.hs b/src/Language/Lsl/Internal/Exec.hs --- a/src/Language/Lsl/Internal/Exec.hs +++ b/src/Language/Lsl/Internal/Exec.hs @@ -105,7 +105,7 @@ result <- (runEval $ evalScript maxTick queue) state case result of (Left s,_) -> return $ Left s - (Right queue',evalState) -> return $ Right $ (scriptImage evalState, queue') + (Right queue',evalState) -> return $ Right (scriptImage evalState, queue') -- The state of evaluation for a script. data EvalState m a = EvalState { @@ -545,7 +545,7 @@ [] -> fail ("label " ++ name ++ " not found") ((m,l):ss') -> case findLBlock name l of - Just (LBlock _ stmts) -> return $ (n,stmts) + Just (LBlock _ stmts) -> return (n,stmts) Nothing -> do setCallStack (frame { frameStacks = (ss',es) }:frames) f (n + 1) @@ -657,7 +657,7 @@ if curState /= newState -- the event queue gets cleared, with the state exit/entry events added. then return [Event "state_exit" [] $ M.singleton "last_state" (SVal curState), - Event "state_entry" [] $ M.empty] + Event "state_entry" [] M.empty] else return queue EvalComplete _ -> setExecutionState Waiting >> return queue YieldTil i -> setExecutionState (SleepingTil i) >> return queue @@ -735,7 +735,7 @@ Nothing -> (IntLit 1) Just expr2 -> ctxItem expr2 pushElement (EvLoop expr (mexpr3) stmt) - pushElement (EvExpr $ expr) + pushElement (EvExpr expr) pushElements [EvDiscard, EvExpr (ListExpr mexpr1)] continue EvStatement (Compound ss) -> diff --git a/src/Language/Lsl/Internal/ExpressionHandler.hs b/src/Language/Lsl/Internal/ExpressionHandler.hs --- a/src/Language/Lsl/Internal/ExpressionHandler.hs +++ b/src/Language/Lsl/Internal/ExpressionHandler.hs @@ -302,9 +302,9 @@ (LLList,SVal s) -> return $ LVal [SVal s] (LLKey,SVal s) -> return $ KVal s (LLKey,KVal s) -> return $ KVal s - (LLVector, (VVal _ _ _)) -> return $ v - (LLRot, (RVal _ _ _ _)) -> return $ v - (LLList, LVal l) -> return $ v + (LLVector, (VVal _ _ _)) -> return v + (LLRot, (RVal _ _ _ _)) -> return v + (LLList, LVal l) -> return v _ -> fail "invalid cast!" evalExpr expr = fail "expression not valid in this context" diff --git a/src/Language/Lsl/Internal/InternalLLFuncs.hs b/src/Language/Lsl/Internal/InternalLLFuncs.hs --- a/src/Language/Lsl/Internal/InternalLLFuncs.hs +++ b/src/Language/Lsl/Internal/InternalLLFuncs.hs @@ -359,7 +359,7 @@ else VVal (x/sinVal) (y/sinVal) (z/sinVal) in continueWith $ v -llAxisAngle2Rot _ [vval@(VVal x y z), FVal r] = return (axisAngleToRotation (vVal2Vec vval) r) >>= continueWith . rot2RVal +llAxisAngle2Rot _ [vval@(VVal x y z), FVal r] = (continueWith . rot2RVal) (axisAngleToRotation (vVal2Vec vval) r) llAxes2Rot _ [VVal xf yf zf, VVal xl yl zl, VVal xu yu zu] = let (x,y,z,s) = matrixToQuaternion ((xf,xl,xu),(yf,yl,yu),(zf,zl,zu)) in @@ -383,7 +383,7 @@ let (x',y',z',s) = rotationsToQuaternion P123 (x,y,z) in continueWith $ RVal x' y' z' s -llRotBetween n [v0@(VVal x1 y1 z1),v1@(VVal x2 y2 z2)] = return (rotationBetween (vVal2Vec v0) (vVal2Vec v1)) >>= continueWith . rot2RVal +llRotBetween n [v0@(VVal x1 y1 z1),v1@(VVal x2 y2 z2)] = (continueWith . rot2RVal) (rotationBetween (vVal2Vec v0) (vVal2Vec v1)) llAngleBetween _ [RVal aX aY aZ aS,RVal bX bY bZ bS] = continueWith $ FVal $ 2 * acos ((aX * bX + aY * bY + aZ * bZ + aS * bS) diff --git a/src/Language/Lsl/Internal/Optimize.hs b/src/Language/Lsl/Internal/Optimize.hs --- a/src/Language/Lsl/Internal/Optimize.hs +++ b/src/Language/Lsl/Internal/Optimize.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -XStandaloneDeriving -XNoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -XStandaloneDeriving -XNoMonomorphismRestriction -fwarn-unused-binds #-} module Language.Lsl.Internal.Optimize(optimizeScript,OptimizerOption(..)) where import Control.Monad.State hiding (State) @@ -7,7 +7,7 @@ import Data.Bits((.&.),(.|.),xor,shiftL,shiftR,complement) import Data.Generics -import Data.Generics.Extras.Schemes(everythingTwice,downup) +import Data.Generics.Extras.Schemes(everythingTwice,everythingButTwice,downup,downupSkipping,everywhereButM,everythingBut) import Data.List(foldl',nub,lookup) import Data.Graph import qualified Data.Set as Set @@ -22,7 +22,7 @@ import Language.Lsl.Internal.OptimizerOptions(OptimizerOption(..)) import Language.Lsl.Syntax(CompiledLSLScript(..),Expr(..),Statement(..),Var(..), Func(..),FuncDec(..),State(..),Ctx(..),Handler(..), - Global(..),Component(..),SourceContext(..),rewriteCtxExpr) + Global(..),Component(..),SourceContext(..)) import Language.Lsl.Internal.Type(LSLType(..),toSVal) import Language.Lsl.Internal.Pragmas(Pragma(..)) import Language.Lsl.Internal.Type(LSLValue(..)) @@ -30,8 +30,6 @@ optionInlining = elem OptimizationInlining --- deriving instance (Show a) => Show (SCC a) - optimizeScript :: [OptimizerOption] -> CompiledLSLScript -> CompiledLSLScript optimizeScript options script@(CompiledLSLScript gs fsIn ss) = CompiledLSLScript gsReachable fsReachable ss1 where inline = optionInlining options @@ -77,19 +75,19 @@ varNameInList = (:[]) . varName varsDefinedByHandler :: Handler -> [String] -varsDefinedByHandler = everything (++) ([] `mkQ` varNameInList) +varsDefinedByHandler = everythingBut stopCondition (++) [] ([] `mkQ` varNameInList) varsDefinedByFunc :: Ctx Func -> [String] -varsDefinedByFunc = everything (++) ([] `mkQ` varNameInList) +varsDefinedByFunc = everythingBut stopCondition (++) [] ([] `mkQ` varNameInList) labels (Label nm) = [nm] labels _ = [] labelsDefinedByFunc :: Ctx Func -> [String] -labelsDefinedByFunc = everything (++) ([] `mkQ` labels) +labelsDefinedByFunc = everythingBut stopCondition (++) [] ([] `mkQ` labels) labelsDefinedByHandler :: Handler -> [String] -labelsDefinedByHandler = everything (++) ([] `mkQ` labels) +labelsDefinedByHandler = everythingBut stopCondition (++) [] ([] `mkQ` labels) namesDefinedByHandler :: Handler -> [String] namesDefinedByHandler handler = labelsDefinedByHandler handler ++ varsDefinedByHandler handler @@ -102,33 +100,18 @@ exprCallsFuncDirectly _ = [] funcCallsFuncs :: Ctx Func -> [String] -funcCallsFuncs = everything (++) ([] `mkQ` exprCallsFuncDirectly) +funcCallsFuncs = everythingBut stopCondition (++) [] ([] `mkQ` exprCallsFuncDirectly) -stateCallsFuncs :: State -> [String] -stateCallsFuncs = everything (++) ([] `mkQ` exprCallsFuncDirectly) - handlerCallsFuncs :: Handler -> [String] -handlerCallsFuncs = everything (++) ([] `mkQ` exprCallsFuncDirectly) +handlerCallsFuncs = everythingBut stopCondition (++) [] ([] `mkQ` exprCallsFuncDirectly) fname (Ctx _ (Func (FuncDec (Ctx _ name) _ _) _)) = name -fstmts (Ctx _ (Func _ stmts)) = stmts graphInfo :: [Ctx Func] -> [SCC (Ctx Func)] graphInfo funcs = scc where edges = (map (\ f -> (f, fname f, funcCallsFuncs f)) funcs) scc = stronglyConnComp edges - acyc = [ f | AcyclicSCC f <- scc] - cyc = [ l | CyclicSCC l <- scc] -newNames seed curNames verbotenNames = foldl' newName (seed,[]) curNames - where newName (n,renames) name = - if name `notElem` verbotenNames - then (n,(name,name):renames) - else if nm `notElem` verbotenNames - then (n+1,(name,nm):renames) - else newName (n+1,renames) name - where nm = "_" ++ show n ++ "inl" - nullCtx :: a -> Ctx a nullCtx = Ctx Nothing @@ -196,7 +179,6 @@ else mkName s -- make another... putRetVar s = get >>= ( \ os -> put os { optRetVar = Just s }) -clearRetVar s = get >>= (\ os -> put os { optRetVar = Nothing }) addVerboten name = do st <- get @@ -222,18 +204,17 @@ st <- get put st { optVerbotenNames = Set.insert s (optVerbotenNames st) } return s - -pushInlinerScope = do + +withInlinerScope action = do st <- get - put st { optInlinerRenames = M.empty : (optInlinerRenames st) } -popInlinerScope = do + let rn = optInlinerRenames st + put st { optInlinerRenames = M.empty : rn } + r <- action st <- get - case optInlinerRenames st of - [] -> error "cannot pop inliner scope" - (top:rest) -> put st { optInlinerRenames = rest } - + put st { optInlinerRenames = rn } + return r + renameToNewInInliner s = do - --verboten <- isVerboten s verboten <- get >>= return . (Set.member s) . optGlobalNames if verboten then do @@ -278,8 +259,7 @@ stmts <- inlineStmts endLabel (map ctxItem ss) >>= return . map nullCtx >>= return . withoutFinalJumpTo endLabel return (if jumpsTo endLabel stmts == 0 then [] else [nullCtx $ Label endLabel], parmVars ++ stmts) -- simplify $ nullCtx (Compound (parmVars ++ stmts))) - where ft = funcType fd - ps = funcParms fd + where ps = funcParms fd mkParmVars :: [Ctx Statement] -> [(Ctx Var,Ctx Expr)] -> OState [Ctx Statement] mkParmVars ss ves = mapM (mkParmVar ss) ves >>= return . concat @@ -298,8 +278,6 @@ where simpleRef (Ctx _ (Get (_,All))) = True simpleRef _ = False -printStatement s = show s ++ "\n" - inlineFunc :: Ctx Func -> [Ctx Expr] -> OState (Expr,[Ctx Statement]) inlineFunc f@(Ctx _ (Func (FuncDec _ t _) _)) args | t == LLVoid = error "cannot inline a void function in a context that requires a value (internal error!)" @@ -327,18 +305,18 @@ retVar <- get >>= return . optRetVar (renames,rewrites) <- getRewriteInfo case retVar of - Nothing -> return (Do (rewriteCtxExpr' renames rewrites expr):Jump endLabel:stmts') + Nothing -> return (Do (rewriteCtxExpr renames rewrites expr):Jump endLabel:stmts') Just rv -> - return (Do (nullCtx (Set (nullCtx rv,All) (rewriteCtxExpr' renames rewrites expr))):Jump endLabel:stmts') + return (Do (nullCtx (Set (nullCtx rv,All) (rewriteCtxExpr renames rewrites expr))):Jump endLabel:stmts') inlineStmts endLabel (Decl v mexpr:stmts) = do v' <- renameVar v (renames,rewrites) <- getRewriteInfo stmts' <- inlineStmts endLabel stmts - return (Decl v' (fmap (rewriteCtxExpr' renames rewrites) mexpr):stmts') + return (Decl v' (fmap (rewriteCtxExpr renames rewrites) mexpr):stmts') inlineStmts endLabel (Do expr:stmts) = do stmts' <- inlineStmts endLabel stmts (renames,rewrites) <- getRewriteInfo - return (Do (rewriteCtxExpr' renames rewrites expr):stmts') + return (Do (rewriteCtxExpr renames rewrites expr):stmts') inlineStmts endLabel (Label s:stmts) = do -- must rename the label BEFORE rewriting the rest of the statements s' <- renameToNew s @@ -359,41 +337,40 @@ (renames,rewrites) <- getRewriteInfo stmts' <- inlineStmts endLabel stmts ss <- inlineStmts endLabel [stmt] - return (While (rewriteCtxExpr' renames rewrites expr) (Compound (map nullCtx ss)) : stmts') + return (While (rewriteCtxExpr renames rewrites expr) (Compound (map nullCtx ss)) : stmts') inlineStmts endLabel (DoWhile stmt expr:stmts) = do stmts' <- inlineStmts endLabel stmts ss <- inlineStmts endLabel [stmt] (renames,rewrites) <- getRewriteInfo - return (DoWhile (Compound (map nullCtx ss)) (rewriteCtxExpr' renames rewrites expr) : stmts') + return (DoWhile (Compound (map nullCtx ss)) (rewriteCtxExpr renames rewrites expr) : stmts') inlineStmts endLabel (For es0 e es1 stmt:stmts) = do (renames,rewrites) <- getRewriteInfo - let rewriteExprs = map (rewriteCtxExpr' renames rewrites) + let rewriteExprs = map (rewriteCtxExpr renames rewrites) stmts' <- inlineStmts endLabel stmts ss <- inlineStmts endLabel [stmt] let body = case ss of s:[] -> s _ -> Compound (map nullCtx ss) - return (For (rewriteExprs es0) (fmap (rewriteCtxExpr' renames rewrites) e) (rewriteExprs es1) body: stmts') + return (For (rewriteExprs es0) (fmap (rewriteCtxExpr renames rewrites) e) (rewriteExprs es1) body: stmts') inlineStmts endLabel (If e s0 s1:stmts) = do (renames,rewrites) <- getRewriteInfo stmts' <- inlineStmts endLabel stmts s0s <- inlineStmts endLabel [s0] s1s <- inlineStmts endLabel [s1] - return (If (rewriteCtxExpr' renames rewrites e) (Compound (map nullCtx s0s)) (Compound (map nullCtx s1s)) : stmts') + return (If (rewriteCtxExpr renames rewrites e) (Compound (map nullCtx s0s)) (Compound (map nullCtx s1s)) : stmts') runInliningOnFunc :: M.Map String FunctionFacts -> [Ctx Func] -> [Global] -> Ctx Func -> Ctx Func runInliningOnFunc ff fs gs f = if noinlining f then f else evalState (performInliningOnFunc f) (freshOptimizerState ff fs (map (\ (GDecl (Var nm _) _) -> nm) gs)) performInliningOnFunc :: Ctx Func -> OState (Ctx Func) -performInliningOnFunc f@(Ctx ctx (Func (FuncDec nm t parms) stmts)) = do - pushInlinerScope - parms' <- mapM renameParm parms - st <- get - put st { optVerbotenNames = Set.fromList verbotenNames, optLocals = [map (\ (Ctx _ v) -> varName v) parms'] } - stmts' <- mapM performInliningForStmt stmts - popInlinerScope - return (Ctx ctx (Func (FuncDec nm t parms') $ concat stmts')) +performInliningOnFunc f@(Ctx ctx (Func (FuncDec nm t parms) stmts)) = + withInlinerScope $ do + parms' <- mapM renameParm parms + st <- get + put st { optVerbotenNames = Set.fromList verbotenNames, optLocals = [map (\ (Ctx _ v) -> varName v) parms'] } + stmts' <- mapM performInliningForStmt stmts + return (Ctx ctx (Func (FuncDec nm t parms') $ concat stmts')) where verbotenNames = namesDefinedByFunc f renameParm (Ctx _ (Var nm t)) = do nm' <- renameToNewInInliner nm @@ -404,14 +381,13 @@ evalState (performInliningOnHandler h) (freshOptimizerState ff fs (map (\ (GDecl (Var nm _) _) -> nm) gs)) performInliningOnHandler :: Handler -> OState Handler -performInliningOnHandler h@(Handler nm parms stmts) = do - pushInlinerScope - parms' <- mapM renameParm parms - st <- get - put st { optVerbotenNames = Set.fromList verbotenNames, optLocals = [map (\ (Ctx _ v) -> varName v) parms] } - stmts' <- mapM performInliningForStmt stmts - popInlinerScope - return (Handler nm parms' (concat stmts')) +performInliningOnHandler h@(Handler nm parms stmts) = + withInlinerScope $ do + parms' <- mapM renameParm parms + st <- get + put st { optVerbotenNames = Set.fromList verbotenNames, optLocals = [map (\ (Ctx _ v) -> varName v) parms] } + stmts' <- mapM performInliningForStmt stmts + return (Handler nm parms' (concat stmts')) where verbotenNames = namesDefinedByHandler h renameParm (Ctx _ (Var nm t)) = do nm' <- renameToNewInInliner nm @@ -433,15 +409,14 @@ stmts <- removeOStateStmts return (stmts ++ [nullCtx (Do expr')]) performInliningForStmt s@(Ctx _ (Compound ss)) = do - pushInlinerScope - refreshOState - st <- get - let locals = optLocals st - put st { optLocals = []:locals } - sss <- mapM performInliningForStmt ss - put st { optLocals = locals } - popInlinerScope - return [(nullCtx (Compound (concat sss)))] + withInlinerScope $ do + refreshOState + st <- get + let locals = optLocals st + put st { optLocals = []:locals } + sss <- mapM performInliningForStmt ss + put st { optLocals = locals } + return [(nullCtx (Compound (concat sss)))] performInliningForStmt (Ctx _ (While expr s)) = do refreshOState bgnLoop <- mkName "bgnLoop" @@ -483,7 +458,6 @@ [s''] -> ctxItem s'' ss' -> Compound ss' return [nullCtx $ DoWhile s' expr'] - --return ((nullCtx $ Label bgnLoop) : (ss ++ stmts ++ [nullCtx $ If expr' (Jump bgnLoop) NullStmt])) performInliningForStmt (Ctx _ (For ies1 mte ses2 s)) = do refreshOState bgnLoop <- mkName "bgnLoop" @@ -530,7 +504,11 @@ return (expr',stmts) inlineExpr :: Ctx Expr -> OState (Ctx Expr) -inlineExpr = everywhereM (mkM inlineCall `extM` renameRef) +inlineExpr = everywhereButM (False `mkQ` string `extQ` srcContext) (mkM inlineCall `extM` renameRef) + where string :: String -> Bool + string _ = True + srcContext :: SourceContext -> Bool + srcContext _ = True inlineCall c@(Call (Ctx _ nm) es) = do fs <- get >>= return . optAllFuncs @@ -576,8 +554,8 @@ where go :: Expr -> Int go e = 1 -rewriteCtxExpr' :: (M.Map String String) -> (M.Map String Expr) -> Ctx Expr -> Ctx Expr -rewriteCtxExpr' renames rewrites = everywhere' (mkT rwName `extT` rwExpr) +rewriteCtxExpr :: (M.Map String String) -> (M.Map String Expr) -> Ctx Expr -> Ctx Expr +rewriteCtxExpr renames rewrites = everywhere' (mkT rwName `extT` rwExpr) where rwExpr e@(Get (Ctx _ nm,All)) = case M.lookup nm rewrites of @@ -689,9 +667,11 @@ isImpure consts ff f = evalState (go f) [] where go :: Ctx Func -> NamesState Bool - go = everythingTwice (liftM2 (||)) (return False `mkQ` cvt (funcDecIn nameStateScopeFuncs) False `extQ` - cvt (stmtIn nameStateScopeFuncs) False `extQ` call `extQ` ref nameStateScopeFuncs) - (return False `mkQ` cvt (stmtOut nameStateScopeFuncs) False) + go = everythingButTwice (False `mkQ` string `extQ` srcContext) + (liftM2 (||)) (return False) + (return False `mkQ` cvt (funcDecIn nameStateScopeFuncs) False `extQ` + cvt (stmtIn nameStateScopeFuncs) False `extQ` call `extQ` ref nameStateScopeFuncs) + (return False `mkQ` cvt (stmtOut nameStateScopeFuncs) False) call c@(Call nm _) = do case M.lookup (ctxItem nm) ff of Just (FunctionFacts { isPureFunction = False }) -> return True @@ -702,7 +682,36 @@ locals <- sfVars sfs return (nm `notElem` locals && (not $ isConst nm)) isConst nm = (nm `Set.member` consts) || (nm `elem` map constName allConstants) + string :: String -> Bool + string _ = True + srcContext :: SourceContext -> Bool + srcContext _ = True + +arentConstants :: Data a => [String] -> [a] -> [String] +arentConstants l xs = nub (evalState (arentConstantsM l xs) []) +arentConstantsM :: (Data a) => [String] -> [a] -> NamesState [String] +arentConstantsM l = everythingButTwice (False `mkQ` string) (liftM2 (++)) (return []) + (return [] `mkQ` cvt (funcDecIn sfs) [] `extQ` + cvt (stmtIn sfs) [] `extQ` modified `extQ` cvt (handlerDecIn sfs) []) + (return [] `mkQ` cvt (funcDecOut sfs) [] `extQ` + cvt (handlerDecOut sfs) [] `extQ` cvt (stmtOut sfs) []) + where sfs = nameStateScopeFuncs + checkNm nm = (sfVars sfs) >>= return . ((nm `elem` l) &&) . (notElem nm) >>= \ b -> if b then return [nm] else return [] + modified (Set (Ctx _ nm,_) _) = checkNm nm + modified (IncBy (Ctx _ nm,_) _) = checkNm nm + modified (DecBy (Ctx _ nm,_) _) = checkNm nm + modified (MulBy (Ctx _ nm,_) _) = checkNm nm + modified (DivBy (Ctx _ nm,_) _) = checkNm nm + modified (ModBy (Ctx _ nm,_) _) = checkNm nm + modified (PreDec (Ctx _ nm,_)) = checkNm nm + modified (PreInc (Ctx _ nm,_)) = checkNm nm + modified (PostDec (Ctx _ nm,_)) = checkNm nm + modified (PostInc (Ctx _ nm,_)) = checkNm nm + modified _ = return [] + string :: String -> Bool + string _ = True + isConstant :: Data a => String -> [a] -> Bool isConstant s xs = not $ evalState (isntConstantM s xs) [] @@ -725,8 +734,38 @@ modified (PostInc (Ctx _ nm,_)) = checkNm nm modified _ = return False -reachableGlobs gs fs ss = [ g | g@(GDecl (Var nm _) _) <- gs, (nm `isUsedIn` fs || nm `isUsedIn` ss)] +areUsedIn :: Data a => [String] -> a -> [String] +areUsedIn l v = + nub (evalState + (everythingButTwice (False `mkQ` string `extQ` sourceContext `extQ` expr `extQ` funcDec `extQ` comp) + (liftM2 (++)) (return []) + (return [] `mkQ` cvt (funcDecIn sfs) [] `extQ` + cvt (stmtIn sfs) [] `extQ` used `extQ` cvt (handlerDecIn sfs) []) + (return [] `mkQ` cvt (funcDecOut sfs) [] `extQ` + cvt (handlerDecOut sfs) [] `extQ` cvt (stmtOut sfs) []) v) []) + where sfs = nameStateScopeFuncs + used :: (Ctx String,Component) -> NamesState [String] + used (Ctx _ nm,_) = (sfVars sfs) >>= \ vs -> return (if nm `elem` l && nm `notElem` vs then [nm] else []) + string :: String -> Bool + string _ = True + sourceContext :: SourceContext -> Bool + sourceContext _ = True + expr :: Expr -> Bool + expr (IntLit _) = True + expr (FloatLit _) = True + expr (KeyLit _) = True + expr (StringLit _) = True + expr _ = False + funcDec :: FuncDec -> Bool + funcDec _ = True + comp :: Component -> Bool + comp _ = True +reachableGlobs gs fs ss = [ g | g@(GDecl (Var nm _) _) <- gs, nm `elem` reachableNames] + where reachableNames = (gnms `areUsedIn` ss) ++ (gnms `areUsedIn` fs) + gnms = [ nm | g@(GDecl (Var nm _) _) <- gs] +--reachableGlobs gs fs ss = [ g | g@(GDecl (Var nm _) _) <- gs, (nm `isUsedIn` fs || nm `isUsedIn` ss)] + isUsedIn :: Data a => String -> a -> Bool isUsedIn s v = evalState @@ -741,8 +780,10 @@ globalConstants :: [Global] -> [Ctx Func] -> [State] -> M.Map String Expr globalConstants gs fs ss = foldl globalConstant M.empty gs - where globalConstant m (GDecl (Var nm t) mexpr) = if isAConst nm then M.insert nm (mexpr2expr m t mexpr) m else m - isAConst nm = isConstant nm fs && isConstant nm ss + where globalConstant m (GDecl (Var nm t) mexpr) = if nm `notElem` nonConsts then M.insert nm (mexpr2expr m t mexpr) m else m + nonConsts = arentConstants gnms fs ++ arentConstants gnms ss + gnms = [nm | (GDecl (Var nm _) _) <- gs] + -- isAConst nm = isConstant nm fs && isConstant nm ss expr2expr :: M.Map String Expr -> Expr -> Expr expr2expr m = everywhere (mkT go) where go e@(Get (nm,All)) = case M.lookup (ctxItem nm) m of @@ -767,9 +808,6 @@ fromBool :: Num a => Bool -> a fromBool x = if x then 1 else 0 -liftBool :: Monad m => Bool -> m Expr -liftBool b = return (IntLit (fromBool b)) - data SimplificationInfo = SimplificationInfo { siScript :: !CompiledLSLScript, siPureFuncs :: !(Set.Set String), @@ -839,6 +877,7 @@ simplifyE :: Expr -> SimpState Expr simplifyE (Neg (Ctx _ (IntLit i))) = return (IntLit (-i)) simplifyE (Not (Ctx _ (IntLit i))) = return (IntLit (fromBool (i == 0))) +simplifyE (Inv (Ctx _ (IntLit i))) = return (IntLit (complement i)) simplifyE (Add (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i + j)) simplifyE (Mul (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i * j)) simplifyE (Sub (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i - j)) @@ -904,6 +943,9 @@ return $ case nameToLit m name of Nothing -> e Just e' -> case (c,e') of + (All,VecExpr _ _ _) -> e + (All,RotExpr _ _ _ _) -> e + (All,ListExpr _) -> e (All,_) -> e' (X,VecExpr x _ _) -> ctxItem x (X,RotExpr x _ _ _) -> ctxItem x @@ -936,12 +978,31 @@ simplifyE e@(Cast LLFloat (Ctx _(IntLit i))) = return (FloatLit $ fromIntegral i) simplifyE e@(Cast LLInteger (Ctx _ (FloatLit f))) = return (IntLit $ truncate f) simplifyE e@(Add (Ctx _ (StringLit s0)) (Ctx _ (StringLit s1))) = return (StringLit (s0 ++ s1)) +simplifyE e@(VecExpr eX eY eZ) = return (VecExpr (toFloatLit eX) (toFloatLit eY) (toFloatLit eZ)) +simplifyE e@(RotExpr eX eY eZ eS) = return (RotExpr (toFloatLit eX) (toFloatLit eY) (toFloatLit eZ) (toFloatLit eS)) simplifyE e = return e - + +toFloatLit (Ctx c (IntLit i)) = (Ctx c (FloatLit $ fromIntegral i)) +toFloatLit e = e + simplify :: Data a => CompiledLSLScript -> Set.Set String -> M.Map String Expr -> a -> a simplify script pureFuncs gcs v = evalState (go v) (SimplificationInfo script pureFuncs gcs []) where go :: Data a => a -> SimpState a - go = downup (mkM (stmtIn simpInfoScopeFuncs) `extM` funcDecIn simpInfoScopeFuncs `extM` handlerDecIn simpInfoScopeFuncs) + go = downupSkipping (False `mkQ` string `extQ` srcContext) + (mkM (stmtIn simpInfoScopeFuncs) `extM` funcDecIn simpInfoScopeFuncs `extM` handlerDecIn simpInfoScopeFuncs) (mkM simplifyE `extM` stmtOut simpInfoScopeFuncs `extM` - funcDecOut simpInfoScopeFuncs `extM` handlerDecOut simpInfoScopeFuncs) + funcDecOut simpInfoScopeFuncs `extM` handlerDecOut simpInfoScopeFuncs) + string :: String -> Bool + string _ = True + srcContext :: SourceContext -> Bool + srcContext _ = True + +string :: String -> Bool +string _ = True + +srcContext :: SourceContext -> Bool +srcContext _ = True + +stopCondition :: Data a => a -> Bool +stopCondition = (False `mkQ` string `extQ` srcContext) diff --git a/src/Language/Lsl/Internal/Type.hs b/src/Language/Lsl/Internal/Type.hs --- a/src/Language/Lsl/Internal/Type.hs +++ b/src/Language/Lsl/Internal/Type.hs @@ -213,9 +213,9 @@ "key" -> simple e >>= return . KVal "int" -> simple e >>= readM >>= return . IVal "float" -> simple e >>= readM >>= return . FVal - "vector" -> acceptVector e >>= return - "rotation" -> acceptRotation e >>= return - "list" -> acceptLslList e >>= return + "vector" -> acceptVector e + "rotation" -> acceptRotation e + "list" -> acceptLslList e _ -> fail "unrecognized value element" in ElemAcceptor "value" f diff --git a/src/Language/Lsl/NewUnitTest.hs b/src/Language/Lsl/NewUnitTest.hs deleted file mode 100644 --- a/src/Language/Lsl/NewUnitTest.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Language.Lsl.NewUnitTest( - LSLUnitTest(..), - FuncCallExpectations(..), - ExpectationMode(..), - EntryPoint(..), - Binding, - expectedReturns, - removeExpectation) where - -import Control.Monad(liftM2) -import Data.List(maximumBy) -import Language.Lsl.Internal.Type(LSLValue(..)) -import Language.Lsl.Internal.Exec(Binding(..)) -import Language.Lsl.Internal.Util(removeLookup) - -data FuncCallExpectations = FuncCallExpectations { - expectationMode :: ExpectationMode, - callList :: [((String, [Maybe LSLValue]),LSLValue)] } deriving (Show) - -data ExpectationMode = Nice | Normal | Exhaust | Strict deriving (Show,Eq) - -data EntryPoint = ModuleFunc String String | ScriptFunc String String | ScriptHandler String String String - deriving (Show) - -data LSLUnitTest = LSLUnitTest { - unitTestName :: String, - entryPoint :: EntryPoint, - initialGlobs :: [Binding], - arguments :: [LSLValue], - expectedCalls :: FuncCallExpectations, - expectedReturn :: Maybe LSLValue, - expectedGlobalVals :: [Binding], - expectedNewState :: Maybe String - } deriving (Show) - -argMatch (Just x) y | lslValuesMatch x y = Just 1 - | otherwise = Nothing -argMatch Nothing _ = Just 0 -argsMatch expectArgs args = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args - -lslValuesMatch (FVal a) (FVal b) = a == b || - if a == 0.0 then b < 0.000001 - else if b == 0.0 then a < 0.000001 - else abs ((b - a) / a) < 0.000001 -lslValuesMatch x y = x == y - -matchFail :: Monad m => m a -matchFail = fail "no matching call" - -expectedReturns :: (Monad m) => String -> [LSLValue] -> FuncCallExpectations -> m ((String,[Maybe LSLValue]),LSLValue) -expectedReturns name args (FuncCallExpectations Strict (match@((name',expectArgs),returns):_)) = - if name /= name' || argsMatch expectArgs args == Nothing then matchFail - else return match -expectedReturns name args (FuncCallExpectations Strict _) = matchFail -expectedReturns n a (FuncCallExpectations mode callList) = - let rightNames = filter ((n==) . fst . fst) callList - argMatch (Just x) y | x == y = Just 1 - | otherwise = Nothing - argMatch Nothing _ = Just 0 - argsMatch args expectArgs = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args - ranked = zip (map (argsMatch a) (map (snd . fst) rightNames)) rightNames - orderMatch (Nothing,_) (Nothing,_) = EQ - orderMatch _ (Nothing,_) = GT - orderMatch (Nothing,_) _ = LT - orderMatch ((Just a),_) ((Just b),_) = compare a b - in case ranked of - [] -> fail matchFail - _ -> case maximumBy orderMatch ranked of - (Nothing,_) -> matchFail - (_,e) -> return e - -removeExpectation :: (String,[Maybe LSLValue]) -> FuncCallExpectations -> FuncCallExpectations -removeExpectation m fce = fce { callList = removeLookup m (callList fce) } diff --git a/src/Language/Lsl/NewUnitTestEnv.hs b/src/Language/Lsl/NewUnitTestEnv.hs deleted file mode 100644 --- a/src/Language/Lsl/NewUnitTestEnv.hs +++ /dev/null @@ -1,270 +0,0 @@ -module Language.Lsl.NewUnitTestEnv( - 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 validLSLScript 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 1000) 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 codebase (unitTest:tests, Nothing) command = - let world = (SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], - wScripts = (codebaseScripts codebase), wLibrary = libFromAugLib (codebaseLib codebase), - 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 codebase (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') diff --git a/src/Language/Lsl/Parse.hs b/src/Language/Lsl/Parse.hs --- a/src/Language/Lsl/Parse.hs +++ b/src/Language/Lsl/Parse.hs @@ -281,12 +281,12 @@ assignment = ctxify $ do v <- var - op <- choice [reservedOp' "+=" >> (return $ IncBy), - reservedOp' "-=" >> (return $ DecBy), - reservedOp' "*=" >> (return $ MulBy), - reservedOp' "/=" >> (return $ DivBy), - reservedOp' "%=" >> (return $ ModBy), - reservedOp' "=" >> (return $ Set)] "assignment operator" + op <- choice [reservedOp' "+=" >> (return IncBy), + reservedOp' "-=" >> (return DecBy), + reservedOp' "*=" >> (return MulBy), + reservedOp' "/=" >> (return DivBy), + reservedOp' "%=" >> (return ModBy), + reservedOp' "=" >> (return Set)] "assignment operator" e <- expr return $ op v e @@ -554,7 +554,7 @@ ------------------------------------------------------------- -- STATE parsing -stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier >>= return] +stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier] stateDecl = do name <- ctxify stateName handlers <- braces $ many handler @@ -613,7 +613,7 @@ -- IMPORT (meta-lsl directive) parsing gimport = do reserved "$import" "$import keyword" - ids <- (ctxify $ (char '$' >> identifier >>= return . (:[]) . ("$"++))) + ids <- (ctxify (char '$' >> identifier >>= return . (:[]) . ("$"++))) <|>(ctxify $ sepBy identifier dot) let id = fmap (concat . intersperse ".") ids let binding = do id0 <- identifier diff --git a/src/Language/Lsl/Sim.hs b/src/Language/Lsl/Sim.hs --- a/src/Language/Lsl/Sim.hs +++ b/src/Language/Lsl/Sim.hs @@ -3043,26 +3043,30 @@ processAvatarInputEvent k inputEvent = runAndLogIfErr "problem processing event for avatar" () $ do av <- getWorldAvatar k + let avInfo = [ IVal lslPlusAvatarKey, KVal (avatarKey av), + IVal lslPlusAvatarPos, ((vec2VVal . avatarPosition) av), + IVal lslPlusAvatarRot, ((rot2RVal . avatarRotation) av), + IVal lslPlusAvatarName, SVal (avatarName av) ] flip (maybe (return ())) (avatarEventHandler av) $ (\ (moduleName,state) -> do lib <- lift getWLibrary - case callAvatarEventProcessor k moduleName inputEvent lib state of + case callAvatarEventProcessor k moduleName inputEvent lib state avInfo of Nothing -> return () Just (Left s) -> throwError s Just (Right (LVal events,result)) -> do mapM_ (putAvatarOutputEvent k) events lift $ setWorldAvatar k (av { avatarEventHandler = Just (moduleName,result) })) -avEventProcCallInfo (AvatarOwnerSay key msg) = ("onOwnerSay",[SVal key, SVal msg]) -avEventProcCallInfo (AvatarHearsChat name key msg) = ("onChat",[SVal name, SVal key, SVal msg]) -avEventProcCallInfo (AvatarDialog msg buttons chan source) = ("onDialog",[SVal msg, LVal $ map SVal buttons, IVal chan, SVal source]) -avEventProcCallInfo (AvatarLoadURL msg url) = ("onLoadURL",[SVal msg, SVal url]) -avEventProcCallInfo (AvatarMapDestination simName position) = ("onMapDestination",[SVal simName, vec2VVal position]) -callAvatarEventProcessor k moduleName avEvent lib state = +avEventProcCallInfo (AvatarOwnerSay key msg) avInfo = ("onOwnerSay",[SVal key, SVal msg, LVal avInfo]) +avEventProcCallInfo (AvatarHearsChat name key msg) avInfo = ("onChat",[SVal name, SVal key, SVal msg, LVal avInfo]) +avEventProcCallInfo (AvatarDialog msg buttons chan source) avInfo = ("onDialog",[SVal msg, LVal $ map SVal buttons, IVal chan, SVal source, LVal avInfo]) +avEventProcCallInfo (AvatarLoadURL msg url) avInfo = ("onLoadURL",[SVal msg, SVal url, LVal avInfo]) +avEventProcCallInfo (AvatarMapDestination simName position) avInfo = ("onMapDestination",[SVal simName, vec2VVal position, LVal avInfo]) +callAvatarEventProcessor k moduleName avEvent lib state avInfo = case hasFunc lib (moduleName,funcName) of Left s -> Just (Left s) Right True -> Just $ simFunc lib (moduleName, funcName) state args Right False -> Nothing - where (funcName,args) = avEventProcCallInfo avEvent + where (funcName,args) = avEventProcCallInfo avEvent avInfo putAvatarOutputEvent k (SVal s) = case reads s of diff --git a/src/Language/Lsl/Syntax.hs b/src/Language/Lsl/Syntax.hs --- a/src/Language/Lsl/Syntax.hs +++ b/src/Language/Lsl/Syntax.hs @@ -1164,7 +1164,7 @@ [] -> do globals <- get'vsGlobals funcs <- get'vsFuncs - return $ Right $ (globals,funcs) + return $ Right (globals,funcs) _ -> return $ Left errs -- this function isn't partiuclarly efficient! diff --git a/src/Language/Lsl/UnitTestEnv.hs b/src/Language/Lsl/UnitTestEnv.hs --- a/src/Language/Lsl/UnitTestEnv.hs +++ b/src/Language/Lsl/UnitTestEnv.hs @@ -3,6 +3,7 @@ simFunc, simSFunc, hasFunc, + hasFunc1, SimpleWorld, TestEvent(..), ExecutionInfo(..), @@ -97,7 +98,7 @@ if allowed then do (_,rt,_) <- ctx ("finding predef " ++ n) $ findM (\ (n',_,_) -> n' == n) funcSigs - return $ (EvalIncomplete, defaultValue rt) + return (EvalIncomplete, defaultValue rt) else fail ("unexpected call: " ++ renderCall n a) mkScript (LModule globdefs vars) = @@ -197,6 +198,22 @@ breakpointsFromCommand (ExecStepOver bps) = bps breakpointsFromCommand (ExecStepOut bps) = bps +hasFunc1 :: [(String,Validity LModule)] -> (String,String) -> [LSLType] -> Either String Bool +hasFunc1 lib (mn,fn) parms = + case converted of + Left s -> Left ("no such module: " ++ mn) + Right (Left s) -> Left ("no such module: " ++ mn) + Right (Right (script,path)) -> + case findFunc fn (map ctxItem $ scriptFuncs script) of + Nothing -> Right False + Just (Func (FuncDec _ _ ps) _) -> + if parms == map (varType . ctxItem) ps + then Right True + else Left ("function " ++ fn ++ " has incorrect parameters") + where converted = evalState (runErrorT (convertEntryPoint (ModuleFunc mn fn))) world + world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib, + expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } + hasFunc :: [(String,Validity LModule)] -> (String,String) -> Either String Bool hasFunc lib (moduleName,functionName) = case converted of diff --git a/src/Language/Lsl/WorldDef.hs b/src/Language/Lsl/WorldDef.hs --- a/src/Language/Lsl/WorldDef.hs +++ b/src/Language/Lsl/WorldDef.hs @@ -542,7 +542,7 @@ sliceSize <- readM sliceSizeStr (m,keyIndex) <- lift SM.get let webHandling = if isNothing handler then WebHandlingByDoingNothing else WebHandlingByFunction - return $ (FullWorldDef maxTime sliceSize webHandling handler objects prims avatars (defaultRegions "") keyIndex) + return (FullWorldDef maxTime sliceSize webHandling handler objects prims avatars (defaultRegions "") keyIndex) in ElemAcceptor "world-def" f activeScriptsElement :: ElemAcceptor KeyManagerM [((String,String),String)] @@ -555,7 +555,7 @@ realPrimKey <- findRealKey primKey (scriptName, c2) <- findSimple "scriptName" c1 (scriptId, []) <- findSimple "scriptId" c2 - return $ ((realPrimKey,scriptName), scriptId) + return ((realPrimKey,scriptName), scriptId) objectsElement :: ElemAcceptor KeyManagerM [LSLObject] objectsElement = elementList "objects" objectElement @@ -595,7 +595,7 @@ (permissions, c16) <- findOrDefault [0] (elementList "permissions" (valueAcceptor "int")) c15 (dropAllowed,c17) <- findValueOrDefault False "dropAllowed" c16 (inventory,[]) <- findOrDefault [] (elementListWith "inventory" acceptInventoryItem) c17 - return $ Prim { primName = name, + return Prim { primName = name, primKey = realKey, primParent = Nothing, primDescription = description, @@ -689,7 +689,7 @@ (fullbright, c5) <- findValueOrDefault False "fullbright" c4 (textureMode, c6) <- findValueOrDefault 0 "textureMode" c5 (textureInfo, []) <- findOrDefault defaultTextureInfo (textureInfoAcceptor "textureInfo") c6 - return $ PrimFace { + return PrimFace { faceAlpha = alpha, faceColor = color, faceShininess = shininess, @@ -706,7 +706,7 @@ (repeats,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "repeats") c1 (offsets,c3) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "offsets") c2 (rotation,[]) <- findValueOrDefault 0.0 "rotation" c3 - return $ TextureInfo { + return TextureInfo { textureKey = name, textureRepeats = repeats, textureOffsets = offsets, @@ -722,7 +722,7 @@ (wind,c4) <- findValueOrDefault 0.0 "wind" c3 (tension,c5) <- findValueOrDefault 1.0 "tension" c4 (force, []) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "force") c5 - return $ Flexibility { + return Flexibility { flexSoftness = softness, flexGravity = gravity, flexFriction = friction, @@ -738,7 +738,7 @@ (intensity,c2) <- findValueOrDefault 1.0 "intensity" c1 (radius,c3) <- findValueOrDefault 10.0 "radius" c2 (falloff,[]) <- findValueOrDefault 1.0 "falloff" c3 - return $ LightInfo { + return LightInfo { lightColor = color, lightIntensity = intensity, lightRadius = radius, @@ -763,7 +763,7 @@ (skew, c13) <- findValueOrDefault 0.0 "skew" c12 (sculptTexture, c14) <- findOptionalElement (simpleElement "sculptTexture") c13 (sculptType, []) <- findValueOrDefault 0 "sculptType" c14 - return $ PrimType { + return PrimType { primVersion = version, -- 1 or 9 primTypeCode = typeCode, primHoleshape = holeshape, @@ -804,7 +804,7 @@ (x,c1) <- findValue "x" (elementsOnly contents) (y,c2) <- findValue "y" c1 (z,[]) <- findValue "z" c2 - return $ (x,y,z) + return (x,y,z) rotAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do @@ -812,10 +812,10 @@ (y,c2) <- findValue "y" c1 (z,c3) <- findValue "z" c2 (s,[]) <- findValue "s" c3 - return $ (x,y,z,s) + return (x,y,z,s) regionAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do (x,c1) <- findValue "x" (elementsOnly contents) (y,[]) <- findValue "y" (c1) - return $ (x,y) + return (x,y) diff --git a/src/LslPlus.hs b/src/LslPlus.hs --- a/src/LslPlus.hs +++ b/src/LslPlus.hs @@ -12,7 +12,7 @@ import System import System.Exit -version="0.3.1" +version="0.3.2" usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" main = do progName <- getProgName