diff --git a/LslPlus.cabal b/LslPlus.cabal --- a/LslPlus.cabal +++ b/LslPlus.cabal @@ -1,5 +1,5 @@ Name: LslPlus -version: 0.3.4 +version: 0.3.5 Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, @@ -74,6 +74,7 @@ Language.Lsl.UnitTest Language.Lsl.UnitTestEnv Language.Lsl.WorldDef + Text.Here Text.ParserCombinators.ParsecExtras.Language Text.ParserCombinators.ParsecExtras.Token Ghc-Options: -fwarn-unused-imports 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 @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XNoMonomorphismRestriction #-} +{-# OPTIONS_GHC -XNoMonomorphismRestriction -XDeriveDataTypeable #-} module Language.Lsl.Internal.Exec( ScriptImage(..), EvalState, @@ -22,7 +22,8 @@ --import Debug.Trace import Data.Bits((.&.),(.|.),xor,shiftL,shiftR,complement) -import Data.List(intersperse,find) +import Data.List(intersperse,find,intercalate) +import Data.Data import qualified Data.Map as M import Data.Maybe(isJust) @@ -49,17 +50,21 @@ findState, fromMCtx, predefFuncs, - isTextLocation) + isTextLocation, + rmCtx) import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),typeOfLSLComponent,typeOfLSLValue,toFloat,toSVal, lslShowVal,replaceLslValueComponent,vecMulScalar,rotMulVec,parseVector,parseRotation, parseInt,parseFloat,invRot,rotMul,vcross,Component(..),lslValueComponent) import Language.Lsl.Internal.Key(nullKey,nextKey) import Language.Lsl.Internal.Evaluation(EvalResult(..),Event(..),ScriptInfo(..)) import Language.Lsl.Internal.Constants(findConstVal,llcZeroRotation,llcZeroVector) +import Language.Lsl.Render import Control.Monad(foldM_,when,mplus,msum,join,zipWithM) import Control.Monad.State(lift,StateT(..)) import Control.Monad.Error(ErrorT(..)) +import Debug.Trace(trace) + -- initialize a script for execution initLSLScript :: RealFloat a => CompiledLSLScript -> ScriptImage a initLSLScript (CompiledLSLScript globals fs ss) = @@ -153,7 +158,7 @@ [] -> (Nothing,Nothing) _ -> let (_,ctx,_,_) = last frames in (ctx,Just 1) collapseFrame (Frame name ctx line (ss,_)) = - (name,ctx,line,concat $ map fst ss) + (name,ctx,line,concat $ map scopeMem ss) -- a soft reset occurs when a script that has been running, but -- has been persisted to inventory, is reactivated. The curState -- stays the same, but if the script was running or sleeping, the @@ -304,13 +309,15 @@ frameStacks :: (ScopeStack a, EvalStack) } deriving (Show) type LabelSet = [LBlock] -type Scope a = (MemRegion a,LabelSet) +--type Scope a = (MemRegion a,LabelSet) type ScopeStack a = [Scope a] type CallStack a = [Frame a] - +data Scope a = Scope { scopeMem :: !(MemRegion a), scopeLabels :: !LabelSet, scopeMarks :: Int } + deriving (Show) + readVarScope :: String -> Scope a -> Maybe (LSLValue a) -readVarScope name (mem,_) = readMem name mem +readVarScope name (Scope { scopeMem = mem }) = readMem name mem readVarSStack :: String -> ScopeStack a -> Maybe (LSLValue a) readVarSStack name ss = foldl mplus Nothing $ map (readVarScope name) ss readVarFrame :: String -> Frame a -> Maybe (LSLValue a) @@ -319,7 +326,7 @@ readVarCallStack name = (readVarFrame name) . head writeVarScope :: String -> LSLValue a -> Scope a -> Maybe (Scope a) -writeVarScope name val (mem,l) = writeMem name val mem >>= return . (flip (,) l) +writeVarScope name val s@(Scope { scopeMem = mem} ) = writeMem name val mem >>= \ mem' -> return s { scopeMem = mem' } writeVarSStack rs name val [] = Nothing writeVarSStack rs name val (s:ss) = case writeVarScope name val s of @@ -344,11 +351,9 @@ | EvCons | EvMkVec | EvMkRot | EvPop | EvReturn | EvDiscard | EvBind String LSLType | EvCond Statement Statement | EvCall String (Maybe SourceContext) [Var] [Ctx Statement] Bool - | EvPredef String | EvLoop Expr [Ctx Expr] Statement - deriving (Show) - --- Note: lifted from Hudak, p.273 ---queryState :: Monad w => (EvalState w a -> a) -> Eval w b a + | EvPredef String | EvLoop Expr [Ctx Expr] Statement | EvMark + deriving (Show,Data,Typeable) + queryState q = evalT (\s -> (q s, s)) updateState :: Monad w => (EvalState w a -> EvalState w a) -> Eval w a () updateState u = evalT (\s -> ((), u s)) @@ -430,7 +435,7 @@ pushScope mem labels = do (frame:frames) <- getCallStack let (ss,es) = frameStacks frame - setCallStack (frame { frameStacks = ((mem,labels):ss,es) }:frames) + setCallStack (frame { frameStacks = (Scope { scopeMem = mem, scopeLabels = labels, scopeMarks = 0}:ss,es) }:frames) pushVal value = do vstack <- getVStack @@ -468,12 +473,23 @@ let (ss,e:es) = frameStacks frame setCallStack (frame { frameStacks = (ss,es) }:frames) return e +getEStack :: Monad w => Eval w a [EvalElement] +getEStack = + do (frame:frames) <- getCallStack + return $ snd $ frameStacks frame popElements 0 = return () popElements n = do popElement popElements (n - 1) +popMarks 0 = return () +popMarks n = do + e <- popElement + case e of + EvMark -> popMarks (n - 1) + _ -> popMarks n + pushElement element = do (frame:frames) <- getCallStack let (ss,es) = frameStacks frame @@ -529,8 +545,8 @@ initVar1 name t mval = do --(((m,l):ss,es):cs) <- getCallStack (frame:frames) <- getCallStack - let ((m,l):ss,es) = frameStacks frame - let frame' = frame { frameStacks = (((initVar name t mval):m,l):ss,es) } + let (sc@Scope { scopeMem = m }:ss,es) = frameStacks frame + let frame' = frame { frameStacks = (sc { scopeMem = initVar name t mval:m }:ss,es) } setCallStack (frame':frames) initVars1 :: (RealFloat a, Read a, Monad w) => [Var] -> [LSLValue a] -> Eval w a () @@ -543,14 +559,23 @@ let (ss,es) = frameStacks frame case ss of [] -> fail ("label " ++ name ++ " not found") - ((m,l):ss') -> + (Scope {scopeLabels = l, scopeMarks = marks}:ss') -> case findLBlock name l of - Just (LBlock _ stmts) -> return (n,stmts) + Just (LBlock _ stmts) -> return (n + marks,stmts) Nothing -> do setCallStack (frame { frameStacks = (ss',es) }:frames) - f (n + 1) + f (n + marks + 1) in f 1 +modMark f = do + (frame:frames) <- getCallStack + let (ss,es) = frameStacks frame + case ss of + [] -> return () + (sc@Scope { scopeMarks = marks }:ss') -> do + let marks' = f marks + let sc' = sc { scopeMarks = marks' } + setCallStack (frame { frameStacks = (sc':ss',es) }:frames) data ExecutionState = Waiting | Executing | Halted | SleepingTil Int | Erroneous String | Crashed String | Suspended Breakpoint | WaitingTil Int -- in a waiting state, but won't process new events until time t @@ -590,7 +615,7 @@ initStacks pushFrame (concat $ intersperse "." path) ctx Nothing pushScope mem $ labelBlocks stmts - pushElement (EvBlock stmts) + pushElements [EvMark,EvBlock stmts] setExecutionState Executing where updateGlobals [] = return () updateGlobals ((name,val):bs) = @@ -644,7 +669,7 @@ do initStacks pushFrame name ctx Nothing pushScope mem $ labelBlocks stmts - pushElement (EvBlock stmts) + pushElements [EvMark,EvBlock stmts] setExecutionState Executing setCurrentEvent event evalScript maxTick queue' @@ -698,6 +723,7 @@ in do cs <- getCallStack vs <- getVStack + es <- getEStack noMoreElements <- elementStackEmpty if noMoreElements then popAndCheck else do @@ -708,9 +734,10 @@ logMsg ("return: " ++ lslShowVal val) popAndCheck EvBlock [] -> popScope >> eval' + EvMark -> modMark ((-)1) >> continue EvBlock (s:ss) -> pushElements [EvBlock ss,EvCtxStatement s] EvCtxStatement s -> do - pushElements [EvStatement $ ctxItem s] + pushElement (EvStatement $ ctxItem s) case srcCtx s of Just (SourceContext { srcTextLocation = txtl }) -> let bp = mkBreakpoint (textName txtl) (textLine0 txtl) 0 in @@ -727,26 +754,29 @@ continue EvStatement (Decl (Var name t) mexpr) -> pushElements [EvBind name t,EvMexpr $ fromMCtx mexpr] EvStatement (If expr stmt1 stmt2) -> pushElements [EvCond stmt1 stmt2,EvExpr $ ctxItem expr] - EvStatement (While expr stmt) -> pushElements [EvLoop (ctxItem expr) [] stmt,EvExpr $ ctxItem expr] - EvStatement (DoWhile stmt expr) -> - pushElements [EvLoop (ctxItem expr) [] stmt, EvExpr (ctxItem expr),EvStatement stmt] + EvStatement (While expr stmt) -> modMark (+1) >> pushElements [EvMark,EvLoop (ctxItem expr) [] stmt,EvExpr $ ctxItem expr] + EvStatement (DoWhile stmt expr) -> modMark (+1) >> + pushElements [EvMark,EvLoop (ctxItem expr) [] stmt, EvExpr (ctxItem expr),EvStatement stmt] EvStatement (For mexpr1 mexpr2 mexpr3 stmt) -> do let expr = case mexpr2 of Nothing -> (IntLit 1) Just expr2 -> ctxItem expr2 + modMark (+1) + pushElement EvMark pushElement (EvLoop expr (mexpr3) stmt) pushElement (EvExpr expr) pushElements [EvDiscard, EvExpr (ListExpr mexpr1)] continue EvStatement (Compound ss) -> do pushScope [] $ labelBlocks ss + pushElement EvMark pushElement (EvBlock ss) continue EvStatement (Label _) -> eval' EvStatement (Jump name) -> do (n,stmts) <- unwindToLabel name - popElements n - pushElement (EvBlock stmts) + popMarks n + pushElements [EvMark,EvBlock stmts] continue EvMexpr Nothing -> pushVal VoidVal >> continue EvMexpr (Just expr) -> pushElements [EvExpr expr] @@ -845,7 +875,7 @@ -- a void function may not have an explicit return; if it does, this -- element will get popped off without being evaluated. when voidFunc (pushElement EvReturn >> pushElement (EvMexpr Nothing)) - pushElement (EvBlock stmts) + pushElements [EvMark,EvBlock stmts] continue EvPredef name -> evalPredef' name EvGet (name,c) -> @@ -962,7 +992,7 @@ (IVal i1,FVal f2) -> toLslBool $ fromInt i1 == f2 (v1,v2) -> toLslBool $ v1 == v2 EvNe -> evalBinary $ \ val1 val2 -> case (val1,val2) of - (LVal l1, LVal l2) -> toLslBool $ length l1 /= length l2 -- special case of LSL weirdness + (LVal l1, LVal l2) -> IVal (length l1 - length l2) -- special case of LSL weirdness (SVal s, KVal k) -> toLslBool $ s /= k (KVal k, SVal s) -> toLslBool $ k /= s (FVal f1,IVal i2) -> toLslBool $ f1 /= fromInt i2 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 @@ -352,12 +352,15 @@ listStatSumSquares l = sum $ map (**2.0) l listStatGeometricMean l = product l ** (1.0 / fromInt (length l)) -llRot2Angle _ [RVal _ _ _ w] = continueWith $ FVal (2.0 * acos w) -llRot2Axis _ [RVal x y z w] = - let sinVal = sqrt (1.0 - w*w) - v = if sinVal == 0.0 then VVal 0.0 0.0 0.0 - else VVal (x/sinVal) (y/sinVal) (z/sinVal) in - continueWith $ v +normalizeQuaternion (x,y,z,w) = (x/mag,y/mag,z/mag,w/mag) + where mag = sqrt (x*x + y*y + z*z + w*w) +llRot2Angle _ [RVal x y z w] = continueWith $ FVal (2.0 * acos w') + where (_,_,_,w') = normalizeQuaternion (x,y,z,w) +llRot2Axis _ [RVal x y z w] = continueWith v + where (x',y',z',w') = normalizeQuaternion (x,y,z,w) + sinVal = sqrt (1.0 - w'*w') + v = if sinVal == 0.0 then VVal 0.0 0.0 0.0 + else VVal (x'/sinVal) (y'/sinVal) (z'/sinVal) llAxisAngle2Rot _ [vval@(VVal x y z), FVal r] = (continueWith . rot2RVal) (axisAngleToRotation (vVal2Vec vval) r) 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 @@ -37,7 +37,6 @@ scc = graphInfo fsIn funFacts = sccsPurity gcs basicFunctionFacts scc pure = Set.fromList [ nm | (nm,ff) <- M.toList funFacts, isPureFunction ff] - --pure = trace (show pure') pure' ifs = [ f | AcyclicSCC f <- scc, inlineable f] -- inlineables nifs = [ f | f <- fsIn, fname f `notElem` (map fname ifs)] -- non-inlineables ss1 = if inline then simp $ map runInliningOnState (simp ss) else ss @@ -120,7 +119,7 @@ data OptimizerState = OptimizerState { optAllFuncs :: !(M.Map String (Ctx Func)), optFunFacts :: !(M.Map String FunctionFacts), - optNameIndex :: Int, + optNameIndex :: !Int, optGlobalNames :: !(Set.Set String), optVerbotenNames :: !(Set.Set String), optLocals :: ![[String]], @@ -128,7 +127,7 @@ optRenames :: !(M.Map String String), -- names that must be renamed in the function to-be-inlined optRewrites :: !(M.Map String Expr), optRetVar :: !(Maybe String), - optStmts :: ![[Ctx Statement]] } + optStmts :: ![[Ctx Statement]] } deriving Show type OState a = State.State OptimizerState a @@ -158,7 +157,7 @@ refreshOState :: OState () refreshOState = do st <- get - put st { optRenames = M.empty, optRetVar = Nothing, optStmts = [] } + put $ st { optRenames = M.empty, optRetVar = Nothing, optStmts = [] } pushLocal s = do st <- get @@ -171,9 +170,8 @@ let i = optNameIndex st let name = "_" ++ s ++ show i put st { optNameIndex = i + 1 } - st <- get verboten <- isVerboten name - if not verboten + if not verboten then do addVerboten name return name else mkName s -- make another... @@ -261,7 +259,6 @@ -- simplify $ nullCtx (Compound (parmVars ++ stmts))) where ps = funcParms fd -tr x = trace (show $ nullify x) x nullify :: Data a => a -> a nullify = everywhere (mkT doNullify) where doNullify :: Maybe SourceContext -> Maybe SourceContext @@ -427,7 +424,8 @@ let locals = optLocals st put st { optLocals = []:locals } sss <- mapM performInliningForStmt ss - put st { optLocals = locals } + st' <- get + put st' { optLocals = locals } return [(nullCtx (Compound (concat sss)))] performInliningForStmt (Ctx _ (While expr s)) = do refreshOState @@ -854,6 +852,10 @@ nameToLit :: M.Map String Expr -> String -> Maybe Expr nameToLit m s = predefToLit s `mplus` constVarToLit m s +nameToLitR m s = case nameToLit m s of + Just e@(Get (nm,All)) -> nameToLitR m (ctxItem nm) `mplus` (Just e) + v -> v + exprsToVals :: [Ctx Expr] -> Maybe [LSLValue Double] exprsToVals es = mapM exprToVal es where exprToVal :: Ctx Expr -> Maybe (LSLValue Double) @@ -873,7 +875,7 @@ Nothing -> Nothing Just vs -> Just $ LVal vs exprToVal _ = Nothing - + simplifyE :: Expr -> SimpState Expr simplifyE (Neg (Ctx _ (IntLit i))) = return (IntLit (-i)) simplifyE (Not (Ctx _ (IntLit i))) = return (IntLit (fromBool (i == 0))) @@ -908,13 +910,11 @@ simplifyE (Le (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (<=) i j)) simplifyE (Equal (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (==) i j)) simplifyE (NotEqual (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (==) i j)) -simplifyE e@(Div (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) | j /= 0 = return (FloatLit ( i / j)) - | otherwise = return e +simplifyE e@(Div (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return $ checkVal e (FVal ( i / j)) simplifyE (Add (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (fromIntegral i + j)) simplifyE (Mul (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (fromIntegral i * j)) simplifyE (Sub (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (fromIntegral i - j)) -simplifyE e@(Div (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) | j /= 0 = return (FloatLit ( fromIntegral i / j)) - | otherwise = return e +simplifyE e@(Div (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return $ checkVal e (FVal ( fromIntegral i / j)) simplifyE (Equal (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i == j then 1 else 0)) simplifyE (NotEqual (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i == j then 0 else 1)) simplifyE (Lt (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i < j then 1 else 0)) @@ -940,7 +940,7 @@ where name = ctxItem nm newExpr = do m <- get >>= return . siConstants - return $ case nameToLit m name of + return $ case nameToLitR m name of Nothing -> e Just e' -> case (c,e') of (All,VecExpr _ _ _) -> e @@ -970,7 +970,7 @@ then case simSFunc (script,[nm]) [] vs of Left _ -> return e Right (VoidVal,_) -> return e - Right (v,_) -> return $ valToExpr v + Right (v,_) -> return $ checkVal e v else return e simplifyE e@(Cast LLString (Ctx _ (IntLit i))) = return (StringLit (show i)) simplifyE e@(Cast LLString (Ctx _ (FloatLit f))) = return (StringLit s) @@ -984,6 +984,22 @@ simplifyE e@(RotExpr eX eY eZ eS) = return (RotExpr (toFloatLit eX) (toFloatLit eY) (toFloatLit eZ) (toFloatLit eS)) simplifyE e = return e +infinity :: Double +infinity = read "Infinity" +maxFloat :: Double +maxFloat = (1 + fromIntegral (2^23 - 1) / (2 ^23)) * fromIntegral (2^127) +minFloat = -maxFloat + +invalidLLFloat f = isNaN f || f == infinity || f == -infinity || f < minFloat || f > maxFloat +checkVal :: Expr -> LSLValue Double -> Expr +checkVal expr v@(FVal f) | invalidLLFloat f = expr + | otherwise = valToExpr v +checkVal expr v@(VVal x y z) | invalidLLFloat x || invalidLLFloat y || invalidLLFloat z = expr + | otherwise = valToExpr v +checkVal expr v@(RVal x y z w) | invalidLLFloat x || invalidLLFloat y || invalidLLFloat z || invalidLLFloat w = expr + | otherwise = valToExpr v +checkVal _ v = valToExpr v + -- could simplify for other types, but this should be sufficient for the main use case simplifyS (If (Ctx _ (IntLit 0)) _ stmt) = return stmt simplifyS (If (Ctx _ (IntLit _)) stmt _) = return stmt @@ -1014,4 +1030,4 @@ srcContext _ = True stopCondition :: Data a => a -> Bool -stopCondition = (False `mkQ` string `extQ` srcContext) +stopCondition = (False `mkQ` string `extQ` srcContext) diff --git a/src/Language/Lsl/Render.hs b/src/Language/Lsl/Render.hs --- a/src/Language/Lsl/Render.hs +++ b/src/Language/Lsl/Render.hs @@ -1,4 +1,4 @@ -module Language.Lsl.Render(renderCompiledScript) where +module Language.Lsl.Render(renderCompiledScript,renderStatements,renderCtxStatement,renderStatement) where import Data.List(foldl',intersperse) import Language.Lsl.Syntax(Expr(..),Func(..),FuncDec(..),Global(..),Handler(..),State(..),Statement(..), @@ -102,7 +102,7 @@ renderString "for (" . renderCtxExprs "" mexpr1 . renderString "; " . renderOptionalExpression mexpr2 . renderString "; " . renderCtxExprs "" mexpr3 . renderString ")" . case stmt of - NullStmt -> renderString ";n" + NullStmt -> renderString ";\n" _ -> renderStatement True n stmt renderStatement' n (If expr stmt1 stmt2) = renderString "if (" . renderCtxExpr expr . renderChar ')' . 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 @@ -49,7 +49,8 @@ compileLibrary, VState, emptyValidationState, - rewriteCtxExpr) where + rewriteCtxExpr, + rmCtx) where import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) import Language.Lsl.Internal.Constants(isConstant,findConstType) @@ -58,8 +59,9 @@ import Language.Lsl.Internal.AccessGenerator(genAccessorsForType,genMAccessorsForType) import Language.Lsl.Internal.Pragmas(Pragma(..)) import Data.Generics +import Data.Generics.Extras.Schemes import Data.Data(Data,Typeable) -import Data.List(find,sort,sortBy,nub,foldl') +import Data.List(find,sort,sortBy,nub,foldl',nubBy,deleteFirstsBy) import qualified Data.Map as M import Data.Maybe(isJust,isNothing) import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError) @@ -79,6 +81,11 @@ isTextLocation (Just (TextLocation _ _ _ _ _)) = True isTextLocation _ = False +rmCtx :: Data a => a -> a +rmCtx = everywhere (mkT doNullify) + where doNullify :: Maybe SourceContext -> Maybe SourceContext + doNullify _ = Nothing + -- | A wrapper that can associate a source code context with a value (e.g. a syntax value). data Ctx a = Ctx { srcCtx :: Maybe SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) instance Functor Ctx where @@ -461,9 +468,33 @@ safeHead [] = Nothing safeHead (x:_) = Just x -compileLSLScript' :: Library ->LSLScript -> Validity CompiledLSLScript + +compileLSLScript' :: Library -> LSLScript -> Validity CompiledLSLScript compileLSLScript' library script = evalState (compileLSLScript script) (emptyValidationState { vsLib = library }) +collectLabels :: Data a => a -> [(String,Maybe SourceContext)] +collectLabels = everythingBut (False `mkQ` string `extQ` sctx) (++) [] ([] `mkQ` lab) + where string :: String -> Bool + string = const True + sctx :: SourceContext -> Bool + sctx = const True + lab :: Ctx Statement -> [(String,Maybe SourceContext)] + lab (Ctx ctx (Label s)) = [(s,ctx)] + lab _ = [] + +warnLabelsMany :: Data a => [a] -> [CodeErr] +warnLabelsMany = concatMap warnLabels + +warnLabelsStates = concatMap warnLabelsState + where warnLabelsState (State _ hs) = warnLabelsMany hs + +warnLabels :: Data a => a -> [CodeErr] +warnLabels x = map (\ (name,ctx) -> (ctx,"label " ++ name ++ " is already defined (problem for LSL/Mono)")) problems + where problems = deleteFirstsBy fstEq labels uniques + labels = collectLabels x + uniques = nubBy fstEq labels + fstEq = flip ((==) . fst) . fst + compileLSLScript :: LSLScript -> VState (Validity CompiledLSLScript) compileLSLScript (LSLScript globs states) = do preprocessGlobDefs_ "" globs @@ -477,7 +508,10 @@ globals <- get'vsGlobals funcs <- get'vsFuncs states <- get'vsStates - return $ Right $ CompiledLSLScript (reverse globals) (reverse funcs) (reverse states) + -- for now, error on label warnings since we have no warnings + return $ case warnLabelsStates states ++ warnLabelsMany funcs of + [] -> Right $ CompiledLSLScript (reverse globals) (reverse funcs) (reverse states) + errs -> Left errs _ -> return $ Left $ reverse err preprocessStates states = let snames = map (\ (State cn _) -> ctxItem cn) states in put'vsStateNames snames 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.4" +version="0.3.5" usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" main = do progName <- getProgName diff --git a/src/Text/Here.hs b/src/Text/Here.hs new file mode 100644 --- /dev/null +++ b/src/Text/Here.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Here +-- Copyright : (c) Rob Greayer 2009 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : robgreayer@yahoo.com +-- Stability : provisional +-- Portability : non-portable (uses existentially template haskell) +-- +-- An implementation of 'here' documents, using quasiquotation. +-- +----------------------------------------------------------------------------- +module Text.Here(here) where + +import Data.Generics.Aliases(extQ) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote(QuasiQuoter(..),dataToPatQ,dataToExpQ) + +herePat :: String -> TH.Q TH.Pat +herePat s = dataToPatQ (const Nothing) s +hereExp :: String -> TH.Q TH.Exp +hereExp s = dataToExpQ (const Nothing) s + +-- | A quasi-quoter for a string... +here :: QuasiQuoter +here = QuasiQuoter hereExp herePat