diff --git a/LslPlus.cabal b/LslPlus.cabal --- a/LslPlus.cabal +++ b/LslPlus.cabal @@ -1,5 +1,5 @@ Name: LslPlus -version: 0.2.0 +version: 0.3.0 Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, @@ -19,50 +19,6 @@ Tested-With: GHC ==6.10.1 Extra-source-files: NOTICE --- Library --- Build-Depends: ghc >= 6.10, base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3, --- HaXml >= 1.19 && < 1.20, directory > 1 && < 1.1, mtl >= 1.1 && < 1.2, array >= 0.2 && < 0.3, --- network >= 2.1 && < 2.3, random >= 1.0, containers >= 0.1 && < 0.3, old-time, utf8-string >= 0.3 && < 0.4, --- pureMD5 >= 0.2 && < 3, bytestring >= 0.9 && < 0.10, template-haskell >= 2.3.0.0 && < 2.4, syb >= 0.1.0.0 && < 0.2.0.0 --- Exposed-Modules: Language.Lsl.Syntax, Language.Lsl.Parse, Language.Lsl.QQ, Language.Lsl.Sim --- Language.Lsl.WorldDef, Language.Lsl.UnitTest, Language.Lsl.UnitTestEnv, Language.Lsl.Render --- Other-modules: --- Language.Lsl.Internal.Animation --- Language.Lsl.Internal.AvEvents --- Language.Lsl.Internal.Breakpoint --- Language.Lsl.Internal.BreakpointsDeserialize --- Language.Lsl.Internal.BuiltInModules --- Language.Lsl.Internal.CodeHelper --- Language.Lsl.Internal.Compiler --- Language.Lsl.Internal.Constants --- Language.Lsl.Internal.DOMProcessing --- Language.Lsl.Internal.DOMSourceDescriptor --- Language.Lsl.Internal.DOMUnitTestDescriptor --- Language.Lsl.Internal.Evaluation --- Language.Lsl.Internal.EventSigs --- Language.Lsl.Internal.Exec --- Language.Lsl.Internal.ExecInfo --- Language.Lsl.Internal.ExpressionHandler --- Language.Lsl.Internal.FuncSigs --- Language.Lsl.Internal.InternalLLFuncs --- Language.Lsl.Internal.Key --- Language.Lsl.Internal.Load --- Language.Lsl.Internal.Log --- Language.Lsl.Internal.Math --- Language.Lsl.Internal.MetaData --- Language.Lsl.Internal.NumberParsing --- Language.Lsl.Internal.Optimize --- Language.Lsl.Internal.Physics --- Language.Lsl.Internal.SHA1 --- Language.Lsl.Internal.SimMetaData --- Language.Lsl.Internal.SystemTester --- Language.Lsl.Internal.TestResult --- Language.Lsl.Internal.Type --- Language.Lsl.Internal.UnitTester --- Language.Lsl.Internal.Util --- Language.Lsl.Internal.WorldState --- Language.Lsl.Internal.XmlCreate --- Hs-Source-Dirs: src, qqsrc Executable LslPlus Build-Depends: ghc >= 6.10, base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3, HaXml >= 1.19 && < 1.20, directory > 1 && < 1.1, mtl >= 1.1 && < 1.2, array >= 0.2 && < 0.3, @@ -71,14 +27,7 @@ Main-Is: LslPlus.hs Hs-Source-Dirs: src Other-modules: - Language.Lsl.Syntax - Language.Lsl.Parse - Language.Lsl.QQ - Language.Lsl.Sim - Language.Lsl.WorldDef - Language.Lsl.UnitTest - Language.Lsl.UnitTestEnv - Language.Lsl.Render + Data.Generics.Extras.Schemes Language.Lsl.Internal.AccessGenerator Language.Lsl.Internal.Animation Language.Lsl.Internal.AvEvents @@ -105,7 +54,9 @@ Language.Lsl.Internal.MetaData Language.Lsl.Internal.NumberParsing Language.Lsl.Internal.Optimize + Language.Lsl.Internal.OptimizerOptions Language.Lsl.Internal.Physics + Language.Lsl.Internal.Pragmas Language.Lsl.Internal.SHA1 Language.Lsl.Internal.SimMetaData Language.Lsl.Internal.SystemTester @@ -115,4 +66,16 @@ 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 + Language.Lsl.Sim + Language.Lsl.Syntax + Language.Lsl.UnitTest + Language.Lsl.UnitTestEnv + Language.Lsl.WorldDef + Text.ParserCombinators.ParsecExtras.Language + Text.ParserCombinators.ParsecExtras.Token Ghc-Options: -fwarn-unused-imports diff --git a/src/Data/Generics/Extras/Schemes.hs b/src/Data/Generics/Extras/Schemes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Extras/Schemes.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Rank2Types #-} +module Data.Generics.Extras.Schemes ( + downup, + everythingTwice + ) where + +------------------------------------------------------------------------------ + +import Data.Data +import Data.Generics.Aliases +import Control.Monad + +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) + + +downup :: Monad m => GenericM m -> GenericM m -> GenericM m + +downup down up x = do x' <- down x + x'' <- gmapM (downup down up) x' + up x'' diff --git a/src/Language/Lsl/Internal/Compiler.hs b/src/Language/Lsl/Internal/Compiler.hs --- a/src/Language/Lsl/Internal/Compiler.hs +++ b/src/Language/Lsl/Internal/Compiler.hs @@ -5,20 +5,23 @@ module Language.Lsl.Internal.Compiler(compile,main0) where import Control.Monad(when) +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as UTF8 import IO(Handle,hGetContents,stdin) import Language.Lsl.Internal.DOMSourceDescriptor(sourceFiles) import Language.Lsl.Internal.Load(loadModules,loadScripts) import Language.Lsl.Render(renderCompiledScript) +import Language.Lsl.Internal.OptimizerOptions(OptimizerOption(..)) import Language.Lsl.Syntax(AugmentedLibrary(..),CompiledLSLScript(..),Ctx(..),Func(..),Global(..), GlobDef(..),Handler(..),LModule(..),SourceContext(..),State(..),Validity,Var(..), - funcName,funcParms,funcType,libFromAugLib) + TextLocation(..),funcName,funcParms,funcType,libFromAugLib) import Language.Lsl.Internal.Type(lslTypeString) import System.Directory(doesFileExist,removeFile) import System.FilePath(replaceExtension) import System.Time(calendarTimeToString,getClockTime,toCalendarTime) import Text.XML.HaXml(Document(..),xmlParse) --hiding (when,xmlEscape) import Text.XML.HaXml.Posn(Posn(..)) -import Language.Lsl.Internal.Optimize(optimizeScript) +import Language.Lsl.Internal.Optimize(optimizeScript,OptimizerOption(..)) import Language.Lsl.Internal.XmlCreate hiding (emit) import qualified Language.Lsl.Internal.XmlCreate as E @@ -26,15 +29,15 @@ readCompileEmit :: Handle -> IO () readCompileEmit h = - do sourceInfo@(_,scriptInfo) <- readSourceList h + do sourceInfo@(optimize,_,scriptInfo) <- readSourceList h results@(_,compiledScripts) <- compile sourceInfo - renderScriptsToFiles compiledScripts scriptInfo + renderScriptsToFiles optimize compiledScripts scriptInfo putStr $ formatCompilationSummary results main0 = readCompileEmit stdin -compile :: ([(String,String)],[(String,String)]) -> IO (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) -compile (moduleInfo,scriptInfo) = +compile :: (Bool,[(String,String)],[(String,String)]) -> IO (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) +compile (_,moduleInfo,scriptInfo) = do augLib <- loadModules moduleInfo scripts <- loadScripts (libFromAugLib augLib) scriptInfo return (augLib,scripts) @@ -73,7 +76,7 @@ emit "globals" (map emitGlobal globals ++ map emitFreeVar freevars)]) where funcs globdefs = [ f | GF f <- globdefs] -emitFunc (Func fd _) = +emitFunc (Ctx _ (Func fd _)) = emit "entryPoint" [ emit "name" [showString (ctxItem $ funcName fd)], emit "returnType" [showString (lslTypeString $ funcType fd)], @@ -101,28 +104,28 @@ formatErr (ctx,msg) = emit "itemError" [formatCtx ctx , emit "msg" [showString (xmlEscape msg)]] -formatCtx UnknownSourceContext = id -formatCtx (TextLocation { textLine0 = l0, textColumn0 = c0, textLine1 = l1, textColumn1 = c1, textName = n }) = +formatCtx Nothing = id +formatCtx (Just (SourceContext { srcTextLocation = TextLocation { textLine0 = l0, textColumn0 = c0, textLine1 = l1, textColumn1 = c1, textName = n }})) = emit "errLoc" (map (\ (x,y) -> emit x [showString y]) [("lineStart",show l0), ("columnStart",show c0), ("lineEnd",show l1), ("columnEnd",show c1)]) -readSourceList :: Handle -> IO ([(String,String)],[(String,String)]) +readSourceList :: Handle -> IO (Bool,[(String,String)],[(String,String)]) readSourceList handle = do input <- hGetContents handle let doc = xmlParse "" input return $ processCompileList doc -processCompileList :: Document Posn -> ([(String,String)],[(String,String)]) +processCompileList :: Document Posn -> (Bool,[(String,String)],[(String,String)]) processCompileList (Document _ _ root _) = case sourceFiles root of Left s -> error s Right v -> v -renderScriptsToFiles :: [(String,Validity CompiledLSLScript)] -> [(String,String)] -> IO () -renderScriptsToFiles compiledScripts pathTable = +renderScriptsToFiles :: Bool -> [(String,Validity CompiledLSLScript)] -> [(String,String)] -> IO () +renderScriptsToFiles opt compiledScripts pathTable = let scriptsToRender = [(path,script) | (Just path,Right script) <- map (\ (name,vs) -> (lookup name pathTable,vs)) compiledScripts] scriptsToRemove = @@ -131,12 +134,13 @@ clockTime <- getClockTime calTime <- toCalendarTime clockTime let stamp = calendarTimeToString calTime - mapM_ (\ (path,script) -> renderScriptToFile stamp path script) scriptsToRender + mapM_ (\ (path,script) -> renderScriptToFile opt stamp path script) scriptsToRender mapM_ (removeOutputScript) scriptsToRemove -renderScriptToFile stamp path script = +renderScriptToFile opt stamp path script = let newPath = replaceExtension path ".lsl" - text = renderCompiledScript stamp (optimizeScript script) in writeFile newPath text + options = if opt then [OptimizationInlining] else [] + text = renderCompiledScript stamp (optimizeScript options script) in B.writeFile newPath (UTF8.fromString text) removeOutputScript path = do exists <- doesFileExist outpath 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 @@ -1,52 +1,53 @@ +{-# OPTIONS_GHC -XNoMonomorphismRestriction #-} module Language.Lsl.Internal.Constants where import Data.Bits((.|.),shiftL) import Language.Lsl.Internal.Type(LSLValue(..),typeOfLSLValue) import Language.Lsl.Internal.Util(findM) -data Constant = Constant { constName :: String, constVal :: LSLValue } +data Constant a = Constant { constName :: String, constVal :: LSLValue a } deriving (Show) -llcInventoryAll = IVal (-1) -llcInventoryAnimation = IVal 20 -llcInventoryBodyPart = IVal 13 -llcInventoryClothing = IVal 5 -llcInventoryGesture = IVal 21 -llcInventoryLandmark = IVal 3 -llcInventoryNotecard = IVal 7 -llcInventoryNone = IVal (-1) -llcInventoryObject = IVal 6 -llcInventoryScript = IVal 10 -llcInventorySound = IVal 1 -llcInventoryTexture = IVal 0 +cInventoryAll = (-1);llcInventoryAll :: RealFloat a => LSLValue a;llcInventoryAll = IVal cInventoryAll +cInventoryAnimation = 20;llcInventoryAnimation :: RealFloat a => LSLValue a; llcInventoryAnimation = IVal cInventoryAnimation +cInventoryBodyPart = 13;llcInventoryBodyPart :: RealFloat a => LSLValue a; llcInventoryBodyPart = IVal cInventoryBodyPart +cInventoryClothing = 5;llcInventoryClothing :: RealFloat a => LSLValue a; llcInventoryClothing = IVal cInventoryClothing +cInventoryGesture = 21;llcInventoryGesture :: RealFloat a => LSLValue a; llcInventoryGesture = IVal cInventoryGesture +cInventoryLandmark = 3;llcInventoryLandmark :: RealFloat a => LSLValue a; llcInventoryLandmark = IVal cInventoryLandmark +cInventoryNotecard = 7;llcInventoryNotecard :: RealFloat a => LSLValue a; llcInventoryNotecard = IVal cInventoryNotecard +cInventoryNone = (-1);llcInventoryNone :: RealFloat a => LSLValue a;llcInventoryNone = IVal cInventoryNone +cInventoryObject = 6;llcInventoryObject :: RealFloat a => LSLValue a; llcInventoryObject = IVal cInventoryObject +cInventoryScript = 10;llcInventoryScript :: RealFloat a => LSLValue a; llcInventoryScript = IVal cInventoryScript +cInventorySound = 1;llcInventorySound :: RealFloat a => LSLValue a; llcInventorySound = IVal cInventorySound +cInventoryTexture = 0;llcInventoryTexture :: RealFloat a => LSLValue a; llcInventoryTexture = IVal cInventoryTexture cPermissionChangeLinks = 0x80 :: Int llcPermissionChangeLinks = IVal cPermissionChangeLinks cChangedLink = 0x20 :: Int llcChangedLink = IVal cChangedLink -(cChangedInventory,llcChangedInventory) = mkIConst 0x1 -(cChnagedAllowedDrop,llcChangedAllowedDrop) = mkIConst 0x40 +cChangedInventory = 0x1;llcChangedInventory :: RealFloat a => LSLValue a; llcChangedInventory = IVal cChangedInventory +cChangedAllowedDrop = 0x40;llcChangedAllowedDrop :: RealFloat a => LSLValue a; llcChangedAllowedDrop = IVal cChangedAllowedDrop -(cMaskBase,llcMaskBase) = mkIConst 0 -(cMaskOwner,llcMaskOwner) = mkIConst 1 -(cMaskGroup,llcMaskGroup) = mkIConst 2 -(cMaskEveryone,llcMaskEveryone) = mkIConst 3 -(cMaskNext,llcMaskNext) = mkIConst 4 +cMaskBase = 0;llcMaskBase :: RealFloat a => LSLValue a; llcMaskBase = IVal cMaskBase +cMaskOwner = 1;llcMaskOwner :: RealFloat a => LSLValue a; llcMaskOwner = IVal cMaskOwner +cMaskGroup = 2;llcMaskGroup :: RealFloat a => LSLValue a; llcMaskGroup = IVal cMaskGroup +cMaskEveryone = 3;llcMaskEveryone :: RealFloat a => LSLValue a; llcMaskEveryone = IVal cMaskEveryone +cMaskNext = 4;llcMaskNext :: RealFloat a => LSLValue a; llcMaskNext = IVal cMaskNext -(cPermModify,llcPermModify) = mkIConst 0x00004000 -(cPermCopy,llcPermCopy) = mkIConst 0x00008000 -(cPermTransfer,llcPermTransfer) = mkIConst 0x00002000 -(cPermMove,llcPermMove) = mkIConst 0x00080000 +cPermModify = 0x00004000;llcPermModify :: RealFloat a => LSLValue a; llcPermModify = IVal cPermModify +cPermCopy = 0x00008000;llcPermCopy :: RealFloat a => LSLValue a; llcPermCopy = IVal cPermCopy +cPermTransfer = 0x00002000;llcPermTransfer :: RealFloat a => LSLValue a; llcPermTransfer = IVal cPermTransfer +cPermMove = 0x00080000;llcPermMove :: RealFloat a => LSLValue a; llcPermMove = IVal cPermMove cFullPerm = cPermModify .|. cPermMove .|. cPermTransfer .|. cPermCopy -(cPrimTypeBox,llcPrimTypeBox) = mkIConst 0 -(cPrimTypeCylinder,llcPrimTypeCylinder) = mkIConst 1 -(cPrimTypePrism,llcPrimTypePrism) = mkIConst 2 -(cPrimTypeRing,llcPrimTypeRing) = mkIConst 6 -(cPrimTypeSphere,llcPrimTypeSphere) = mkIConst 3 -(cPrimTypeSculpt,llcPrimTypeSculpt) = mkIConst 7 -(cPrimTypeTorus,llcPrimTypeTorus) = mkIConst 4 -(cPrimTypeTube,llcPrimTypeTube) = mkIConst 5 +cPrimTypeBox = 0;llcPrimTypeBox :: RealFloat a => LSLValue a; llcPrimTypeBox = IVal cPrimTypeBox +cPrimTypeCylinder = 1;llcPrimTypeCylinder :: RealFloat a => LSLValue a; llcPrimTypeCylinder = IVal cPrimTypeCylinder +cPrimTypePrism = 2;llcPrimTypePrism :: RealFloat a => LSLValue a; llcPrimTypePrism = IVal cPrimTypePrism +cPrimTypeRing = 6;llcPrimTypeRing :: RealFloat a => LSLValue a; llcPrimTypeRing = IVal cPrimTypeRing +cPrimTypeSphere = 3;llcPrimTypeSphere :: RealFloat a => LSLValue a; llcPrimTypeSphere = IVal cPrimTypeSphere +cPrimTypeSculpt = 7;llcPrimTypeSculpt :: RealFloat a => LSLValue a; llcPrimTypeSculpt = IVal cPrimTypeSculpt +cPrimTypeTorus = 4;llcPrimTypeTorus :: RealFloat a => LSLValue a; llcPrimTypeTorus = IVal cPrimTypeTorus +cPrimTypeTube = 5;llcPrimTypeTube :: RealFloat a => LSLValue a; llcPrimTypeTube = IVal cPrimTypeTube validAttachmentPoints = [0..36]::[Int] @@ -58,88 +59,88 @@ cPermissionControlCamera = 0x800 :: Int llcPermissionControlCamera = IVal cPermissionControlCamera -(cPermissionTrackCamera,llcPermissionTrackCamera) = mkIConst 0x400 -(cPermissionTriggerAnimation,llcPermissionTriggerAnimation) = mkIConst 0x10 -(cPermissionDebit,llcPermissionDebit) = mkIConst 0x2 -(cPermissionAttach,llcPermissionAttach) = mkIConst 0x20 -(cPermissionTakeControls,llcPermissionTakeControls) = mkIConst 0x4 +cPermissionTrackCamera = 0x400;llcPermissionTrackCamera :: RealFloat a => LSLValue a; llcPermissionTrackCamera = IVal cPermissionTrackCamera +cPermissionTriggerAnimation = 0x10;llcPermissionTriggerAnimation :: RealFloat a => LSLValue a; llcPermissionTriggerAnimation = IVal cPermissionTriggerAnimation +cPermissionDebit = 0x2;llcPermissionDebit :: RealFloat a => LSLValue a; llcPermissionDebit = IVal cPermissionDebit +cPermissionAttach = 0x20;llcPermissionAttach :: RealFloat a => LSLValue a; llcPermissionAttach = IVal cPermissionAttach +cPermissionTakeControls = 0x4;llcPermissionTakeControls :: RealFloat a => LSLValue a; llcPermissionTakeControls = IVal cPermissionTakeControls -(cActive,llcActive) = mkIConst 0x2 -(cAgent,llcAgent) = mkIConst 0x1 -(cPassive,llcPassive) = mkIConst 0x4 -(cScripted,llcScripted) = mkIConst 0x8 +cActive = 0x2;llcActive :: RealFloat a => LSLValue a; llcActive = IVal cActive +cAgent = 0x1;llcAgent :: RealFloat a => LSLValue a; llcAgent = IVal cAgent +cPassive = 0x4;llcPassive :: RealFloat a => LSLValue a; llcPassive = IVal cPassive +cScripted = 0x8;llcScripted :: RealFloat a => LSLValue a; llcScripted = IVal cScripted -(cStatusPhysics,llcStatusPhysics) = mkIConst 1 -(cStatusRotateX,llcStatusRotateX) = mkIConst 2 -(cStatusRotateY,llcStatusRotateY) = mkIConst 4 -(cStatusRotateZ,llcStatusRotateZ) = mkIConst 8 -(cStatusPhantom,llcStatusPhantom) = mkIConst 16 -(cStatusSandbox,llcStatusSandbox) = mkIConst 32 -(cStatusBlockGrab,llcStatusBlockGrab) = mkIConst 64 -(cStatusDieAtEdge,llcStatusDieAtEdge) = mkIConst 128 -(cStatusReturnAtEdge,llcStatusReturnAtEdge) = mkIConst 256 -(cStatusCastShadows,llcStatusCastShadows) = mkIConst 512 +cStatusPhysics = 1;llcStatusPhysics :: RealFloat a => LSLValue a; llcStatusPhysics = IVal cStatusPhysics +cStatusRotateX = 2;llcStatusRotateX :: RealFloat a => LSLValue a; llcStatusRotateX = IVal cStatusRotateX +cStatusRotateY = 4;llcStatusRotateY :: RealFloat a => LSLValue a; llcStatusRotateY = IVal cStatusRotateY +cStatusRotateZ = 8;llcStatusRotateZ :: RealFloat a => LSLValue a; llcStatusRotateZ = IVal cStatusRotateZ +cStatusPhantom = 16;llcStatusPhantom :: RealFloat a => LSLValue a; llcStatusPhantom = IVal cStatusPhantom +cStatusSandbox = 32;llcStatusSandbox :: RealFloat a => LSLValue a; llcStatusSandbox = IVal cStatusSandbox +cStatusBlockGrab = 64;llcStatusBlockGrab :: RealFloat a => LSLValue a; llcStatusBlockGrab = IVal cStatusBlockGrab +cStatusDieAtEdge = 128;llcStatusDieAtEdge :: RealFloat a => LSLValue a; llcStatusDieAtEdge = IVal cStatusDieAtEdge +cStatusReturnAtEdge = 256;llcStatusReturnAtEdge :: RealFloat a => LSLValue a; llcStatusReturnAtEdge = IVal cStatusReturnAtEdge +cStatusCastShadows = 512;llcStatusCastShadows :: RealFloat a => LSLValue a; llcStatusCastShadows = IVal cStatusCastShadows -(cPrimBumpShiny,llcPrimBumpShiny) = mkIConst 19 -(cPrimColor,llcPrimColor) = mkIConst 18 -(cPrimTexture,llcPrimTexture) = mkIConst 17 -(cPrimTexgen,llcPrimTexgen) = mkIConst 22 -(cPrimFullbright,llcPrimFullbright) = mkIConst 20 +cPrimBumpShiny = 19;llcPrimBumpShiny :: RealFloat a => LSLValue a; llcPrimBumpShiny = IVal cPrimBumpShiny +cPrimColor = 18;llcPrimColor :: RealFloat a => LSLValue a; llcPrimColor = IVal cPrimColor +cPrimTexture = 17;llcPrimTexture :: RealFloat a => LSLValue a; llcPrimTexture = IVal cPrimTexture +cPrimTexgen = 22;llcPrimTexgen :: RealFloat a => LSLValue a; llcPrimTexgen = IVal cPrimTexgen +cPrimFullbright = 20;llcPrimFullbright :: RealFloat a => LSLValue a; llcPrimFullbright = IVal cPrimFullbright -(cPrimMaterial,llcPrimMaterial) = mkIConst 2 -(cPrimPhantom,llcPrimPhantom) = mkIConst 5 -(cPrimPhysics,llcPrimPhysics) = mkIConst 3 -(cPrimFlexible,llcPrimFlexible) = mkIConst 21 -(cPrimPointLight,llcPrimPointLight) = mkIConst 23 -(cPrimPosition,llcPrimPosition) = mkIConst 6 -(cPrimRotation,llcPrimRotation) = mkIConst 8 -(cPrimSize,llcPrimSize) = mkIConst 7 -(cPrimTempOnRez,llcPrimTempOnRez) = mkIConst 4 -(cPrimType,llcPrimType) = mkIConst 9 +cPrimMaterial = 2;llcPrimMaterial :: RealFloat a => LSLValue a; llcPrimMaterial = IVal cPrimMaterial +cPrimPhantom = 5;llcPrimPhantom :: RealFloat a => LSLValue a; llcPrimPhantom = IVal cPrimPhantom +cPrimPhysics = 3;llcPrimPhysics :: RealFloat a => LSLValue a; llcPrimPhysics = IVal cPrimPhysics +cPrimFlexible = 21;llcPrimFlexible :: RealFloat a => LSLValue a; llcPrimFlexible = IVal cPrimFlexible +cPrimPointLight = 23;llcPrimPointLight :: RealFloat a => LSLValue a; llcPrimPointLight = IVal cPrimPointLight +cPrimPosition = 6;llcPrimPosition :: RealFloat a => LSLValue a; llcPrimPosition = IVal cPrimPosition +cPrimRotation = 8;llcPrimRotation :: RealFloat a => LSLValue a; llcPrimRotation = IVal cPrimRotation +cPrimSize = 7;llcPrimSize :: RealFloat a => LSLValue a; llcPrimSize = IVal cPrimSize +cPrimTempOnRez = 4;llcPrimTempOnRez :: RealFloat a => LSLValue a; llcPrimTempOnRez = IVal cPrimTempOnRez +cPrimType = 9;llcPrimType :: RealFloat a => LSLValue a; llcPrimType = IVal cPrimType -(cParcelDetailsName,llcParcelDetailsName) = mkIConst 0 -(cParcelDetailsDesc,llcParcelDetailsDesc) = mkIConst 1 -(cParcelDetailsOwner,llcParcelDetailsOwner) = mkIConst 2 -(cParcelDetailsGroup,llcParcelDetailsGroup) = mkIConst 3 -(cParcelDetailsArea,llcParcelDetailsArea) = mkIConst 4 +cParcelDetailsName = 0;llcParcelDetailsName :: RealFloat a => LSLValue a; llcParcelDetailsName = IVal cParcelDetailsName +cParcelDetailsDesc = 1;llcParcelDetailsDesc :: RealFloat a => LSLValue a; llcParcelDetailsDesc = IVal cParcelDetailsDesc +cParcelDetailsOwner = 2;llcParcelDetailsOwner :: RealFloat a => LSLValue a; llcParcelDetailsOwner = IVal cParcelDetailsOwner +cParcelDetailsGroup = 3;llcParcelDetailsGroup :: RealFloat a => LSLValue a; llcParcelDetailsGroup = IVal cParcelDetailsGroup +cParcelDetailsArea = 4;llcParcelDetailsArea :: RealFloat a => LSLValue a; llcParcelDetailsArea = IVal cParcelDetailsArea -(cClickActionNone,llcClickActionNone) = mkIConst 0 -(cClickActionTouch,llcClickActionTouch) = mkIConst 0 -(cClickActionSit,llcClickActionSit) = mkIConst 1 -(cClickActionBuy,llcClickActionBuy) = mkIConst 2 -(cClickActionPay,llcClickActionPay) = mkIConst 3 -(cClickActionOpen,llcClickActionOpen) = mkIConst 4 -(cClickActionPlay,llcClickActionPlay) = mkIConst 5 -(cClickActionOpenMedia,llcClickActionOpenMedia) = mkIConst 6 +cClickActionNone = 0;llcClickActionNone :: RealFloat a => LSLValue a; llcClickActionNone = IVal cClickActionNone +cClickActionTouch = 0;llcClickActionTouch :: RealFloat a => LSLValue a; llcClickActionTouch = IVal cClickActionTouch +cClickActionSit = 1;llcClickActionSit :: RealFloat a => LSLValue a; llcClickActionSit = IVal cClickActionSit +cClickActionBuy = 2;llcClickActionBuy :: RealFloat a => LSLValue a; llcClickActionBuy = IVal cClickActionBuy +cClickActionPay = 3;llcClickActionPay :: RealFloat a => LSLValue a; llcClickActionPay = IVal cClickActionPay +cClickActionOpen = 4;llcClickActionOpen :: RealFloat a => LSLValue a; llcClickActionOpen = IVal cClickActionOpen +cClickActionPlay = 5;llcClickActionPlay :: RealFloat a => LSLValue a; llcClickActionPlay = IVal cClickActionPlay +cClickActionOpenMedia = 6;llcClickActionOpenMedia :: RealFloat a => LSLValue a; llcClickActionOpenMedia = IVal cClickActionOpenMedia cClickActions = [cClickActionTouch,cClickActionSit,cClickActionBuy,cClickActionPay,cClickActionOpen,cClickActionPlay,cClickActionOpenMedia] -(cDataBorn,llcDataBorn) = mkIConst 3 -(cDataName,llcDataName) = mkIConst 2 -(cDataOnline,llcDataOnline) = mkIConst 1 -(cDataPayinfo,llcDataPayinfo) = mkIConst 8 -(cDataRating,llcDataRating) = mkIConst 4 -(cDataSimPos,llcDataSimPos) = mkIConst 5 -(cDataSimRating,llcDataSimRating) = mkIConst 7 -(cDataSimStatus,llcDataSimStatus) = mkIConst 6 +cDataBorn = 3;llcDataBorn :: RealFloat a => LSLValue a; llcDataBorn = IVal cDataBorn +cDataName = 2;llcDataName :: RealFloat a => LSLValue a; llcDataName = IVal cDataName +cDataOnline = 1;llcDataOnline :: RealFloat a => LSLValue a; llcDataOnline = IVal cDataOnline +cDataPayinfo = 8;llcDataPayinfo :: RealFloat a => LSLValue a; llcDataPayinfo = IVal cDataPayinfo +cDataRating = 4;llcDataRating :: RealFloat a => LSLValue a; llcDataRating = IVal cDataRating +cDataSimPos = 5;llcDataSimPos :: RealFloat a => LSLValue a; llcDataSimPos = IVal cDataSimPos +cDataSimRating = 7;llcDataSimRating :: RealFloat a => LSLValue a; llcDataSimRating = IVal cDataSimRating +cDataSimStatus = 6;llcDataSimStatus :: RealFloat a => LSLValue a; llcDataSimStatus = IVal cDataSimStatus -(cHTTPBodyMaxlength,llcHTTPBodyMaxlength) = mkIConst 2 -(cHTTPBodyTruncated,llcHTTPBodyTruncated) = mkIConst 0 -(cHTTPMethod,llcHTTPMethod) = mkIConst 0 -(cHTTPMimetype,llcHTTPMimetype) = mkIConst 1 -(cHTTPVerifyCert,llcHTTPVerifyCert) = mkIConst 3 +cHTTPBodyMaxlength = 2;llcHTTPBodyMaxlength :: RealFloat a => LSLValue a; llcHTTPBodyMaxlength = IVal cHTTPBodyMaxlength +cHTTPBodyTruncated = 0;llcHTTPBodyTruncated :: RealFloat a => LSLValue a; llcHTTPBodyTruncated = IVal cHTTPBodyTruncated +cHTTPMethod = 0;llcHTTPMethod :: RealFloat a => LSLValue a; llcHTTPMethod = IVal cHTTPMethod +cHTTPMimetype = 1;llcHTTPMimetype :: RealFloat a => LSLValue a; llcHTTPMimetype = IVal cHTTPMimetype +cHTTPVerifyCert = 3;llcHTTPVerifyCert :: RealFloat a => LSLValue a; llcHTTPVerifyCert = IVal cHTTPVerifyCert -(cRemoteDataChannel,llcRemoteDataChannel) = mkIConst 1 -(cRemoteDataRequest,llcRemoteDataRequest) = mkIConst 2 -(cRemoteDataReply,llcRemoteDataReply) = mkIConst 3 +cRemoteDataChannel = 1;llcRemoteDataChannel :: RealFloat a => LSLValue a; llcRemoteDataChannel = IVal cRemoteDataChannel +cRemoteDataRequest = 2;llcRemoteDataRequest :: RealFloat a => LSLValue a; llcRemoteDataRequest = IVal cRemoteDataRequest +cRemoteDataReply = 3;llcRemoteDataReply :: RealFloat a => LSLValue a; llcRemoteDataReply = IVal cRemoteDataReply llcZeroVector = VVal 0 0 0 llcZeroRotation = RVal 0 0 0 1 -mkIConst :: Int -> (Int,LSLValue) +mkIConst :: RealFloat a => Int -> (Int,LSLValue a) mkIConst i = (i,IVal i) -allConstants :: [Constant] +allConstants :: RealFloat a => [Constant a] allConstants = [ Constant "ACTIVE" llcActive, Constant "AGENT" llcAgent, @@ -248,7 +249,7 @@ Constant "DATA_SIM_STATUS" llcDataSimStatus, Constant "DEBUG_CHANNEL" llcDebugChannel, Constant "DEG_TO_RAD" (FVal 0.01745329238), - Constant "EOF" llcEOF, + Constant "EOF" $ SVal cEOF, Constant "FALSE" (IVal 0), Constant "HTTP_BODY_MAXLENGTH" llcHTTPBodyMaxlength, Constant "HTTP_BODY_TRUNCATED" llcHTTPBodyTruncated, diff --git a/src/Language/Lsl/Internal/DOMProcessing.hs b/src/Language/Lsl/Internal/DOMProcessing.hs --- a/src/Language/Lsl/Internal/DOMProcessing.hs +++ b/src/Language/Lsl/Internal/DOMProcessing.hs @@ -5,6 +5,7 @@ findSimple, findSimpleOrDefault, findValueOrDefault, + findBoolOrDefault, findValue, valueAcceptor, -- String -> ElemAcceptor m t ctxelem, @@ -116,13 +117,21 @@ value <- readM sval return (value,rest) +findBoolOrDefault def name contents = + do (sval,rest) <- findOptionalElement (simpleElement name) contents + case sval of + Nothing -> return (def,contents) + Just "true" -> return (True,rest) + Just "false" -> return (False,rest) + Just s -> fail ("unable to parse " ++ s) + findValueOrDefault def name contents = do (sval,rest) <- findOptionalElement (simpleElement name) contents case sval of Nothing -> return (def, contents) Just s -> do value <- readM s - return (value, contents) + return (value, rest) -- for backwards compatibility attrString (AttValue v) = concatMap decode v diff --git a/src/Language/Lsl/Internal/DOMSourceDescriptor.hs b/src/Language/Lsl/Internal/DOMSourceDescriptor.hs --- a/src/Language/Lsl/Internal/DOMSourceDescriptor.hs +++ b/src/Language/Lsl/Internal/DOMSourceDescriptor.hs @@ -2,17 +2,18 @@ module Language.Lsl.Internal.DOMSourceDescriptor(sourceFiles,sourceFilesElement) where import Control.Monad.Error(MonadError(..)) -import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),elementList,findElement,match,simple) +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),elementList,findElement,match,simple,findBoolOrDefault) import Text.XML.HaXml(Element(..),Content(..)) sourceFiles e = match sourceFilesElement e -sourceFilesElement :: MonadError String m => ElemAcceptor m ([(String,String)],[(String,String)]) +sourceFilesElement :: MonadError String m => ElemAcceptor m (Bool,[(String,String)],[(String,String)]) sourceFilesElement = let f (Elem _ _ contents) = do - (m,contents1) <- findElement modulesElement [ e | e@(CElem _ _) <- contents ] + (optimize,contents0) <- findBoolOrDefault False "optimize" contents + (m,contents1) <- findElement modulesElement [ e | e@(CElem _ _) <- contents0 ] (s,[]) <- findElement scriptsElement contents1 - return (m,s) + return (optimize,m,s) in ElemAcceptor "source_files" f modulesElement :: MonadError String m => ElemAcceptor m [(String,String)] 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 @@ -56,58 +56,58 @@ pathElement :: MonadError String m => ElemAcceptor m String pathElement = ElemAcceptor "path" simple -argumentsElement :: MonadError String m => ElemAcceptor m [LSLValue] +argumentsElement :: MonadError String m => ElemAcceptor m [LSLValue Float] argumentsElement = let f (Elem _ _ contents) = mapM (matchChoice [lslString, lslInteger, lslFloat, lslVector, lslRotation, lslKey, lslList1]) (elementsOnly contents) in ElemAcceptor "arguments" f -lslString :: MonadError String m => ElemAcceptor m LSLValue +lslString :: MonadError String m => ElemAcceptor m (LSLValue Float) lslString = ElemAcceptor "lsl-string" (\ e -> do s <- simple e case evaluateExpression LLString s of Just k -> return k Nothing -> fail "invalid content for lsl-string") -lslKey :: MonadError String m => ElemAcceptor m LSLValue +lslKey :: MonadError String m => ElemAcceptor m (LSLValue Float) lslKey = ElemAcceptor "lsl-key" (\ e -> do s <- simple e case evaluateExpression LLKey s of Just k -> return k Nothing -> fail "invalid content for lsl-key") -lslInteger :: MonadError String m => ElemAcceptor m LSLValue +lslInteger :: MonadError String m => ElemAcceptor m (LSLValue Float) lslInteger = ElemAcceptor "lsl-integer" (\ e -> do s <- simple e case evaluateExpression LLInteger s of Just f -> return f Nothing -> fail "invalid content for lsl-integer") -lslFloat :: MonadError String m => ElemAcceptor m LSLValue +lslFloat :: MonadError String m => ElemAcceptor m (LSLValue Float) lslFloat = ElemAcceptor "lsl-float" (\ e -> do s <- simple e case evaluateExpression LLFloat s of Just f -> return f Nothing -> fail "invalid content for lsl-float") -lslVector :: MonadError String m => ElemAcceptor m LSLValue +lslVector :: MonadError String m => ElemAcceptor m (LSLValue Float) lslVector = ElemAcceptor "lsl-vector" (\ e -> do s <- simple e case evaluateExpression LLVector s of Just f -> return f Nothing -> fail "invalid content for lsl-vector") -lslRotation :: MonadError String m => ElemAcceptor m LSLValue +lslRotation :: MonadError String m => ElemAcceptor m (LSLValue Float) lslRotation = ElemAcceptor "lsl-rotation" (\ e -> do s <- simple e case evaluateExpression LLRot s of Just f -> return f Nothing -> fail "invalid content for lsl-rotation") -lslList :: MonadError String m => ElemAcceptor m LSLValue +lslList :: MonadError String m => ElemAcceptor m (LSLValue Float) lslList = let f (Elem _ _ contents) = do list <- mapM (matchChoice [lslString,lslInteger,lslKey,lslVector,lslRotation,lslFloat]) (elementsOnly contents) return (LVal list) in ElemAcceptor "lsl-list" f -lslList1 :: MonadError String m => ElemAcceptor m LSLValue +lslList1 :: MonadError String m => ElemAcceptor m (LSLValue Float) lslList1 =ElemAcceptor "lsl-list1" (\ e -> do s <- simple e case evaluateExpression LLList s of @@ -115,17 +115,17 @@ Nothing -> fail "invalid content for lsl-list1") -lslVoid :: MonadError String m => ElemAcceptor m LSLValue +lslVoid :: MonadError String m => ElemAcceptor m (LSLValue Float) lslVoid = let f (Elem _ _ []) = return VoidVal f (Elem name _ _) = fail ("unexpected content in " ++ name ++ " tag.") in ElemAcceptor "lsl-void" f -expectedReturnElement :: MonadError String m => ElemAcceptor m (Maybe LSLValue) +expectedReturnElement :: MonadError String m => ElemAcceptor m (Maybe (LSLValue Float)) expectedReturnElement = maybeSomeVal "expectedReturn" -expectationsElement :: MonadError String m => ElemAcceptor m FuncCallExpectations +expectationsElement :: MonadError String m => ElemAcceptor m (FuncCallExpectations Float) expectationsElement = let f (Elem _ _ contents) = do (modeString,contents1) <- findElement modeElement (elementsOnly contents) @@ -145,10 +145,10 @@ modeElement :: MonadError String m => ElemAcceptor m String modeElement = ElemAcceptor "mode" simple -callsElement :: MonadError String m => ElemAcceptor m [((String, [Maybe LSLValue]),LSLValue)] +callsElement :: MonadError String m => ElemAcceptor m [((String, [Maybe (LSLValue Float)]),LSLValue Float)] callsElement = elementList "calls" callElement -callElement :: MonadError String m => ElemAcceptor m ((String, [Maybe LSLValue]),LSLValue) +callElement :: MonadError String m => ElemAcceptor m ((String, [Maybe (LSLValue Float)]),LSLValue Float) callElement = let f (Elem _ _ contents) = do (name,contents1) <- findElement (ElemAcceptor "name" simple) (elementsOnly contents) @@ -157,19 +157,19 @@ return ((name,args),retval) in ElemAcceptor "call" f -callArgsElement :: MonadError String m => ElemAcceptor m [Maybe LSLValue] +callArgsElement :: MonadError String m => ElemAcceptor m [Maybe (LSLValue Float)] callArgsElement = elementList "args" (maybeSomeVal "maybe-value") -returnsElement :: MonadError String m => ElemAcceptor m LSLValue +returnsElement :: MonadError String m => ElemAcceptor m (LSLValue Float) returnsElement = someVal "returns" -initialBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue)] +initialBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue Float)] initialBindingsElement = elementList "initialBindings" globalBindingElement -finalBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue)] +finalBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue Float)] finalBindingsElement = elementList "finalBindings" globalBindingElement -globalBindingElement :: MonadError String m => ElemAcceptor m (String,LSLValue) +globalBindingElement :: MonadError String m => ElemAcceptor m (String,LSLValue Float) globalBindingElement = let f (Elem _ _ contents) = do (name,contents1) <- findElement (ElemAcceptor "name" simple) (elementsOnly contents) diff --git a/src/Language/Lsl/Internal/Evaluation.hs b/src/Language/Lsl/Internal/Evaluation.hs --- a/src/Language/Lsl/Internal/Evaluation.hs +++ b/src/Language/Lsl/Internal/Evaluation.hs @@ -8,17 +8,17 @@ import Language.Lsl.Internal.Breakpoint(Breakpoint) --type ScriptInfo = (String,Int,String,String) -- (object id, prim index, script name, prim key) -data ScriptInfo = ScriptInfo { scriptInfoObjectKey :: String, - scriptInfoPrimIndex :: Int, - scriptInfoScriptName :: String, - scriptInfoPrimKey :: String, - scriptInfoCurrentEvent :: Maybe Event } +data ScriptInfo a = ScriptInfo { scriptInfoObjectKey :: String, + scriptInfoPrimIndex :: Int, + scriptInfoScriptName :: String, + scriptInfoPrimKey :: String, + scriptInfoCurrentEvent :: Maybe (Event a) } deriving (Show) data EvalResult = EvalIncomplete | EvalComplete (Maybe String) | YieldTil Int | BrokeAt Breakpoint deriving (Show) -data Event = Event { eventName :: String, eventValues :: [LSLValue], eventInfo :: Map String LSLValue } +data Event a = Event { eventName :: String, eventValues :: [LSLValue a], eventInfo :: Map String (LSLValue a) } deriving (Show) 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,3 +1,4 @@ +{-# OPTIONS_GHC -XNoMonomorphismRestriction #-} module Language.Lsl.Internal.Exec( ScriptImage(..), EvalState, @@ -38,6 +39,7 @@ State(..), Ctx(..), Global(..), + TextLocation(..), SourceContext(..), Handler(..), ctxVr2Vr, @@ -49,7 +51,7 @@ predefFuncs, isTextLocation) import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),typeOfLSLComponent,typeOfLSLValue,toFloat,toSVal, - lslShowVal,replaceLslValueComponent,vecMulScalar,rotMulVec, + 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(..)) @@ -59,14 +61,14 @@ import Control.Monad.Error(ErrorT(..)) -- initialize a script for execution -initLSLScript :: CompiledLSLScript -> ScriptImage +initLSLScript :: RealFloat a => CompiledLSLScript -> ScriptImage a initLSLScript (CompiledLSLScript globals fs ss) = ScriptImage { scriptImageName = "", curState = "default", executionState = Waiting, glob = initGlobals globals, - funcs = fs, + funcs = map ctxItem fs, states = ss, valueStack = [], callStack = [], @@ -106,49 +108,49 @@ (Right queue',evalState) -> return $ Right $ (scriptImage evalState, queue') -- The state of evaluation for a script. -data EvalState m = EvalState { - scriptImage :: ScriptImage, +data EvalState m a = EvalState { + scriptImage :: ScriptImage a, objectId :: String, primId :: Int, scriptName :: String, myPrimKey :: String, - performAction :: String -> ScriptInfo -> [LSLValue] -> m (EvalResult,LSLValue), + performAction :: String -> ScriptInfo a -> [LSLValue a] -> m (EvalResult,LSLValue a), logMessage :: String -> m (), qwtick :: m Int, uwtick :: Int -> m (), checkBreakpoint :: Breakpoint -> StepManager -> m (Bool, StepManager), - nextEvent :: String -> String -> m (Maybe Event) } + nextEvent :: String -> String -> m (Maybe (Event a)) } -type Eval m = ErrorT String (StateT (EvalState m) m) +type Eval m a = ErrorT String (StateT (EvalState m a) m) -evalT :: Monad m => ((EvalState m) -> (a,EvalState m)) -> Eval m a +evalT :: Monad m => ((EvalState m b) -> (a,EvalState m b)) -> Eval m b a evalT v = lift ((\ f -> StateT (\ s -> return (f s))) v) -- the image, or 'memory state' of a running script. Includes the -- status of all stacks, global variables, and immutable items like -- the functions and state definitions. -data ScriptImage = ScriptImage { +data ScriptImage a = ScriptImage { scriptImageName :: String, curState :: StateName, executionState :: ExecutionState, - glob :: MemRegion, + glob :: MemRegion a, funcs :: [Func], states :: [State], - valueStack :: ValueStack, - callStack :: CallStack, + valueStack :: ValueStack a, + callStack :: CallStack a, stepManager :: StepManager, globals :: [Global], - currentEvent :: Maybe Event + currentEvent :: Maybe (Event a) } deriving (Show) -data FrameInfo = FrameInfo { frameInfoImageName :: String, frameInfoFrames :: [(String,SourceContext,Maybe Int,[(String,LSLValue)])] } +data FrameInfo a = FrameInfo { frameInfoImageName :: String, frameInfoFrames :: [(String,Maybe SourceContext,Maybe Int,[(String,LSLValue a)])] } deriving (Show) frameInfo scriptImage = FrameInfo (scriptImageName scriptImage) $ frames ++ [("glob", bottomContext, Nothing, glob scriptImage)] where frames = (map collapseFrame $ callStack scriptImage) (bottomContext,bottomLine) = case frames of - [] -> (UnknownSourceContext,Nothing) + [] -> (Nothing,Nothing) _ -> let (_,ctx,_,_) = last frames in (ctx,Just 1) collapseFrame (Frame name ctx line (ss,_)) = (name,ctx,line,concat $ map fst ss) @@ -221,14 +223,14 @@ -- location has a name (rather than an address) and can hold a value -- which can be of any LSL type. So 1 memory location can hold a -- vector, or a string, or a list, etc. -type Binding = (String,LSLValue) +type Binding a = (String,LSLValue a) -- a memory region is just a collection of NameElementPairs -type MemRegion = [Binding] +type MemRegion a = [Binding a] emptyMemRegion = [] initVar name LLInteger Nothing = (name,IVal 0) -initVar name LLFloat Nothing = (name,FVal 0.0) +initVar name LLFloat Nothing = (name,FVal $ realToFrac 0.0) initVar name LLString Nothing = (name,SVal "") initVar name LLKey Nothing = (name,SVal "") initVar name LLList Nothing = (name,LVal []) @@ -240,16 +242,16 @@ initVar name LLInteger (Just (FVal f)) = (name,IVal $ floor f) initVar name _ (Just v) = (name,v) -writeMem :: Monad m => String -> LSLValue -> MemRegion -> m MemRegion +writeMem :: Monad m => String -> LSLValue a -> MemRegion a -> m (MemRegion a) writeMem name value cells = case break (\(name',element) -> name' == name) cells of (cells',[]) -> fail "no such variable" (xs,y:ys) -> return ((name,value):(xs ++ ys)) -readMem :: Monad m => String -> MemRegion -> m LSLValue +readMem :: Monad m => String -> MemRegion a -> m (LSLValue a) readMem = lookupM -initGlobals :: [Global] -> MemRegion +initGlobals :: RealFloat a => [Global] -> MemRegion a initGlobals globals = map (initGlobal globals) globals initGlobal globals (GDecl (Var name t) mexpr) = initVar name t $ fmap (evalLit globals) mexpr @@ -264,9 +266,9 @@ _ -> error "invalid float expression" in case expr of Neg (Ctx _ (IntLit i)) -> IVal (-i) - Neg (Ctx _ (FloatLit f)) -> FVal (-f) + Neg (Ctx _ (FloatLit f)) -> FVal (-(realToFrac f)) IntLit i -> IVal i - FloatLit f -> FVal f + FloatLit f -> FVal (realToFrac f) StringLit s -> SVal s KeyLit k -> KVal k ListExpr l -> LVal $ map (evalCtxLit globals) l @@ -298,25 +300,25 @@ toBool x = if x == 0 then False else True --type Frame = (ScopeStack,EvalStack) -data Frame = Frame { frameName :: String, frameContext :: SourceContext, frameSourceLine :: Maybe Int, - frameStacks :: (ScopeStack, EvalStack) } +data Frame a = Frame { frameName :: String, frameContext :: Maybe SourceContext, frameSourceLine :: Maybe Int, + frameStacks :: (ScopeStack a, EvalStack) } deriving (Show) type LabelSet = [LBlock] -type Scope = (MemRegion,LabelSet) -type ScopeStack = [Scope] -type CallStack = [Frame] +type Scope a = (MemRegion a,LabelSet) +type ScopeStack a = [Scope a] +type CallStack a = [Frame a] -readVarScope :: String -> Scope -> Maybe LSLValue +readVarScope :: String -> Scope a -> Maybe (LSLValue a) readVarScope name (mem,_) = readMem name mem -readVarSStack :: String -> ScopeStack -> Maybe LSLValue +readVarSStack :: String -> ScopeStack a -> Maybe (LSLValue a) readVarSStack name ss = foldl mplus Nothing $ map (readVarScope name) ss -readVarFrame :: String -> Frame -> Maybe LSLValue +readVarFrame :: String -> Frame a -> Maybe (LSLValue a) readVarFrame name = (readVarSStack name) . fst . frameStacks -readVarCallStack :: String -> CallStack -> Maybe LSLValue +readVarCallStack :: String -> CallStack a -> Maybe (LSLValue a) readVarCallStack name = (readVarFrame name) . head -writeVarScope :: String -> LSLValue -> Scope -> Maybe Scope +writeVarScope :: String -> LSLValue a -> Scope a -> Maybe (Scope a) writeVarScope name val (mem,l) = writeMem name val mem >>= return . (flip (,) l) writeVarSStack rs name val [] = Nothing writeVarSStack rs name val (s:ss) = @@ -332,7 +334,7 @@ type EvalStack = [EvalElement] -type ValueStack = [LSLValue] +type ValueStack a = [LSLValue a] data EvalElement = EvBlock [Ctx Statement] | EvCtxStatement (Ctx Statement) | EvStatement Statement | EvExpr Expr | EvMexpr (Maybe Expr) @@ -341,20 +343,20 @@ | EvShiftL | EvShiftR | EvCast LSLType | EvGet (String,Component) | EvSet (String,Component) | EvCons | EvMkVec | EvMkRot | EvPop | EvReturn | EvDiscard | EvBind String LSLType - | EvCond Statement Statement | EvCall String SourceContext [Var] [Ctx Statement] Bool + | 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) -> Eval w a +--queryState :: Monad w => (EvalState w a -> a) -> Eval w b a queryState q = evalT (\s -> (q s, s)) -updateState :: Monad w => (EvalState w -> EvalState w) -> Eval w () +updateState :: Monad w => (EvalState w a -> EvalState w a) -> Eval w a () updateState u = evalT (\s -> ((), u s)) queryExState q = queryState (q . scriptImage) -updateExState :: Monad w => (ScriptImage -> ScriptImage) -> Eval w () +updateExState :: Monad w => (ScriptImage a -> ScriptImage a) -> Eval w a () updateExState u = updateState (\s -> s { scriptImage = u $ scriptImage s }) -getTick :: Monad w => Eval w Int +getTick :: Monad w => Eval w a Int getTick = join $ evalT (\s -> (lift $ lift $ qwtick s,s)) setTick v = do f <- (queryState uwtick) lift $ lift $ f v @@ -371,35 +373,35 @@ setStepManager sm' return result -getGlob :: Monad w => Eval w MemRegion +getGlob :: Monad w => Eval w a (MemRegion a) getGlob = queryExState glob -getFuncs :: Monad w => Eval w [Func] +getFuncs :: Monad w => Eval w a [Func] getFuncs = queryExState funcs -getVStack :: Monad w => Eval w ValueStack +getVStack :: Monad w => Eval w a (ValueStack a) getVStack = queryExState valueStack -getCallStack :: Monad w => Eval w CallStack +getCallStack :: Monad w => Eval w a (CallStack a) getCallStack = queryExState callStack -getStates :: Monad w => Eval w [State] +getStates :: Monad w => Eval w a [State] getStates = queryExState states -getCurrentEvent :: Monad w => Eval w (Maybe Event) +getCurrentEvent :: Monad w => Eval w a (Maybe (Event a)) getCurrentEvent = queryExState currentEvent -getExecutionState :: Monad w => Eval w ExecutionState +getExecutionState :: Monad w => Eval w a ExecutionState getExecutionState = queryExState executionState -getCurState :: Monad w => Eval w String +getCurState :: Monad w => Eval w a String getCurState = queryExState curState -getEvalState :: Monad w => Eval w (EvalState w) +--getEvalState :: (RealFloat a, Read a, Monad w) => Eval w a (EvalState w a) getEvalState = queryState id -getObjectId :: Monad w => Eval w String +getObjectId :: Monad w => Eval w a String getObjectId = queryState objectId -getPrimId :: Monad w => Eval w Int +getPrimId :: Monad w => Eval w a Int getPrimId = queryState primId -getScriptName :: Monad w => Eval w String +getScriptName :: Monad w => Eval w a String getScriptName = queryState scriptName -getScriptImageName :: Monad w => Eval w String +getScriptImageName :: Monad w => Eval w a String getScriptImageName = queryExState scriptImageName -getMyPrimKey :: Monad w => Eval w String +getMyPrimKey :: Monad w => Eval w a String getMyPrimKey = queryState myPrimKey -getStepManager :: Monad w => Eval w StepManager +getStepManager :: Monad w => Eval w a StepManager getStepManager = queryExState stepManager setGlob g = updateExState (\e -> e { glob = g }) @@ -411,12 +413,12 @@ setCurrentEvent event = updateExState (\e -> e { currentEvent = Just event }) setScriptImageName n = updateExState (\ e -> e { scriptImageName = n }) -initStacks :: Monad w => Eval w () +initStacks :: Monad w => Eval w a () initStacks = do setVStack [] setCallStack [] -popScope :: Monad w => Eval w Scope +popScope :: Monad w => Eval w a (Scope a) popScope = do --((s:ss,es):cs) <- getCallStack (frame:frames) <- getCallStack @@ -424,7 +426,7 @@ setCallStack (frame { frameStacks = (ss,es) }:frames) return s -pushScope :: Monad w => MemRegion -> LabelSet -> Eval w () +pushScope :: Monad w => MemRegion a -> LabelSet -> Eval w a () pushScope mem labels = do (frame:frames) <- getCallStack let (ss,es) = frameStacks frame @@ -434,7 +436,7 @@ do vstack <- getVStack setVStack (value:vstack) -popVal :: Monad w => Eval w LSLValue +popVal :: Monad w => Eval w a (LSLValue a) popVal = do vstack <- getVStack case vstack of @@ -443,24 +445,24 @@ setVStack vs return v -peekVal :: Monad w => Eval w LSLValue +peekVal :: Monad w => Eval w a (LSLValue a) peekVal = do vstack <- getVStack case vstack of [] -> fail "empty value stack" (v:_) -> return v -valStackEmpty :: Monad w => Eval w Bool +valStackEmpty :: (RealFloat a, Read a, Monad w) => Eval w a Bool valStackEmpty = getVStack >>= (return . (==[])) -elementStackEmpty :: Monad w => Eval w Bool +elementStackEmpty :: Monad w => Eval w a Bool elementStackEmpty = do (frame:cs) <- getCallStack case frameStacks frame of (_,[]) -> return True _ -> return False -popElement :: Monad w => Eval w EvalElement +popElement :: Monad w => Eval w a EvalElement popElement = do (frame:frames) <- getCallStack let (ss,e:es) = frameStacks frame @@ -481,10 +483,10 @@ do mapM pushElement elements return EvalIncomplete -callStackEmpty :: Monad w => Eval w Bool +callStackEmpty :: Monad w => Eval w a Bool callStackEmpty = getCallStack >>= return . null -popFrame :: Monad w => Eval w () +popFrame :: Monad w => Eval w a () popFrame = do (f:cs) <- getCallStack stepMgr <- getStepManager @@ -500,12 +502,12 @@ cs <- getCallStack setCallStack (Frame { frameName = name, frameContext = ctx, frameSourceLine = line, frameStacks = ([],[])}:cs) -getFunc :: Monad w => String -> Eval w Func +getFunc :: Monad w => String -> Eval w a Func getFunc name = do funcs <- getFuncs incontext ("func: " ++ name) $ findFunc name funcs -setVar :: Monad w => String -> LSLValue -> Eval w () +setVar :: Monad w => String -> LSLValue a -> Eval w a () setVar name val = do cs <- getCallStack case writeVarCallStack name val cs of @@ -515,7 +517,7 @@ glob' <- incontext ("setting " ++ name ++ ":") $ writeMem name val glob setGlob glob' -getVar :: Monad w => String -> Eval w LSLValue +getVar :: (RealFloat a, Read a, Monad w) => String -> Eval w a (LSLValue a) getVar name = do cs <- getCallStack glob <- getGlob @@ -523,7 +525,7 @@ Nothing -> fail ("no such variable " ++ name) Just val -> return val -initVar1 :: Monad w => String -> LSLType -> Maybe LSLValue -> Eval w () +initVar1 :: (RealFloat a, Read a, Monad w) => String -> LSLType -> Maybe (LSLValue a) -> Eval w a () initVar1 name t mval = do --(((m,l):ss,es):cs) <- getCallStack (frame:frames) <- getCallStack @@ -531,7 +533,7 @@ let frame' = frame { frameStacks = (((initVar name t mval):m,l):ss,es) } setCallStack (frame':frames) -initVars1 :: Monad w => [Var] -> [LSLValue] -> Eval w () +initVars1 :: (RealFloat a, Read a, Monad w) => [Var] -> [LSLValue a] -> Eval w a () initVars1 vars vals = foldM_ (\_ -> \ (Var n t, v) -> initVar1 n t $ Just v) () $ zip vars vals @@ -564,7 +566,7 @@ findM (\ (Handler (Ctx _ name') _ _) -> name' == name) handlers -evalScriptSimple :: Monad w => Int -> [String] -> [Binding] -> [LSLValue] -> Eval w (EvalResult,Maybe LSLValue) +evalScriptSimple :: (Read a, RealFloat a, Monad w) => Int -> [String] -> [Binding a] -> [LSLValue a] -> Eval w a (EvalResult,Maybe (LSLValue a)) evalScriptSimple maxTick path globbindings args = do setupSimple path globbindings args evalSimple maxTick @@ -611,7 +613,7 @@ Left s -> fail s Right v -> return v -evalScript :: Monad w => Int -> [Event] -> Eval w [Event] +evalScript :: (RealFloat a, Read a, Monad w) => Int -> [Event a] -> Eval w a [Event a] evalScript maxTick queue = do executionState <- getExecutionState case executionState of @@ -671,7 +673,7 @@ else return queue Halted -> return queue -eval :: Monad w => Int -> Eval w EvalResult +eval :: (RealFloat a, Read a, Monad w) => Int -> Eval w a EvalResult eval maxTick = do t <- getTick @@ -685,10 +687,10 @@ else return EvalIncomplete) -eval' :: Monad w => Eval w EvalResult +eval' :: (RealFloat a, Read a, Monad w) => Eval w a EvalResult eval' = let continue = return EvalIncomplete - popAndCheck :: Monad w => Eval w EvalResult + popAndCheck :: Monad w => Eval w a EvalResult popAndCheck = do popFrame noMoreFrames <- callStackEmpty @@ -709,12 +711,13 @@ EvBlock (s:ss) -> pushElements [EvBlock ss,EvCtxStatement s] EvCtxStatement s -> do pushElements [EvStatement $ ctxItem s] - if (isTextLocation $ srcCtx s) then - let bp = mkBreakpoint (textName $ srcCtx s) (textLine0 $ srcCtx s) 0 in - do brk <- checkBp bp - if brk then return $ BrokeAt bp - else continue - else continue + case srcCtx s of + Just (SourceContext { srcTextLocation = txtl }) -> + let bp = mkBreakpoint (textName txtl) (textLine0 txtl) 0 in + do brk <- checkBp bp + if brk then return $ BrokeAt bp + else continue + Nothing -> continue EvStatement (Return mexpr) -> pushElements [EvReturn,EvMexpr $ fromMCtx mexpr] EvStatement (NullStmt) -> eval' EvStatement (StateChange s) -> return $ EvalComplete $ Just s @@ -765,7 +768,7 @@ pushElement (EvStatement (if trueCondition val then stmt1 else stmt2)) continue EvExpr (IntLit i) -> pushVal (IVal i) >> continue - EvExpr (FloatLit f) -> pushVal (FVal f) >> continue + EvExpr (FloatLit f) -> pushVal (FVal (realToFrac f)) >> continue EvExpr (StringLit s) -> pushVal (SVal s) >> continue EvExpr (KeyLit k) -> pushVal (KVal k) >> continue EvExpr (VecExpr e1 e2 e3) -> @@ -1041,29 +1044,6 @@ "ffffffff-ffff-ffff-ffff-ffffffffffff" -> True _ -> False where tr c = if c `elem` "0123456789abcdef" then 'f' else c --- TODO: LSL also will parse hex notation for strings and floats... -parseVector s = - case [(VVal x y z,t) | ("<",t0) <- lex s, - (x,t1) <- reads t0, - (",",t2) <- lex t1, - (y,t3) <- reads t2, - (",",t4) <- lex t3, - (z,t5) <- reads t4, - (">",t) <- lex t5] of - [] -> VVal 0.0 0.0 0.0 - (v,_):_ -> v -parseRotation s = - case [(RVal x y z w,t) | ("<",t0) <- lex s, - (x,t1) <- reads t0, - (",",t2) <- lex t1, - (y,t3) <- reads t2, - (",",t4) <- lex t3, - (z,t5) <- reads t4, - (",",t6) <- lex t5, - (w,t7) <- reads t6, - (">",t) <- lex t7] of - [] -> RVal 0.0 0.0 0.0 0.0 - (v,_):_ -> v toLslBool bool = IVal (if bool then 1 else 0) evalBinary f = @@ -1097,9 +1077,9 @@ convertArg LLString (KVal k) = SVal k convertArg _ v = v -ctxList es = map (Ctx UnknownSourceContext) es +ctxList es = map (Ctx Nothing) es -data ExecutionInfo = ExecutionInfo String Int FrameInfo deriving (Show) +data ExecutionInfo a = ExecutionInfo String Int (FrameInfo a) deriving (Show) hasActiveHandler simage handler = case find ( \ (State ctxname _) -> curState simage == ctxItem ctxname) (states simage) of diff --git a/src/Language/Lsl/Internal/ExecInfo.hs b/src/Language/Lsl/Internal/ExecInfo.hs --- a/src/Language/Lsl/Internal/ExecInfo.hs +++ b/src/Language/Lsl/Internal/ExecInfo.hs @@ -1,7 +1,7 @@ module Language.Lsl.Internal.ExecInfo(emitExecutionInfo) where import Language.Lsl.Internal.Exec(ExecutionInfo(..),FrameInfo(..)) -import Language.Lsl.Syntax(SourceContext(..)) +import Language.Lsl.Syntax(SourceContext(..),TextLocation(..)) import Language.Lsl.Internal.Type(LSLValue(..)) import Language.Lsl.Internal.XmlCreate(emit,emitSimple) @@ -22,8 +22,8 @@ emitCtx ctx, emitLine line, emit "bindings" [] (map emitBinding bindings)] - where emitCtx UnknownSourceContext = id - emitCtx ctx = emitSimple "file" [] ( textName ctx ) + where emitCtx Nothing = id + emitCtx (Just (SourceContext { srcTextLocation = txtl })) = emitSimple "file" [] ( textName txtl ) emitLine Nothing = id emitLine (Just i) = emitSimple "line" [] (show i) @@ -48,4 +48,4 @@ emitSimple "z" [] (show z), emitSimple "s" [] (show s)] emitVal (LVal l) = - emit "val" [("class","list-value")] [emit "elements" [] (map emitVal l)] + emit "val" [("class","list-value")] [emit "elements" [] (map emitVal l)] 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 @@ -118,6 +118,10 @@ validPrimitiveExpr (Le e0 e1) = validRelExpr e0 e1 validPrimitiveExpr (Gt e0 e1) = validRelExpr e0 e1 validPrimitiveExpr (Ge e0 e1) = validRelExpr e0 e1 +validPrimitiveExpr (Cast t e) = do + t' <- validPrimitiveCtxExpr e + when (not $ isCastValid t' t) $ fail "invalid cast" + return t validPrimitiveExpr expr = fail "expression not valid in this context" validPrimEach e0 e1 = @@ -198,7 +202,7 @@ case t of (IVal i) -> return $ IVal (if i == 0 then 1 else 0) evalExpr (IntLit i) = return (IVal i) -evalExpr (FloatLit f) = return (FVal f) +evalExpr (FloatLit f) = return (FVal $ realToFrac f) evalExpr (StringLit s) = return (SVal s) evalExpr (KeyLit k) = return (KVal k) evalExpr (VecExpr xExpr yExpr zExpr) = @@ -280,6 +284,29 @@ evalExpr (Le e0 e1) = evalRelExpr (<=) (<=) e0 e1 evalExpr (Gt e0 e1) = evalRelExpr (>) (>) e0 e1 evalExpr (Ge e0 e1) = evalRelExpr (>=) (>=) e0 e1 +evalExpr (Cast t e) = do + v <- evalCtxExpr e + case (t,v) of + (LLInteger,IVal i) -> return $ IVal i + (LLInteger,FVal f) -> return $ IVal (truncate f) + (LLInteger,SVal s) -> return $ IVal (parseInt s) + -- TODO: can you cast a key to an int? + (LLFloat,FVal f) -> return $ FVal f + (LLFloat,IVal i) -> return $ FVal (fromInteger $ toInteger i) + (LLFloat,SVal s) -> return $ FVal (parseFloat s) + -- TODO: can you cast a key to a float? + (LLString,v) -> return $ toSVal v + -- TODO: can you cast anything but a string to a key? + (LLVector,SVal s) -> return $ parseVector s + (LLRot,SVal s) -> return $ parseRotation s + (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 + _ -> fail "invalid cast!" + evalExpr expr = fail "expression not valid in this context" evalArithExpr fi ff e0 e1 = @@ -347,4 +374,4 @@ Left s -> error (show s) putStr $ expressionValidatorEmitter (checkExpr t text) - + 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 @@ -126,9 +126,9 @@ import Network.URI(escapeURIChar,unEscapeString) internalLLFuncNames :: [String] -internalLLFuncNames = map fst (internalLLFuncs :: [(String, a -> [LSLValue] -> Maybe (EvalResult,LSLValue))]) +internalLLFuncNames = map fst (internalLLFuncs :: (Read a, RealFloat a) => [(String, a -> [LSLValue a] -> Maybe (EvalResult,LSLValue a))]) -internalLLFuncs :: (Monad m) => [(String, a -> [LSLValue] -> m (EvalResult,LSLValue))] +internalLLFuncs :: (Read a, RealFloat a, Monad m) => [(String, b -> [LSLValue a] -> m (EvalResult,LSLValue a))] internalLLFuncs = [ ("llAbs",llAbs), ("llAcos",llAcos), @@ -274,7 +274,7 @@ llSHA1String _ [SVal string] = continueWith $ SVal (hashStoHex string) -- Math functions -unaryToLL :: (Monad m) => (Float -> Float) -> [LSLValue] -> m (EvalResult,LSLValue) +unaryToLL :: (RealFloat a, Monad m) => (a -> a) -> [LSLValue a] -> m (EvalResult,LSLValue a) unaryToLL f [FVal v] = continueWith $ FVal (f v) llCos _ = unaryToLL cos @@ -308,7 +308,7 @@ in pow (a `mod` c) b' -- should use a map for this, but have been using lists for everything, so will stick with it... -statFuncs :: [(Int, [Float] -> Float)] +statFuncs :: RealFloat a => [(Int, [a] -> a)] statFuncs = map (\(Just (IVal op), f) -> (op,f)) [ (findConstVal "LIST_STAT_RANGE", listStatRange), (findConstVal "LIST_STAT_MAX", listStatMax), @@ -321,7 +321,7 @@ (findConstVal "LIST_STAT_NUM_COUNT", fromInt . length), (findConstVal "LIST_STAT_GEOMETRIC_MEAN", listStatGeometricMean)] -toF :: LSLValue -> Maybe Float +toF :: Num a => LSLValue a -> Maybe a toF (IVal i) = Just (fromInt i) toF (FVal f) = Just f toF _ = Nothing @@ -436,7 +436,7 @@ llCSV2List _ [SVal s] = continueWith $ LVal $ map SVal (lslCsvToList [] s) llList2CSV _ [LVal l] = - continueWith $ SVal $ concat (intersperse "," (map lslValToString l)) + continueWith $ SVal $ concat (intersperse ", " (map lslValToString l)) lslValToString (VVal x y z) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ ">" lslValToString (RVal x y z s) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ "," ++ (show s) ++ ">" @@ -492,6 +492,7 @@ concat (direction $ sort $ strideList list stride) +typeCodes :: RealFloat a => [(LSLType, LSLValue a)] typeCodes = map (\ (t,Just v) -> (t,v)) [ (LLInteger, findConstVal "TYPE_INTEGER"), (LLFloat, findConstVal "TYPE_FLOAT"), @@ -499,7 +500,8 @@ (LLKey, findConstVal "TYPE_KEY"), (LLVector, findConstVal "TYPE_VECTOR"), (LLRot, findConstVal "TYPE_ROTATION")] - + +invalidType :: RealFloat a => LSLValue a invalidType = let Just v = findConstVal "TYPE_INVALID" in v -- TODO: might this function work with negative indices? assuming no. @@ -508,9 +510,11 @@ if index < 0 || index >= length l then invalidType else let Just v = lookup (typeOfLSLValue $ l !! index) typeCodes in v +elemAtM' i = if i >= 0 then elemAtM i else elemAtM ((-1) - i) . reverse + llList2Float _ [LVal l, IVal index] = continueWith $ FVal $ - case elemAtM index l of + case elemAtM' index l of Just (SVal s) -> parseFloat s Just (IVal i) -> fromInt i Just (FVal f) -> f @@ -518,7 +522,7 @@ llList2Integer _ [LVal l, IVal index] = continueWith $ IVal $ - case elemAtM index l of + case elemAtM' index l of Just (SVal s) -> parseInt s Just (IVal i) -> i Just (FVal f) -> truncate f @@ -526,22 +530,22 @@ llList2Key _ [LVal l, IVal index] = continueWith $ - case elemAtM index l of + case elemAtM' index l of Just v -> let (SVal v') = toSVal v in KVal v' _ -> let (Just (SVal v)) = findConstVal "NULL_KEY" in KVal v llList2Rot _ [LVal l, IVal index] = - continueWith $ case elemAtM index l of + continueWith $ case elemAtM' index l of Just r@(RVal _ _ _ _) -> r _ -> let (Just r) = findConstVal "ZERO_ROTATION" in r llList2String _ [LVal l, IVal index] = continueWith $ - case elemAtM index l of + case elemAtM' index l of Nothing -> SVal "" Just v -> toSVal v llList2Vector _ [LVal l, IVal index] = - continueWith $ case elemAtM index l of + continueWith $ case elemAtM' index l of Just v@(VVal _ _ _) -> v _ -> let (Just v) = findConstVal "ZERO_VECTOR" in v diff --git a/src/Language/Lsl/Internal/Load.hs b/src/Language/Lsl/Internal/Load.hs --- a/src/Language/Lsl/Internal/Load.hs +++ b/src/Language/Lsl/Internal/Load.hs @@ -12,7 +12,7 @@ let parseFile (name,path) = do result <- tryJust (\ e@(SomeException x) -> Just (show e)) $ p path case result of - Left msg -> return (name,Left (UnknownSourceContext,msg)) + Left msg -> return (name,Left (Nothing,msg)) Right (Left err) -> return (name,Left err) Right (Right m) -> return (name,Right m) in liftIO $ mapM parseFile files diff --git a/src/Language/Lsl/Internal/Math.hs b/src/Language/Lsl/Internal/Math.hs --- a/src/Language/Lsl/Internal/Math.hs +++ b/src/Language/Lsl/Internal/Math.hs @@ -65,7 +65,7 @@ invertQuaternion (x,y,z,s) = (-x,-y,-z,s) -rotationsToQuaternion :: Permutation3 -> (Float,Float,Float) -> (Float,Float,Float,Float) +rotationsToQuaternion :: RealFloat a => Permutation3 -> (a,a,a) -> (a,a,a,a) rotationsToQuaternion order (x,y,z) = let rx = (sin (x/2), 0.0, 0.0, cos (x/2)) ry = (0.0, sin (y/2), 0.0, cos (y/2)) @@ -86,7 +86,7 @@ sign f = if f < 0 then -1 else 1 -quaternionToRotations :: Permutation3 -> Bool -> (Float,Float,Float,Float) -> (Float,Float,Float) +quaternionToRotations :: RealFloat a => Permutation3 -> Bool -> (a,a,a,a) -> (a,a,a) quaternionToRotations rotOrder lh quat= let (p1,p2,p3,p0) = quatPermute quat rotOrder mult = if lh then -1 else 1 @@ -126,4 +126,4 @@ x' = x / sinVal y' = y / sinVal z' = z / sinVal - in if sinVal == 0 then ((1,0,0),0) else ((x',y',z'),angle) + in if sinVal == 0 then ((1,0,0),0) else ((x',y',z'),angle) 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,73 +1,947 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Language.Lsl.Internal.Optimize(optimizeScript) where - -import Language.Lsl.Syntax(CompiledLSLScript(..),Expr(..),Statement(..),Func(..),FuncDec(..),State(..),Ctx(..),Handler(..)) - -optimizeScript :: CompiledLSLScript -> CompiledLSLScript -optimizeScript (CompiledLSLScript gs fs ss) = (CompiledLSLScript gs fs' ss) - where usedFuncs = concatMap stateUsesFuncs ss ++ concatMap funcUsesFuncs fs - fs' = [ f | f@(Func fd _) <- fs, (ctxItem . funcName) fd `elem` usedFuncs ] - -exprUsesFuncs :: Expr -> [String] -exprUsesFuncs (Call (ctxName) es) = ctxItem ctxName : (exprsUsesFuncs es) -exprUsesFuncs (IntLit _) = [] -exprUsesFuncs (FloatLit _) = [] -exprUsesFuncs (StringLit _) = [] -exprUsesFuncs (KeyLit _) = [] -exprUsesFuncs (ListExpr es) = exprsUsesFuncs es -exprUsesFuncs (VecExpr x y z) = exprsUsesFuncs [x,y,z] -exprUsesFuncs (RotExpr x y z s) = exprsUsesFuncs [x,y,z,s] -exprUsesFuncs (Add e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Sub e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Mul e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Div e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Mod e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Set _ e) = exprUsesFuncs' e -exprUsesFuncs (BAnd e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (BOr e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Xor e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (ShiftL e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (ShiftR e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (And e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Or e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Equal e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (NotEqual e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Lt e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Gt e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Le e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (Ge e1 e2) = exprsUsesFuncs [e1,e2] -exprUsesFuncs (IncBy _ e) = exprUsesFuncs' e -exprUsesFuncs (DecBy _ e) = exprUsesFuncs' e -exprUsesFuncs (MulBy _ e) = exprUsesFuncs' e -exprUsesFuncs (DivBy _ e) = exprUsesFuncs' e -exprUsesFuncs (ModBy _ e) = exprUsesFuncs' e -exprUsesFuncs (Not e) = exprUsesFuncs' e -exprUsesFuncs (Neg e) = exprUsesFuncs' e -exprUsesFuncs (Inv e) = exprUsesFuncs' e -exprUsesFuncs (Cast _ e) = exprUsesFuncs' e -exprUsesFuncs _ = [] - -exprUsesFuncs' = exprUsesFuncs . ctxItem -exprsUsesFuncs = concatMap exprUsesFuncs' - -statementUsesFuncs :: Statement -> [String] -statementUsesFuncs (Compound ss) = concatMap (statementUsesFuncs . ctxItem) ss -statementUsesFuncs (While e s) = exprUsesFuncs' e ++ statementUsesFuncs s -statementUsesFuncs (DoWhile s e) = statementUsesFuncs s ++ exprUsesFuncs' e -statementUsesFuncs (For e1 me2 e3 s) = - exprsUsesFuncs e1 ++ maybe [] exprUsesFuncs' me2 ++ exprsUsesFuncs e3 ++ statementUsesFuncs s -statementUsesFuncs (If e s1 s2) = exprUsesFuncs' e ++ statementUsesFuncs s1 ++ statementUsesFuncs s2 -statementUsesFuncs (Decl _ (Just e)) = exprUsesFuncs' e -statementUsesFuncs (Return (Just e)) = exprUsesFuncs' e -statementUsesFuncs (Do e) = exprUsesFuncs' e -statementUsesFuncs _ = [] - -statementUsesFuncs' = statementUsesFuncs . ctxItem - -funcUsesFuncs :: Func -> [String] -funcUsesFuncs (Func _ stmts) = concatMap statementUsesFuncs' stmts -handlerUsesFuncs :: Handler -> [String] -handlerUsesFuncs (Handler _ _ stmts) = concatMap statementUsesFuncs' stmts - -stateUsesFuncs :: State -> [String] -stateUsesFuncs (State _ handlers) = concatMap handlerUsesFuncs handlers +{-# OPTIONS_GHC -fwarn-incomplete-patterns -XStandaloneDeriving -XNoMonomorphismRestriction #-} +module Language.Lsl.Internal.Optimize(optimizeScript,OptimizerOption(..)) where + +import Control.Monad.State hiding (State) +import qualified Control.Monad.Identity as Id +import qualified Control.Monad.State as State(State) + +import Data.Bits((.&.),(.|.),xor,shiftL,shiftR,complement) +import Data.Generics +import Data.Generics.Extras.Schemes(everythingTwice,downup) +import Data.List(foldl',nub,lookup) +import Data.Graph +import qualified Data.Set as Set +import qualified Data.Map as M + +import Debug.Trace + +import Language.Lsl.Parse +import Language.Lsl.Internal.Constants(allConstants,Constant(..),findConstVal) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs,internalLLFuncNames) +import Language.Lsl.Internal.OptimizerOptions(OptimizerOption(..)) +import Language.Lsl.Syntax(CompiledLSLScript(..),Expr(..),Statement(..),Var(..), + Func(..),FuncDec(..),State(..),Ctx(..),Handler(..), + Global(..),Component(..),SourceContext(..),rewriteCtxExpr) +import Language.Lsl.Internal.Type(LSLType(..),toSVal) +import Language.Lsl.Internal.Pragmas(Pragma(..)) +import Language.Lsl.Internal.Type(LSLValue(..)) +import Language.Lsl.UnitTestEnv(simSFunc) + +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 + gcs = globalConstants gs fsIn ss + 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 + ifs' = foldl (\ fs f -> let f' = runInliningOnFunc funFacts fs gs f in f':fs) [] ifs -- inlineables that have had any inlining done + nifs' = map (runInliningOnFunc funFacts ifs' gs) nifs -- non-inlineables that have had any inlining done + fs' = if inline then (nifs' ++ ifs') else fsIn + fsReachable = reachableFuncs ss1 (simp fs') -- funcs that are still reachable from handlers + gsReachable = reachableGlobs gs fsReachable ss1 -- globals that are still reachable from handlers/funcs + simp = if inline then simplify script pure gcs else id + runInliningOnState s@(State nm hs) = if noinlining nm then s + else (State nm (map (runInliningOnHandler funFacts ifs' gs) hs)) + +hasPragma p (Ctx (Just SourceContext { srcPragmas = l }) _) | p `elem` l = True + | otherwise = False +hasPragma _ _ = False + +inlineable = hasPragma PragmaInline +noinlining = hasPragma PragmaNoInline + +data EPKey = HK String String | FK String deriving (Show, Eq, Ord) + +stateEdges :: [State] -> [(EPKey,EPKey,[EPKey])] +stateEdges ss = concatMap (\ (State (Ctx _ nm) hs) -> (map (\ h@(Handler (Ctx _ nm') _ _) -> (HK nm nm',HK nm nm', (map FK (handlerCallsFuncs h)))) hs)) ss + +funcEdges :: [Ctx Func] -> [(EPKey,EPKey,[EPKey])] +funcEdges fs = map (\ f -> let fn = fname f in (FK fn, FK fn,map FK $ funcCallsFuncs f)) fs + +reachableFuncs ss fs = [ f | f <- fs, fname f `elem` allReachableFnames] + where ses = stateEdges ss + (graph,v2n,k2v) = graphFromEdges (ses ++ funcEdges fs) + allReachableIndices = nub $ concatMap (reachable graph) [ i | Just i <- map ( \ (k,_,_) -> k2v k) ses] + allReachableFnames = [fn | (FK fn,_,_) <- map ( \ i -> v2n i) allReachableIndices] + +varNameInList :: Var -> [String] +varNameInList = (:[]) . varName + +varsDefinedByHandler :: Handler -> [String] +varsDefinedByHandler = everything (++) ([] `mkQ` varNameInList) + +varsDefinedByFunc :: Ctx Func -> [String] +varsDefinedByFunc = everything (++) ([] `mkQ` varNameInList) + +labels (Label nm) = [nm] +labels _ = [] + +labelsDefinedByFunc :: Ctx Func -> [String] +labelsDefinedByFunc = everything (++) ([] `mkQ` labels) + +labelsDefinedByHandler :: Handler -> [String] +labelsDefinedByHandler = everything (++) ([] `mkQ` labels) + +namesDefinedByHandler :: Handler -> [String] +namesDefinedByHandler handler = labelsDefinedByHandler handler ++ varsDefinedByHandler handler + +namesDefinedByFunc :: Ctx Func -> [String] +namesDefinedByFunc func = labelsDefinedByFunc func ++ varsDefinedByFunc func + +exprCallsFuncDirectly :: Expr -> [String] +exprCallsFuncDirectly (Call (ctxName) _) = [ctxItem ctxName] +exprCallsFuncDirectly _ = [] + +funcCallsFuncs :: Ctx Func -> [String] +funcCallsFuncs = everything (++) ([] `mkQ` exprCallsFuncDirectly) + +stateCallsFuncs :: State -> [String] +stateCallsFuncs = everything (++) ([] `mkQ` exprCallsFuncDirectly) + +handlerCallsFuncs :: Handler -> [String] +handlerCallsFuncs = everything (++) ([] `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 + +newtype FunctionFacts = FunctionFacts { isPureFunction :: Bool } deriving (Show) + +data OptimizerState = OptimizerState { + optAllFuncs :: !(M.Map String (Ctx Func)), + optFunFacts :: !(M.Map String FunctionFacts), + optNameIndex :: Int, + optGlobalNames :: !(Set.Set String), + optVerbotenNames :: !(Set.Set String), + optLocals :: ![[String]], + optInlinerRenames :: ![M.Map String String], -- names that must be renamed in the 'destination' function/handler + 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]] } + +type OState a = State.State OptimizerState a + +basicFunctionFacts = M.fromList (zip internalLLFuncNames (repeat (FunctionFacts { isPureFunction = True }))) `M.union` + M.fromList [(nm,FunctionFacts False) | (nm,_,_) <- funcSigs] + +freshOptimizerState funFacts fs gnames = OptimizerState { + optAllFuncs = M.fromList (map (\ f@(Ctx _ (Func (FuncDec nm _ _) _)) -> (ctxItem nm,f)) fs), + optFunFacts = funFacts, + optNameIndex = 0, + optGlobalNames = (Set.fromList gnames), + optVerbotenNames = Set.empty, + optLocals = [], + optInlinerRenames = [], + optRenames = M.empty, + optRewrites = M.empty, + optRetVar = Nothing, + optStmts = [] } + +removeOStateStmts :: OState [Ctx Statement] +removeOStateStmts = do + st <- get + let stmts = (concat (reverse (optStmts st))) + put st { optStmts = [] } + return stmts + +refreshOState :: OState () +refreshOState = do + st <- get + put st { optRenames = M.empty, optRetVar = Nothing, optStmts = [] } + +pushLocal s = do + st <- get + case optLocals st of + [] -> put st { optLocals = [[s]] } + top:rest -> put st { optLocals = (s:top):rest } + +mkName s = do + st <- get + let i = optNameIndex st + let name = "_" ++ s ++ show i + put st { optNameIndex = i + 1 } + st <- get + verboten <- isVerboten name + if not verboten + then do addVerboten name + return name + 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 + let s = optVerbotenNames st + put st { optVerbotenNames = (Set.insert name s) } + +addRename s s' = do + st <- get + put st { optRenames = M.insert s s' (optRenames st) } + +rewriteLabel s = do + renames <- get >>= return . optRenames + return $ maybe s id (M.lookup s renames) + +renameToNew s = do + verboten <- isVerboten s + if verboten + then do + s' <- mkName s + addRename s s' + return s' + else do + st <- get + put st { optVerbotenNames = Set.insert s (optVerbotenNames st) } + return s + +pushInlinerScope = do + st <- get + put st { optInlinerRenames = M.empty : (optInlinerRenames st) } +popInlinerScope = do + st <- get + case optInlinerRenames st of + [] -> error "cannot pop inliner scope" + (top:rest) -> put st { optInlinerRenames = rest } + +renameToNewInInliner s = do + --verboten <- isVerboten s + verboten <- get >>= return . (Set.member s) . optGlobalNames + if verboten + then do + s' <- mkName s + st <- get + case optInlinerRenames st of + [] -> error "empty inliner rename stack" + (top:rest) -> put st { optInlinerRenames = M.insert s s' top : rest } + return s' + else do + st <- get + put st { optVerbotenNames = Set.insert s (optVerbotenNames st) } + return s + +inlinerRenamingFor s = do + renameStack <- get >>= return . optInlinerRenames + return $ renamingFor renameStack s + where renamingFor [] s = s + renamingFor (top:rest) s = case M.lookup s top of + Just s' -> s' + Nothing -> renamingFor rest s + +renameVar (Var s t) = do + s' <- renameToNew s + return (Var s' t) + +getRewriteInfo :: OState (M.Map String String, M.Map String Expr) +getRewriteInfo = get >>= ( \ st -> return (optRenames st, optRewrites st)) + +isVerboten s = do + verbotenNames <- get >>= return . optVerbotenNames + globalNames <- get >>= return . optGlobalNames + return (s `Set.member` (verbotenNames `Set.union` globalNames)) + +inlineProc :: + Ctx Func -> -- the function to inline + [Ctx Expr] -> -- the arguments to the call + OState ([Ctx Statement],[Ctx Statement]) -- +inlineProc (Ctx c (Func fd ss)) args = do + endLabel <- mkName "end" + parmVars <- mkParmVars ss (zip ps args) + 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 + +mkParmVars :: [Ctx Statement] -> [(Ctx Var,Ctx Expr)] -> OState [Ctx Statement] +mkParmVars ss ves = mapM (mkParmVar ss) ves >>= return . concat +mkParmVar ss (Ctx _ v@(Var nm _),arg) = do + funFacts <- get >>= return . optFunFacts + locals <- get >>= return . concat . optLocals + if isRelativelyPure locals funFacts arg && + (staticComplexity arg < 2 || usageCount nm ss == 1) && not (nm `isModifiedIn` ss) && (simpleRef arg || nm `isUsedOnlyWholeIn` ss) + then do + st <- get + put st { optRewrites = M.insert (varName v) (ctxItem arg) (optRewrites st) } + return [] + else do + v' <- renameVar v + return [nullCtx $ Decl v' $ Just arg] + 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!)" + | otherwise = do + ret <- mkName "ret" + putRetVar ret + (endStmts,stmts) <- inlineProc f args + let count = countOfSetsOf ret stmts + case (count,last stmts) of + (1,Ctx _ (Do ((Ctx _ (Set _ expr))))) -> return (ctxItem expr,init stmts) + _ -> return ((Get (nullCtx ret,All)),(nullCtx $ Decl (Var ret t) Nothing): (stmts ++ endStmts)) + +inlineVoidFunc :: Ctx Func -> [Ctx Expr] -> OState [Ctx Statement] +inlineVoidFunc f args = do + (endStmts,stmts) <- inlineProc f args + return (stmts ++ endStmts) + +inlineStmts :: String -> [Statement] -> OState [Statement] +inlineStmts _ [] = return [] +inlineStmts endLabel (NullStmt:NullStmt:stmts) = inlineStmts endLabel (NullStmt:stmts) +inlineStmts endLabel (NullStmt:stmts) = inlineStmts endLabel stmts >>= return . (NullStmt:) +inlineStmts endLabel (Return Nothing:stmts) = inlineStmts endLabel stmts >>= return . (Jump endLabel:) +inlineStmts endLabel (Return (Just expr):stmts) = do + stmts' <- inlineStmts endLabel stmts + retVar <- get >>= return . optRetVar + (renames,rewrites) <- getRewriteInfo + case retVar of + 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') +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') +inlineStmts endLabel (Do expr:stmts) = do + stmts' <- inlineStmts endLabel stmts + (renames,rewrites) <- getRewriteInfo + 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 + stmts' <- inlineStmts endLabel stmts + return (Label s':stmts) +inlineStmts endLabel (Jump s:stmts) = do + -- must process the rest of the statements BEFORE rewriting the Jump + stmts' <- inlineStmts endLabel stmts + s' <- rewriteLabel s + return (Jump s':stmts') +inlineStmts endLabel (StateChange s:stmts) = inlineStmts endLabel stmts >>= return . (StateChange s:) +inlineStmts endLabel (Compound ss:stmts) = do + stmts' <- inlineStmts endLabel stmts + st <- get + ss' <- inlineStmts endLabel (map ctxItem ss) + return (Compound (map nullCtx ss'):stmts') +inlineStmts endLabel (While expr stmt:stmts) = do + (renames,rewrites) <- getRewriteInfo + stmts' <- inlineStmts endLabel stmts + ss <- inlineStmts endLabel [stmt] + 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') +inlineStmts endLabel (For es0 e es1 stmt:stmts) = do + (renames,rewrites) <- getRewriteInfo + 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') +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') + +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')) + where verbotenNames = namesDefinedByFunc f + renameParm (Ctx _ (Var nm t)) = do + nm' <- renameToNewInInliner nm + return (nullCtx $ Var nm' t) + +runInliningOnHandler :: M.Map String FunctionFacts -> [Ctx Func] -> [Global] -> Handler -> Handler +runInliningOnHandler ff fs gs h = if noinlining (handlerName h) then h else + 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')) + where verbotenNames = namesDefinedByHandler h + renameParm (Ctx _ (Var nm t)) = do + nm' <- renameToNewInInliner nm + return (nullCtx $ Var nm' t) + +performInliningForStmt :: Ctx Statement -> OState [Ctx Statement] +performInliningForStmt s@(Ctx _ (Do (Ctx _ (Call cnm exprs)))) = do + refreshOState + (es,sss) <- inlineExprs exprs + fs <- get >>= return . optAllFuncs + case M.lookup (ctxItem cnm) fs of + Nothing -> return (concat sss ++ [nullCtx $ (Do (nullCtx (Call cnm es)))]) + Just f -> do + ss <- inlineVoidFunc f es + return $ (concat sss) ++ ss +performInliningForStmt s@(Ctx _ (Do expr)) = do + refreshOState + expr' <- inlineExpr expr + 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)))] +performInliningForStmt (Ctx _ (While expr s)) = do + refreshOState + bgnLoop <- mkName "bgnLoop" + (expr',stmts) <- inlineExpr' expr + ss <- performInliningForStmt (nullCtx s) + return $ case (stmts,ss) of + ([],[s']) -> [nullCtx $ While expr' (ctxItem s')] + ([],_) -> [nullCtx $ While expr' (Compound ss)] + _ -> ((nullCtx $ Label bgnLoop) : (stmts ++ case ss of + [] -> [nullCtx $ If expr' (Jump bgnLoop) NullStmt] + _ -> [nullCtx $ If expr' (Compound (ss ++ [nullCtx $ Jump bgnLoop])) NullStmt])) +performInliningForStmt s@(Ctx _ NullStmt) = refreshOState >> return [nullCtx NullStmt] +performInliningForStmt s@(Ctx _ (Decl (Var v t) Nothing)) = do + refreshOState + v' <- renameToNewInInliner v + pushLocal $ v' + return [nullCtx (Decl (Var v' t) Nothing)] +performInliningForStmt s@(Ctx _ (Decl (Var v t) (Just expr))) = do + refreshOState + (expr',stmts) <- inlineExpr' expr + v' <- renameToNewInInliner v + pushLocal v' + return (stmts ++ [nullCtx (Decl (Var v' t) (Just expr'))]) +performInliningForStmt s@(Ctx _ (Return Nothing)) = refreshOState >> return [nullCtx (Return Nothing)] +performInliningForStmt s@(Ctx _ (Return (Just expr))) = do + refreshOState + expr' <- inlineExpr expr + stmts <- removeOStateStmts + return (stmts ++ [nullCtx (Return (Just expr'))]) +performInliningForStmt (Ctx _ l@(Label _)) = refreshOState >> return [nullCtx l] +performInliningForStmt (Ctx _ j@(Jump _)) = refreshOState >> return [nullCtx j] +performInliningForStmt (Ctx _ s@(StateChange _)) = refreshOState >> return [nullCtx s] +performInliningForStmt (Ctx _ (DoWhile s expr)) = do + refreshOState + bgnLoop <- mkName "bgnLoop" + ss <- performInliningForStmt (nullCtx s) + (expr',stmts) <- inlineExpr' expr + let s' = case ss ++ stmts of + [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" + (ies1',iss1s) <- inlineExprs ies1 + (mte',tss) <- case mte of + Nothing -> return (Nothing,[]) + Just te -> do (te',tss) <- inlineExpr' te + return (Just te',tss) + (ses2', sss2s) <- inlineExprs ses2 + ss <- performInliningForStmt (nullCtx s) + let iss1 = concat iss1s + let sss2 = concat sss2s + case (iss1,tss,sss2,ss) of + ([],[],[],[s']) -> return [(nullCtx $ For ies1' mte' ses2' (ctxItem s'))] + ([],[],[],_) -> return [(nullCtx $ For ies1' mte' ses2' (Compound ss))] + _ -> return (iss1 ++ (map (nullCtx . Do) ies1') ++ [nullCtx $ Label bgnLoop] ++ rest) + where rest = case mte' of + Nothing -> ss ++ sss2 ++ (map (nullCtx . Do) ses2') ++ [nullCtx $ Jump bgnLoop] + Just te' -> tss ++ + [nullCtx $ If te' (Compound (ss ++ sss2 ++ (map (nullCtx . Do) ses2') ++ [nullCtx $ Jump bgnLoop])) NullStmt] +performInliningForStmt (Ctx _ (If e s0 s1)) = do + refreshOState + (e',ess) <- inlineExpr' e + s0s <- performInliningForStmt (nullCtx s0) + s1s <- performInliningForStmt (nullCtx s1) + let branch1 = case s0s of + [s] -> ctxItem s + _ -> Compound s0s + let branch2 = case s1s of + [s] -> ctxItem s + _ -> Compound s1s + return (ess ++ [nullCtx $ If e' branch1 branch2]) + +inlineExprs :: [Ctx Expr] -> OState ([Ctx Expr], [[Ctx Statement]]) +inlineExprs exprs = do + es <- mapM inlineExpr' exprs + return $ foldr combine ([],[]) es + where combine :: (Ctx Expr, [Ctx Statement]) -> ([Ctx Expr],[[Ctx Statement]]) -> ([Ctx Expr],[[Ctx Statement]]) + combine (e,ss) (es,sss) = (e:es,ss:sss) +inlineExpr' :: Ctx Expr -> OState (Ctx Expr,[Ctx Statement]) +inlineExpr' expr = do + expr' <- inlineExpr expr + stmts <- removeOStateStmts + return (expr',stmts) + +inlineExpr :: Ctx Expr -> OState (Ctx Expr) +inlineExpr = everywhereM (mkM inlineCall `extM` renameRef) + +inlineCall c@(Call (Ctx _ nm) es) = do + fs <- get >>= return . optAllFuncs + tmp <- get >>= return . optInlinerRenames + tmp1 <- get >>= return . optRenames + case M.lookup nm fs of + Nothing -> return c + Just f -> do + (e, stmts) <- inlineFunc f es + st <- get + put st { optStmts = (stmts:(optStmts st)) } + return e +inlineCall e = return e +renameRef :: (Ctx String, Component) -> OState (Ctx String,Component) +renameRef (Ctx ctx nm, v) = do + nm' <- inlinerRenamingFor nm + return (Ctx ctx nm', v) + +isRelativelyPure :: [String] -> (M.Map String FunctionFacts) -> Ctx Expr -> Bool +isRelativelyPure locals ff = everything (&&) (True `mkQ` go) + where + go (Get (cnm,_)) = nm `elem` locals || nm `elem` (map constName allConstants) where nm = ctxItem cnm + go (Set _ _) = False + go (IncBy _ _) = False + go (DecBy _ _) = False + go (MulBy _ _) = False + go (DivBy _ _) = False + go (ModBy _ _) = False + go (PostInc _) = False + go (PostDec _) = False + go (PreInc _) = False + go (PreDec _) = False + go (Call (Ctx _ nm) _) = + case M.lookup nm ff of + Nothing -> False + Just facts -> isPureFunction facts + go _ = True + +-- a notion of how much codespace would be wasted if an expression +-- was copied wherever it was used, versus computed in one place +staticComplexity :: Ctx Expr -> Int +staticComplexity = everything (+) (0 `mkQ` go) + 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) + where + rwExpr e@(Get (Ctx _ nm,All)) = + case M.lookup nm rewrites of + Nothing -> e + Just e' -> e' + rwExpr e = e + rwName c@(Ctx _ nm) = + case M.lookup nm renames of + Nothing -> c + Just nm' -> nullCtx nm' + +usageCount :: String -> [Ctx Statement] -> Int +usageCount nm = everything (+) (0 `mkQ` refCount) + where refCount :: (Ctx String, Component) -> Int + refCount (Ctx _ nm',_) | nm == nm' = 1 + | otherwise = 0 + +isUsedOnlyWholeIn :: String -> [Ctx Statement] -> Bool +isUsedOnlyWholeIn nm = everything (&&) (True `mkQ` whole) + where whole :: (Ctx String, Component) -> Bool + whole (_, All) = True + whole (Ctx _ nm',_) | nm == nm' = False + | otherwise = True + +countOfSetsOf :: String -> [Ctx Statement] -> Int +countOfSetsOf nm = everything (+) (0 `mkQ` count) + where count (Set (Ctx _ nm',All) _) | nm == nm' = 1 + | otherwise = 0 + count _ = 0 + +isModifiedIn :: String -> [Ctx Statement] -> Bool +isModifiedIn nm = everything (||) (False `mkQ` modified) + where modified (Set (Ctx _ nm',_) _) = nm == nm' + modified (IncBy (Ctx _ nm',_) _) = nm == nm' + modified (DecBy (Ctx _ nm',_) _) = nm == nm' + modified (MulBy (Ctx _ nm',_) _) = nm == nm' + modified (DivBy (Ctx _ nm',_) _) = nm == nm' + modified (ModBy (Ctx _ nm',_) _) = nm == nm' + modified (PreDec (Ctx _ nm',_)) = nm == nm' + modified (PreInc (Ctx _ nm',_)) = nm == nm' + modified (PostDec (Ctx _ nm',_)) = nm == nm' + modified (PostInc (Ctx _ nm',_)) = nm == nm' + modified _ = False + +jumpsTo :: String -> [Ctx Statement] -> Int +jumpsTo label = everything (+) (0 `mkQ` count) + where count (Jump l) | l == label = 1 + | otherwise = 0 + count _ = 0 + +withoutFinalJumpTo label [] = [] +withoutFinalJumpTo label ss = + case final of + (Ctx _ (Jump l)) | l == label -> initial + | otherwise -> ss + (Ctx c (Compound ss')) -> initial ++ [(Ctx c (Compound (withoutFinalJumpTo label ss')))] + (Ctx c (If expr s0 s1)) -> initial ++ [Ctx c (If expr (rmvj s0) (rmvj s1))] + (Ctx c s) -> ss + where final = last ss + initial = init ss + rmvj s@(Jump l) | l == label = NullStmt + | otherwise = s + rmvj (Compound ss) = Compound (withoutFinalJumpTo label ss) + rmvj s = s + +-- an explicit dictionary (could create a class for this, but seems unnecessary) +data ScopeFuncs m = ScopeFuncs { sfPushFrame :: m (), sfPopFrame :: m (), sfPushVar :: String -> m (), sfVars :: m [String] } + +type NamesState = State.State [[String]] + +nameStateScopeFuncs :: ScopeFuncs NamesState +nameStateScopeFuncs = ScopeFuncs pushFrame popFrame pushVar (get >>= return . concat) + +pushFrame :: NamesState () +pushFrame = get >>= put . ([]:) +popFrame :: NamesState () +popFrame = get >>= ( \ s -> if null s then error "stack empty: cannot pop frame" else put (tail s)) +pushVar v = do + st <- get + case st of + [] -> error "stack empty: cannot add variable" + (f:fs) -> put ((v:f):fs) + +sccsPurity :: M.Map String Expr -> M.Map String FunctionFacts -> [SCC (Ctx Func)] -> M.Map String FunctionFacts +sccsPurity gcs ff = foldl' (sccPurity gcs) ff + +sccPurity :: M.Map String Expr -> M.Map String FunctionFacts -> SCC (Ctx Func) -> M.Map String FunctionFacts +sccPurity gcs ff scc = + case scc of + AcyclicSCC f -> go [f] + CyclicSCC fs -> go fs + where go fs = ff `M.union` ( M.fromList $ map ( \ f -> (fname f, FunctionFacts purity)) fs) + where purity = not $ or $ map (isImpure (M.keysSet gcs) ff) fs + +stmtIn sfs s@(Compound _) = (sfPushFrame sfs) >> return s +stmtIn _ s = return s +funcDecIn sfs fd@(Func (FuncDec _ _ parms) _) = (sfPushFrame sfs) >> mapM_ (\ cv -> (sfPushVar sfs) $ (varName . ctxItem) cv) parms >> return fd +stmtOut sfs s@(Compound _) = (sfPopFrame sfs) >> return s +stmtOut sfs s@(Decl v _) = ((sfPushVar sfs) $ varName v) >> return s +stmtOut _ s = return s +handlerDecIn sfs h@(Handler _ parms _) = (sfPushFrame sfs) >> mapM_ (\ cv -> (sfPushVar sfs) $ (varName . ctxItem) cv) parms >> return h +handlerDecOut sfs h@(Handler _ _ _) = (sfPopFrame sfs) >> return h +funcDecOut sfs f@(Func (FuncDec _ _ _) _) = (sfPopFrame sfs) >> return f + +cvt :: Monad m => (a -> m a) -> b -> a -> m b +cvt f v x = f x >> return v + +isImpure :: Set.Set String -> M.Map String FunctionFacts -> Ctx Func -> Bool +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) + call c@(Call nm _) = do + case M.lookup (ctxItem nm) ff of + Just (FunctionFacts { isPureFunction = False }) -> return True + _ -> return False + call e = return False + ref:: ScopeFuncs NamesState -> (Ctx String, Component) -> NamesState Bool + ref sfs v@(Ctx _ nm,_) = do + locals <- sfVars sfs + return (nm `notElem` locals && (not $ isConst nm)) + isConst nm = (nm `Set.member` consts) || (nm `elem` map constName allConstants) + +isConstant :: Data a => String -> [a] -> Bool +isConstant s xs = not $ evalState (isntConstantM s xs) [] + +isntConstantM :: (Data a) => String -> [a] -> NamesState Bool +isntConstantM s = everythingTwice (liftM2 (||)) (return False `mkQ` cvt (funcDecIn sfs) False `extQ` + cvt (stmtIn sfs) False `extQ` modified `extQ` cvt (handlerDecIn sfs) False) + (return False `mkQ` cvt (funcDecOut sfs) False `extQ` + cvt (handlerDecOut sfs) False `extQ` cvt (stmtOut sfs) False) + where sfs = nameStateScopeFuncs + checkNm nm = (sfVars sfs) >>= return . ((nm == s) &&) . (notElem nm) + 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 False + +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 + (everythingTwice (liftM2 (||)) (return False `mkQ` cvt (funcDecIn sfs) False `extQ` + cvt (stmtIn sfs) False `extQ` used `extQ` cvt (handlerDecIn sfs) False) + (return False `mkQ` cvt (funcDecOut sfs) False `extQ` + cvt (handlerDecOut sfs) False `extQ` cvt (stmtOut sfs) False) v) [] + where sfs = nameStateScopeFuncs + used :: (Ctx String,Component) -> NamesState Bool + used (Ctx _ nm,_) = (sfVars sfs) >>= return . ((nm == s) &&) . (notElem nm) + +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 + 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 + Nothing -> e + Just e' -> e' + go e@(Neg (Ctx _ (IntLit i))) = (IntLit (-i)) + go e@(Neg (Ctx _ (FloatLit f))) = (FloatLit (-f)) + go e = e + mexpr2expr m _ (Just expr) = expr2expr m expr + mexpr2expr m LLFloat Nothing = FloatLit 0 + mexpr2expr m LLInteger Nothing = IntLit 0 + mexpr2expr m LLString Nothing = StringLit "" + mexpr2expr m LLList Nothing = ListExpr [] + mexpr2expr m LLVector Nothing = VecExpr (nullCtx $ FloatLit 0) (nullCtx $ FloatLit 0) (nullCtx $ FloatLit 0) + mexpr2expr m LLRot Nothing = RotExpr (nullCtx $ FloatLit 0) (nullCtx $ FloatLit 0) (nullCtx $ FloatLit 0) (nullCtx $ FloatLit 1) + mexpr2expr m LLKey Nothing = KeyLit "" + mexpr2expr m LLVoid Nothing = error "somehow, an expression of type void?" + +bb2int :: (a -> a -> Bool) -> a -> a -> Int +bb2int op x y = if op x y then 1 else 0 + +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), + siConstants :: !(M.Map String Expr), + siLocalsInScope :: ![[String]] + } + +simpInfoScopeFuncs = ScopeFuncs { + sfPushFrame = get >>= \ si -> put si { siLocalsInScope = [] : (siLocalsInScope si) }, + sfPopFrame = do + si <- get + case siLocalsInScope si of + [] -> error "stack empty, cannot pop frame" + (f:fs) -> put si { siLocalsInScope = fs }, + sfPushVar = (\ s -> do + si <- get + case siLocalsInScope si of + [] -> error "stack empty, cannot push variable" + (f:fs) -> put si { siLocalsInScope = ((s:f):fs) }), + sfVars = get >>= return . concat . siLocalsInScope + } + +type SimpState a = State.State SimplificationInfo a + +floatToLit :: RealFloat a => a -> Expr +floatToLit = FloatLit . realToFrac + +valToExpr :: RealFloat a => LSLValue a -> Expr +valToExpr (IVal i) = IntLit i +valToExpr (FVal f) = floatToLit f +valToExpr (SVal s) = StringLit s +valToExpr (KVal k) = KeyLit k +valToExpr (VVal x y z) = VecExpr (nullCtx $ floatToLit x) (nullCtx $ floatToLit y) (nullCtx $ floatToLit z) +valToExpr (RVal x y z s) = RotExpr (nullCtx $ floatToLit x) (nullCtx $ floatToLit y) (nullCtx $ floatToLit z) (nullCtx $ floatToLit s) +valToExpr (LVal l) = ListExpr (map (nullCtx . valToExpr) l) +valToExpr VoidVal = error "can't convert the void value to an expression" + +predefToLit :: String -> Maybe Expr +predefToLit s = fmap valToExpr (findConstVal s) + +constVarToLit :: M.Map String Expr -> String -> Maybe Expr +constVarToLit m s = M.lookup s m + +nameToLit :: M.Map String Expr -> String -> Maybe Expr +nameToLit m s = predefToLit s `mplus` constVarToLit m s + +exprsToVals :: [Ctx Expr] -> Maybe [LSLValue Double] +exprsToVals es = mapM exprToVal es + where exprToVal :: Ctx Expr -> Maybe (LSLValue Double) + exprToVal (Ctx _ (IntLit i)) = Just (IVal i) + exprToVal (Ctx _ (FloatLit f)) = Just (FVal f) + exprToVal (Ctx _ (StringLit s)) = Just (SVal s) + exprToVal (Ctx _ (KeyLit k)) = Just (KVal k) + exprToVal (Ctx _ (VecExpr ex ey ez)) = + case (exprToVal ex, exprToVal ey, exprToVal ez) of + (Just (FVal x),Just (FVal y),Just (FVal z)) -> Just (VVal x y z) + _ -> Nothing + exprToVal (Ctx _ (RotExpr ex ey ez es)) = + case (exprToVal ex, exprToVal ey, exprToVal ez, exprToVal es) of + (Just (FVal x),Just (FVal y),Just (FVal z),Just (FVal s)) -> Just (RVal x y z s) + _ -> Nothing + exprToVal (Ctx _ (ListExpr es)) = case exprsToVals es of + 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))) +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)) +simplifyE (And (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (fromBool (i /= 0 && j /= 0))) +simplifyE (Or (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (fromBool (i /= 0 || j /= 0))) +simplifyE (Lt (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (<) i j)) +simplifyE (Gt (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (>) i j)) +simplifyE (Ge (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (>=) i j)) +simplifyE (Le (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (<=) i j)) +simplifyE (Equal (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (==) i j)) +simplifyE (NotEqual (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (bb2int (==) i j)) +simplifyE (BAnd (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i .&. j)) +simplifyE (BOr (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i .|. j)) +simplifyE (Xor (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i `xor` j)) +simplifyE (ShiftL (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i `shiftL` j)) +simplifyE (ShiftR (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) = return (IntLit (i `shiftR` j)) +simplifyE e@(Div (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) | j /= 0 = return (IntLit ( i `div` j)) + | otherwise = return e +simplifyE e@(Mod (Ctx _ (IntLit i)) (Ctx _ (IntLit j))) | j /= 0 = return (IntLit ( i `mod` j)) + | otherwise = return e +simplifyE (Neg (Ctx _ (FloatLit i))) = return (FloatLit (-i)) +simplifyE (Add (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (i + j)) +simplifyE (Mul (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (i * j)) +simplifyE (Sub (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (FloatLit (i - j)) +simplifyE (Lt (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (<) i j)) +simplifyE (Gt (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (>) i j)) +simplifyE (Ge (Ctx _ (FloatLit i)) (Ctx _ (FloatLit j))) = return (IntLit (bb2int (>=) i j)) +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 (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 (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)) +simplifyE (Gt (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i > j then 1 else 0)) +simplifyE (Le (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i <= j then 1 else 0)) +simplifyE (Ge (Ctx _ (IntLit i)) (Ctx _ (FloatLit j))) = return (IntLit (if fromIntegral i >= j then 1 else 0)) +simplifyE (Add (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (FloatLit (i + fromIntegral j)) +simplifyE (Mul (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (FloatLit (i * fromIntegral j)) +simplifyE (Sub (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (FloatLit (i - fromIntegral j)) +simplifyE e@(Div (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) | j /= 0 = return (FloatLit ( i / fromIntegral j)) + | otherwise = return e +simplifyE (Equal (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i == fromIntegral j then 1 else 0)) +simplifyE (NotEqual (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i == fromIntegral j then 0 else 1)) +simplifyE (Lt (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i < fromIntegral j then 1 else 0)) +simplifyE (Gt (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i > fromIntegral j then 1 else 0)) +simplifyE (Le (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i <= fromIntegral j then 1 else 0)) +simplifyE (Ge (Ctx _ (FloatLit i)) (Ctx _ (IntLit j))) = return (IntLit (if i >= fromIntegral j then 1 else 0)) +simplifyE e@(Get (nm,c)) = do + locals <- get >>= return . concat . siLocalsInScope + if name `elem` locals + then return e + else newExpr + where name = ctxItem nm + newExpr = do + m <- get >>= return . siConstants + return $ case nameToLit m name of + Nothing -> e + Just e' -> case (c,e') of + (All,_) -> e' + (X,VecExpr x _ _) -> ctxItem x + (X,RotExpr x _ _ _) -> ctxItem x + (Y,VecExpr _ y _) -> ctxItem y + (Y,RotExpr _ y _ _) -> ctxItem y + (Z,VecExpr _ _ z) -> ctxItem z + (Z,RotExpr _ _ z _) -> ctxItem z + (S,RotExpr _ _ _ s) -> ctxItem s + _ -> e +simplifyE e@(Call (Ctx _ nm) exprs) = + case exprsToVals exprs of + Nothing -> return e + Just vs -> + case lookup nm internalLLFuncs of + Just f -> return (valToExpr $ snd (Id.runIdentity (f () vs))) + Nothing -> do + pureFuncs <- get >>= return . siPureFuncs + script <- get >>= return . siScript + if nm `Set.member` pureFuncs + then case simSFunc (script,[nm]) [] vs of + Left _ -> return e + Right (VoidVal,_) -> return e + Right (v,_) -> return $ valToExpr 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) + where SVal s = toSVal (FVal f') + f' :: Float + f' = realToFrac f +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 = return 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) + (mkM simplifyE `extM` stmtOut simpInfoScopeFuncs `extM` + funcDecOut simpInfoScopeFuncs `extM` handlerDecOut simpInfoScopeFuncs) diff --git a/src/Language/Lsl/Internal/OptimizerOptions.hs b/src/Language/Lsl/Internal/OptimizerOptions.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/Internal/OptimizerOptions.hs @@ -0,0 +1,3 @@ +module Language.Lsl.Internal.OptimizerOptions(OptimizerOption(..)) where + +data OptimizerOption = OptimizationInlining deriving (Show,Eq) diff --git a/src/Language/Lsl/Internal/Pragmas.hs b/src/Language/Lsl/Internal/Pragmas.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/Internal/Pragmas.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable #-} +module Language.Lsl.Internal.Pragmas(Pragma(..)) where + +import Data.Data(Data,Typeable) + +data Pragma = PragmaInline | PragmaNoInline + deriving (Show,Ord,Eq,Typeable,Data) 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 @@ -7,6 +7,8 @@ typeOfLSLComponent, parseFloat, parseInt, + parseVector, + parseRotation, lslValueComponent, replaceLslValueComponent, lslValString, @@ -43,16 +45,16 @@ import Language.Lsl.Internal.Util(lookupM,readM,cross,quaternionMultiply,quaternionToMatrix,fromInt) import Language.Lsl.Internal.DOMProcessing(Element(..),ElemAcceptor(..),findValue,elementsOnly,simple,attrString,acceptList) -import Text.Printf(printf) +import Text.Printf(printf,PrintfArg(..)) data LSLType = LLList | LLInteger | LLVector | LLFloat | LLString | LLRot | LLKey | LLVoid deriving (Eq, Show, Typeable, Data) -- A value. Values correspond to the built in types (LSLType) that LSL -- supports. A value is an item that can be pushed onto the value stack. -data LSLValue = IVal Int | FVal Float | SVal String | VVal Float Float Float - | RVal Float Float Float Float | LVal [LSLValue] | KVal String - | VoidVal deriving (Show,Eq,Ord) +data LSLValue a = IVal Int | FVal a | SVal String | VVal a a a + | RVal a a a a | LVal [LSLValue a] | KVal String + | VoidVal deriving (Show,Eq,Ord) data Component = X | Y | Z | S | All deriving (Eq,Show, Typeable, Data) @@ -84,6 +86,7 @@ replaceLslValueComponent All v v' = v' replaceLslValueComponent c v v' = error ("can't replace component " ++ (show c) ++ " of value " ++ (show v) ++ " with value " ++ (show v')) +typeOfLSLValue :: (RealFloat a) => LSLValue a -> LSLType typeOfLSLValue v = case v of (IVal _) -> LLInteger @@ -103,7 +106,7 @@ -- convert a value to a string 'internally' (TODO: where SHOULD this be used? It's used in internal funcs, but -- probably will not work completely correctly when tabs, newlines, or double quotes are involved) lslValString (IVal i) = (show i) -lslValString (FVal f) = (printf "%.6f" f) +lslValString (FVal f) = (printf "%.6f" ((realToFrac f) :: Double)) lslValString (SVal s) = s lslValString (KVal k) = k lslValString (VVal x y z) = concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,">"] @@ -186,9 +189,9 @@ [] -> reads s v -> v -toSVal :: LSLValue -> LSLValue +toSVal :: RealFloat a => LSLValue a -> LSLValue a toSVal (SVal s) = SVal s -toSVal (FVal f) = SVal (printf "%.6f" f) +toSVal (FVal f) = SVal (printf "%.6f" (realToFrac f :: Double)) toSVal (IVal i) = SVal (show i) toSVal (KVal k) = SVal k toSVal (VVal x y z) = SVal $ concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,">"] @@ -198,10 +201,10 @@ SVal $ concatMap toS l where toS v = let (SVal s) = toSVal v in s -comp2Str :: Float -> String -comp2Str f = printf "%.5f" f +comp2Str :: RealFloat a => a -> String +comp2Str f = printf "%.5f" (realToFrac f :: Double) -lslValueElement :: MonadError String m => ElemAcceptor m LSLValue +lslValueElement :: (RealFloat a, Read a, MonadError String m) => ElemAcceptor m (LSLValue a) lslValueElement = let f e@(Elem _ attrs contents) = do valType <- lookupM "class" attrs @@ -256,4 +259,4 @@ liftV2 f = \ x y -> vec2VVal $ f (vVal2Vec x) (vVal2Vec y) rot2RVal (x,y,z,s) = RVal x y z s -rVal2Rot (RVal x y z s) = (x,y,z,s) +rVal2Rot (RVal x y z s) = (x,y,z,s) diff --git a/src/Language/Lsl/Internal/UnitTester.hs b/src/Language/Lsl/Internal/UnitTester.hs --- a/src/Language/Lsl/Internal/UnitTester.hs +++ b/src/Language/Lsl/Internal/UnitTester.hs @@ -20,7 +20,7 @@ -- trace1 x = trace (show x) x -testExecutionElement :: MonadError String m => ElemAcceptor m (([(String,String)],[(String,String)]),[LSLUnitTest]) +testExecutionElement :: MonadError String m => ElemAcceptor m ((Bool,[(String,String)],[(String,String)]),[LSLUnitTest]) testExecutionElement = let f (Elem _ _ contents) = do (sources,contents1) <- findElement sourceFilesElement [ e | e@(CElem _ _) <- contents] diff --git a/src/Language/Lsl/Internal/WorldState.hs b/src/Language/Lsl/Internal/WorldState.hs --- a/src/Language/Lsl/Internal/WorldState.hs +++ b/src/Language/Lsl/Internal/WorldState.hs @@ -203,7 +203,7 @@ randGen :: !StdGen, wlibrary :: ![(String,Validity LModule)], wscripts :: ![(String,Validity CompiledLSLScript)], - worldEventHandler :: !(Maybe (String, [(String,LSLValue)])), + worldEventHandler :: !(Maybe (String, [(String,LSLValue Float)])), worldAvatars :: !(Map String Avatar), worldBreakpointManager :: !BreakpointManager, worldSuspended :: !(Maybe (String,String)), -- prim-key, script-name, image @@ -285,7 +285,7 @@ getWorldPendingHTTPRequests = queryWorld worldPendingHTTPRequests getWorldOpenDataChannels :: Monad m => WorldM m (Map String (String,String), Map (String,String) String) getWorldOpenDataChannels = queryWorld worldOpenDataChannels -getWorldEventHandler :: Monad m => WorldM m (Maybe (String,[(String,LSLValue)])) +getWorldEventHandler :: Monad m => WorldM m (Maybe (String,[(String,LSLValue Float)])) getWorldEventHandler = queryWorld worldEventHandler getWorldXMLRequestRegistry :: Monad m => WorldM m (Map String XMLRequestSourceType) getWorldXMLRequestRegistry = queryWorld worldXMLRequestRegistry @@ -465,7 +465,7 @@ | ResetScript String String -- prim key, script name | ResetScripts String -- object name | WorldSimEvent { worldSimEventName :: String, worldSimEventArgs :: [SimEventArg] } - | DeferredScriptEvent { deferredScriptEvent :: Event, deferredScriptEventTarget :: DeferredScriptEventTarget } + | DeferredScriptEvent { deferredScriptEvent :: Event Float, deferredScriptEventTarget :: DeferredScriptEventTarget } | Chat { chatChannel :: Int, chatterName :: String, chatterKey :: String, chatMessage :: String, chatLocation :: ((Int,Int),(Float,Float,Float)), chatRange :: Maybe Float } @@ -567,12 +567,12 @@ data PredefFunc m = PredefFunc { predefFuncName :: String, predefFuncResultType :: LSLType, - predef :: ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue) } + predef :: ScriptInfo Float -> [LSLValue Float] -> ErrorT String (WorldM m) (EvalResult,LSLValue Float) } deriving (Show) -instance Monad m => Show (ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue)) where +instance Monad m => Show (ScriptInfo Float -> [LSLValue Float] -> WorldM m (EvalResult,LSLValue Float)) where showsPrec _ _ = showString "(function :: ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue))" -instance Monad m => Show (ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue)) where +instance Monad m => Show (ScriptInfo Float -> [LSLValue Float] -> ErrorT String (WorldM m) (EvalResult,LSLValue Float)) where showsPrec _ _ = showString "(function :: ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue))" evalErrorT :: ErrorT String m v -> m (Either String v) diff --git a/src/Language/Lsl/NewUnitTest.hs b/src/Language/Lsl/NewUnitTest.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/NewUnitTest.hs @@ -0,0 +1,73 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/NewUnitTestEnv.hs @@ -0,0 +1,270 @@ +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 @@ -9,17 +9,79 @@ parseModuleFromStringAQ ) where +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as UTF8 import Data.Char(digitToInt) import Data.List(intersperse) -import Language.Lsl.Syntax(Expr(..),Statement(..),Func(..),FuncDec(..),Handler(..),State(..),Ctx(..),SourceContext(..),LSLType(..), +import Language.Lsl.Internal.Pragmas(Pragma(..)) +import Language.Lsl.Syntax(Expr(..),Statement(..),Func(..),FuncDec(..),Handler(Handler),State(..),Ctx(..),TextLocation(..),SourceContext(..),LSLType(..), Component(..),Var(..),LModule(..),LSLScript(..),GlobDef(..),goodHandlers) import Text.ParserCombinators.Parsec hiding (State) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language( javaStyle ) +import qualified Text.ParserCombinators.ParsecExtras.Token as P +import Text.ParserCombinators.ParsecExtras.Language( javaStyle, emptyDef ) import Text.ParserCombinators.Parsec.Error import Control.Monad.Error(liftIO) import Control.Monad.Trans(MonadIO) +import Debug.Trace + +data ParseState = ParseState { + atStart :: !Bool, + parseAntiQuotations :: !Bool, + pendingPragmas :: ![Pragma], + trailingWS :: !String, + leadingWS :: !String + } + +getAQState = getState >>= return . parseAntiQuotations + +newAQState = ParseState { atStart = True, parseAntiQuotations = True, pendingPragmas = [], trailingWS = "", leadingWS = "" } +newNoAQState = ParseState { atStart = True, parseAntiQuotations = False, pendingPragmas = [], trailingWS = "", leadingWS = "" } + +data WS = WSSimple { wsText :: String } | WSSingle { wsText :: String } | WSMulti { wsText :: String } + deriving Show +custWS simpleSpace oneLineComment multiLineComment = do + st <- getState + ws <- many ((simpleSpace >>= return . WSSimple) <|> + (oneLineComment >>= return . WSSingle) <|> + (multiLineComment >>= return . WSMulti) "") + let (trailing,leading) = if atStart st then ([],ws) else extractTrailing ws + let pragmas = foldl extractPragma [] leading + setState st { atStart = False, + pendingPragmas = pragmas, + trailingWS = wsCat trailing, + leadingWS = wsCat leading } + where wsCat = concatMap wsText + extractTrailing [] = ([],[]) + extractTrailing (WSSimple txt:rest) = + case break (=='\n') txt of + (ttxt,[]) -> let (t,rest') = extractTrailing rest in (WSSimple ttxt:t,rest') + ([],mtxt) -> ([],WSSimple mtxt:rest) + (ttxt,mtxt) -> ([WSSimple ttxt],WSSimple mtxt:rest) + extractTrailing (ws@(WSSingle txt):rest) = ([ws],rest) + extractTrailing (ws@(WSMulti txt):rest) | '\n' `elem` txt = ([ws],rest) + | otherwise = let (t,rest') = extractTrailing rest in (ws:t,rest') + extractPragma ps (WSSingle txt) = maybe ps (:ps) (parsePragma txt) + extractPragma ps _ = ps + +parsePragma :: String -> Maybe Pragma +parsePragma txt = + case parse parser "" txt of + Left _ -> Nothing + Right p -> Just p + where + pragmaStyle = emptyDef { P.reservedNames = ["pragma","inline","noinlining"], P.commentLine = "--" } + lexer :: P.TokenParser () + lexer = P.makeTokenParser pragmaStyle + reserved = P.reserved lexer + ws = P.whiteSpace lexer + parser = do + ws + reserved "pragma" + pragma <- (reserved "inline" >> return PragmaInline) <|> (reserved "noinlining" >> return PragmaNoInline) + eof + return pragma + -- define basic rules for lexical analysis lslStyle = javaStyle { P.reservedOpNames= ["*","/","+","++","-","--","^","&","&&", @@ -30,8 +92,9 @@ P.caseSensitive = True, P.identStart = letter <|> char '_', P.opLetter = oneOf "*/+:!#$%&*+./=?@\\^|-~", - P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" } -lexer :: P.TokenParser Bool + P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~", + P.custWhiteSpace = Just custWS } +lexer :: P.TokenParser ParseState lexer = P.makeTokenParser lslStyle identLetter = P.identLetter lslStyle @@ -106,9 +169,9 @@ do wholeDigits <- many1 digit "number" let w = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt wholeDigits mf <- option Nothing (char '.' >> option (fromIntegral w) (fracPart False (fromIntegral w)) >>= return . Just) - return $ case mf of - Nothing -> Left w - Just f -> Right f + case mf of + Nothing -> try ( expon >>= \ p -> return $ Right (fromIntegral w * p) ) <|> (return $ Left w) + Just f -> return $ Right f stringLiteral = lexeme ( do{ str <- between (char '"') @@ -308,17 +371,18 @@ return $ Cast t e ctxify f = do + pragmas <- getState >>= return . pendingPragmas pos0 <- getPosition v <- f pos1 <- getPosition - return $ Ctx (pos2Loc (pos0,pos1)) v + return $ Ctx (pos2Ctx (pos0,pos1) pragmas) v notExpr = ctxify ((char '!' "prefix operator") >> whiteSpace >> expr2 >>= return.Not) invExpr = ctxify ((char '~' "prefix operator") >> whiteSpace >> expr2 >>= return.Inv) negExpr = ctxify ((char '-' "prefix operator") >> whiteSpace >> expr2 >>= return.Neg) atomicExpr = do - aq <- getState + aq <- getAQState (ctxify $ try ( do m <- option 1 (reservedOp "-" >> return (-1)) n <- naturalOrFloat @@ -350,18 +414,18 @@ unaryExpr = choice [try prefixExpr,notExpr,invExpr, negExpr,try castExpr,atomicExpr] -expr2 :: GenParser Char Bool (Ctx Expr) +expr2 :: GenParser Char ParseState (Ctx Expr) expr2 = choice [try assignment, try postfixExpr, unaryExpr] expr1 = orExpr -expr :: GenParser Char Bool (Ctx Expr) +expr :: GenParser Char ParseState (Ctx Expr) expr = do r <- choice [try assignment, expr1] mtrace "expr: " r exprParser :: String -> Either ParseError (Ctx Expr) -exprParser text = runParser expr False "" text +exprParser text = runParser (whiteSpace>>expr) newNoAQState "" text ------------------------------------------------------------------------------ -- STATEMENT PARSING @@ -451,9 +515,10 @@ stmt <- statement reserved "while" e <- parens expr + semi return $ DoWhile stmt e -parseType text = runParser typeName False "" text +parseType text = runParser typeName newNoAQState "" text ------------------------------------------------------------ -- HANDLER Parsing @@ -498,16 +563,21 @@ stateDecls = many stateDecl -------------------------------------------------------------- -varOrFunc = do (Ctx ctx (t,id)) <- ctxify $ do +varOrFunc = do pos0 <- getPosition + pragmas <- getState >>= return . pendingPragmas + (Ctx ctx (t,id)) <- ctxify $ do t <- try typeName id <- ctxify identifier "identifier" return (t,id) - choice [func t id, gvar ctx t id] - <|> do id <- ctxify identifier "identifier" - func LLVoid id -func t id = do ps <- parens params - stmts <- braces statements - return $ GF $ Func (FuncDec id t ps) stmts + choice [func t id pragmas pos0, gvar ctx t id] + <|> do pos0 <- getPosition + pragmas <- getState >>= return . pendingPragmas + id <- ctxify identifier "identifier" + func LLVoid id pragmas pos0 +func t id pragmas pos0 = do ps <- parens params + stmts <- braces statements + pos1 <- getPosition + return $ GF $ Ctx (pos2Ctx (pos0, pos1) pragmas) $ Func (FuncDec id t ps) stmts gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp' "=" >> expr >>= return . Just) semi return $ GV (Ctx ctx (Var id t)) mexpr @@ -573,7 +643,7 @@ return $ LModule globs freevars parseFromString parser string = - case runParser parser False "" string of + case runParser parser newNoAQState "" string of Left err -> Left (snd (fromParseError err)) Right x -> Right x @@ -586,55 +656,49 @@ -- | Parse an LSL script, with possible antiquotations, into its syntax tree. parseScriptFromStringAQ :: String -> Either ParseError LSLScript -parseScriptFromStringAQ s = runParser lslParser True "" s +parseScriptFromStringAQ s = runParser lslParser newAQState "" s -- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree. parseModuleFromStringAQ :: String -> Either ParseError LModule -parseModuleFromStringAQ s = runParser moduleParser True "" s +parseModuleFromStringAQ s = runParser moduleParser newAQState "" s -parseModule :: (MonadIO m) => SourceName -> m (Either (SourceContext,String) LModule) +parseModule :: (MonadIO m) => SourceName -> m (Either (Maybe SourceContext,String) LModule) parseModule file = parseFile moduleParser file parseScript file = parseFile lslParser file -fromParseError :: ParseError -> (SourceContext,String) +fromParseError :: ParseError -> (Maybe SourceContext,String) fromParseError err = let pos = errorPos err msg = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err) - in (TextLocation { textLine0 = sourceLine pos, textColumn0 = sourceColumn pos, - textLine1 = sourceLine pos, textColumn1 = sourceColumn pos, - textName = sourceName pos }, + in (Just $ SourceContext TextLocation { textLine0 = sourceLine pos, textColumn0 = sourceColumn pos, + textLine1 = sourceLine pos, textColumn1 = sourceColumn pos, + textName = sourceName pos } + "" "" [], msg) parseFile p file = - do s <- liftIO $ readFile file + do s <- (liftIO $ B.readFile file) >>= return . UTF8.toString case parser s of Left err -> return $ Left (fromParseError err) Right x -> return $ Right x - where parser = runParser p False file - -txtLoc pos len = - TextLocation { textName = sourceName pos, - textColumn0 = sourceColumn pos, - textLine0 = sourceLine pos, - textColumn1 = sourceColumn pos + (len-1), - textLine1 = sourceLine pos } + where parser = runParser p newNoAQState file -idLoc pos id = txtLoc pos $ length id - pos2Loc (pos0,pos1) = - TextLocation { + SourceContext TextLocation { textName = sourceName pos0, textColumn0 = sourceColumn pos0, textLine0 = sourceLine pos0, textColumn1 = sourceColumn pos1, textLine1 = sourceLine pos1 - } + } "" "" [] -combineContexts (UnknownSourceContext,pos0,pos1,UnknownSourceContext) = pos2Loc (pos0,pos1) -combineContexts (TextLocation l0 c0 l1 c1 n,_,_,TextLocation l0' c0' l1' c1' n') = - TextLocation l0 c0 l1' c1' n -combineContexts (TextLocation l0 c0 l1 c1 n,_,pos,_) = - TextLocation l0 c0 (sourceLine pos) (sourceColumn pos) n -combineContexts (_,pos,_,TextLocation l0 c0 l1 c1 n) = - TextLocation (sourceLine pos) (sourceColumn pos) l1 c1 n +pos2Ctx (pos0,pos1) pragmas = Just (pos2Loc (pos0,pos1)) { srcPragmas = pragmas } + +combineContexts (Nothing,pos0,pos1,Nothing) = Just $ pos2Loc (pos0,pos1) +combineContexts (Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre _ prag),_,_,Just (SourceContext (TextLocation l0' c0' l1' c1' n') _ post _ )) = + Just $ SourceContext (TextLocation l0 c0 l1' c1' n) pre post prag +combineContexts (Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag),_,pos,_) = + Just $ SourceContext (TextLocation l0 c0 (sourceLine pos) (sourceColumn pos) n) pre post prag +combineContexts (_,pos,_,Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag)) = + Just $ SourceContext (TextLocation (sourceLine pos) (sourceColumn pos) l1 c1 n) pre post prag 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 @@ -65,8 +65,9 @@ let render' [] = blank render' (v:vars) = renderChar ',' . renderVar v . render' vars in render' vars -renderFuncs = renderSequence renderFunc +renderFuncs = renderSequence renderCtxFunc +renderCtxFunc (Ctx _ func) = renderFunc func renderFunc (Func dec stmts) = renderFuncDec dec . renderString "{\n" . renderStatements 0 stmts . renderString "}\n" @@ -103,7 +104,7 @@ case val of Nothing -> renderString ";\n" Just expr -> renderString " = " . renderCtxExpr expr . renderString ";\n" -renderStatement' n (NullStmt) = blank +renderStatement' n (NullStmt) = blank . renderString "\n" renderStatement' n (Return Nothing) = renderString "return;\n" renderStatement' n (Return (Just expr)) = renderString "return " . renderCtxExpr expr . renderString ";\n"; renderStatement' n (StateChange name) = renderString "state " . renderString name . renderString ";\n"; @@ -122,7 +123,13 @@ renderExpression (IntLit i) = shows i renderExpression (FloatLit f) = shows f -renderExpression (StringLit s) = shows s +renderExpression (StringLit s) = renderString ('"':go s) + where go [] = "\"" + go ('\\':s) = '\\':'\\':go s + go ('\t':s) = '\\':'t':go s + go ('\n':s) = '\\':'n':go s + go ('"':s) = '\\':'"':go s + go (c:s) = c:go s renderExpression (KeyLit k) = shows k renderExpression (VecExpr x y z) = renderChar '<' . renderCtxExpr x . renderChar ',' . 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 @@ -75,7 +75,7 @@ import Text.Printf(PrintfType(..),printf) -- execute a predefined ('ll') function -doPredef :: Monad m => String -> ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue) +doPredef :: Monad m => String -> ScriptInfo Float -> [LSLValue Float] -> WorldM m (EvalResult,LSLValue Float) doPredef name info@(ScriptInfo oid pid sid pkey event) args = do predefs <- getPredefFuncs -- find the correct function to execute @@ -2566,7 +2566,7 @@ unimplementedFuncs = S.toList (S.difference (S.fromList allFuncs) (S.fromList implementedFuncs)) --------------------------------------------------------------------------------------------------- -logFromScript :: Monad m => ScriptInfo -> String -> WorldM m () +logFromScript :: Monad m => ScriptInfo Float -> String -> WorldM m () logFromScript scriptInfo msg = logAMessage LogInfo (infoToLogSource scriptInfo) msg infoToLogSource info = (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) @@ -3496,7 +3496,7 @@ data SimStatus = SimEnded { simStatusMessage :: String, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | SimInfo { simStatusEvents :: [SimEvent], simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | SimSuspended { simStatusEvents :: [SimEvent], - simStatusSuspendInfo :: ExecutionInfo, + simStatusSuspendInfo :: ExecutionInfo Float, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } deriving (Show) @@ -3521,7 +3521,7 @@ simInputEventName :: String, simInputEventDescription :: String, simInputEventParameters :: [SimParam], - simInputEventHandler :: String -> [LSLValue] -> WorldM m () } + simInputEventHandler :: String -> [LSLValue Float] -> WorldM m () } data SimParam = SimParam { simParamName :: String, simParamDescription :: String, simParamType :: SimParamType } 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 @@ -17,6 +17,7 @@ LSLScript(..), Validity, Global(..), + TextLocation(..), SourceContext(..), Ctx(..), CompiledLSLScript(..), @@ -35,8 +36,6 @@ nullCtx, ctxVr2Vr, findFunc, - --validLSLScript, - --validLibrary, moduleFromScript, findState, predefFuncs, @@ -44,17 +43,20 @@ goodHandlers, libFromAugLib, isTextLocation, + isCastValid, compileLSLScript, compileLSLScript', compileLibrary, VState, - emptyValidationState) where + emptyValidationState, + rewriteCtxExpr) where import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) import Language.Lsl.Internal.Constants(isConstant,findConstType) import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors) import Language.Lsl.Internal.FuncSigs(funcSigs) import Language.Lsl.Internal.AccessGenerator(genAccessorsForType,genMAccessorsForType) +import Language.Lsl.Internal.Pragmas(Pragma(..)) import Data.Generics import Data.Data(Data,Typeable) import Data.List(find,sort,sortBy,nub,foldl') @@ -69,15 +71,16 @@ import Debug.Trace --trace1 s v = trace (s ++ show v) v -data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } | - UnknownSourceContext +data TextLocation = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } + deriving (Show,Typeable,Data) +data SourceContext = SourceContext { srcTextLocation :: TextLocation, srcPreText :: String, srcPostTxt :: String, srcPragmas :: [Pragma] } deriving (Show,Typeable,Data) -isTextLocation (TextLocation _ _ _ _ _) = True +isTextLocation (Just (TextLocation _ _ _ _ _)) = True isTextLocation _ = False -- | A wrapper that can associate a source code context with a value (e.g. a syntax value). -data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) +data Ctx a = Ctx { srcCtx :: Maybe SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) instance Functor Ctx where fmap f (Ctx c v) = (Ctx c $ f v) @@ -87,7 +90,7 @@ fromMCtx = fmap ctxItem nullCtx :: a -> Ctx a -nullCtx = Ctx UnknownSourceContext +nullCtx = Ctx Nothing funcNames = map (ctxItem.funcName) @@ -107,6 +110,9 @@ deriving (Show,Typeable,Data) type CtxStmt = Ctx Statement + +type CtxFunc = Ctx Func + -- | An LSL function definition (return type, parameters and statements. data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data) @@ -118,7 +124,7 @@ type CtxExpr = Ctx Expr -- | An LSL expression. data Expr = IntLit Int - | FloatLit Float + | FloatLit Double | StringLit String | ListExpr [CtxExpr] | VecExpr CtxExpr CtxExpr CtxExpr @@ -188,10 +194,10 @@ deriving (Show,Typeable,Data) -- | A global definition (a function, a variable, or a module import statement). -data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String +data GlobDef = GV CtxVar (Maybe CtxExpr) | GF (Ctx Func) | GI CtxName [(String,String)] String deriving (Show,Typeable,Data) -- | An LSL event handler definition. -data Handler = Handler CtxName [CtxVar] [CtxStmt] +data Handler = Handler { handlerName :: CtxName, handlerParams :: [CtxVar], handlerStatements :: [CtxStmt] } deriving (Show,Typeable,Data) -- | The set of valid handlers supported by LSL. @@ -205,7 +211,7 @@ -- | An LSL script. data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) -type ModuleInfo = ([Global],[Func]) +type ModuleInfo = ([Global],[Ctx Func]) -- | A collection of modules. type Library = [(String,Validity LModule)] -- | A collection of mouldes, augmented with additional derived information. @@ -228,12 +234,12 @@ lookupModule :: String -> Library -> Validity LModule lookupModule name lib = case lookup name lib of - Nothing -> throwError [(UnknownSourceContext, "unknown module")] - Just (Left ((_,s):_)) -> throwError [(UnknownSourceContext, "invalid library (" ++ s ++ ")")] + Nothing -> throwError [(Nothing, "unknown module")] + Just (Left ((_,s):_)) -> throwError [(Nothing, "invalid library (" ++ s ++ ")")] Just (Right m) -> return m -- A description of an error and where to find it in the source. -type CodeErr = (SourceContext,String) +type CodeErr = (Maybe SourceContext,String) ctxFromCodeErr = fst msgFromCodeErr = snd @@ -242,44 +248,16 @@ type Validity a = Either [CodeErr] a instance Error [CodeErr] where - noMsg = [(UnknownSourceContext,"")] - strMsg s = [(UnknownSourceContext,s)] + noMsg = [(Nothing,"")] + strMsg s = [(Nothing,s)] -incontext (ctx,s) (Left ((ctx',s'):_)) = - case ctx' of - UnknownSourceContext -> Left [(ctx,msg)] - _ -> Left [(ctx',msg)] - where msg = if null s then s' else s ++ ": " ++ s' -incontext _ v = v - -incontext' (ctx,s) (Left ((_,s'):_)) = Left [(ctx,s ++ ": " ++ s')] -incontext' _ v = v - -------------------- matchTypes LLFloat LLInteger = True matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) -typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs) -typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = - return (vars,(FuncDec (fmap (prefix++) name) t params):funcs) -typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') = - do (LModule globs _) <- lookupModule (ctxItem moduleName) library - foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs -typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs - -noDupVars :: [String] -> [CtxVar] -> Validity [String] -noDupVars used [] = return used -noDupVars used ((Ctx ctx (Var n t)):vs) = do - when (n `elem` used) $ throwError [(ctx, n ++ " already defined")] - noDupVars (n:used) vs - -checkName :: Maybe SourceContext -> String -> [String] -> Validity () -checkName (Just ctx) name names = - when (name `elem` names) $ throwError [(ctx, name ++ " is multiply defined")] - data CompiledLSLScript = CompiledLSLScript { scriptGlobals :: ![Global], - scriptFuncs :: ![Func], + scriptFuncs :: ![Ctx Func], scriptStates :: ![State]} deriving (Show) @@ -288,16 +266,15 @@ data ValidationState = ValidationState { vsLib :: !Library, - vsGlobalRegistry :: !(M.Map String SourceContext), - vsLocalRegistry :: ![M.Map String SourceContext], + vsGlobalRegistry :: !(M.Map String (Maybe SourceContext)), + vsLocalRegistry :: ![M.Map String (Maybe SourceContext)], vsLocalVars :: ![[Var]], vsRefs :: !(M.Map RefPos SourceContext), vsLabels :: ![[String]], vsModules :: ![String], - vsGlobDefs :: ![GlobDef], vsStates :: ![State], vsGlobals :: ![Global], - vsFuncs :: ![Func], + vsFuncs :: ![Ctx Func], vsErr :: ![CodeErr], vsWarn :: ![CodeErr], vsNamesUsed :: [String], @@ -308,7 +285,7 @@ vsBranchReturns :: !Bool, vsHandlersUsed :: ![String], vsImports :: ![(String,[(String,String)],String)], - vsContext :: [SourceContext] + vsContext :: [Maybe SourceContext] } emptyValidationState = ValidationState { @@ -319,7 +296,6 @@ vsRefs = M.empty, vsLabels = [], vsModules = [], - vsGlobDefs = [], vsStates = [], vsGlobals = [], vsFuncs = [], @@ -362,10 +338,10 @@ registry <- get'vsGlobalRegistry case M.lookup name registry of Nothing -> return () - Just UnknownSourceContext -> return () - Just ctx -> do + Just Nothing -> return () + Just (Just ctx) -> do refs <- get'vsRefs - put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs) + put'vsRefs (M.insert (RefPos name (textLine0 $ srcTextLocation ctx) (textColumn0 $ srcTextLocation ctx)) ctx refs) vsmAddRef name ctx = do lr <- get'vsLocalRegistry @@ -374,17 +350,17 @@ go (top:rest) = do case M.lookup name top of Nothing -> go rest - Just UnknownSourceContext -> return () - Just ctx -> do + Just Nothing -> return () + Just (Just ctx) -> do refs <- get'vsRefs - put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs) + put'vsRefs (M.insert (RefPos name (textLine0 $ srcTextLocation ctx) (textColumn0 $ srcTextLocation ctx)) ctx refs) vsmAddGV :: Var -> VState () vsmAddGV var = get'vsGVs >>= put'vsGVs . (var:) vsmAddGF :: FuncDec -> VState () vsmAddGF fd = get'vsGFs >>= put'vsGFs . (fd:) -vsmAddFunc :: Func -> VState () +vsmAddFunc :: Ctx Func -> VState () vsmAddFunc func = get'vsFuncs >>= put'vsFuncs . (func :) vsmAddGlobal :: Global -> VState () @@ -393,7 +369,7 @@ vsmAddState :: State -> VState () vsmAddState state = get'vsStates >>= put'vsStates . (state :) -vsmAddLocal :: SourceContext -> Var -> VState () +vsmAddLocal :: Maybe SourceContext -> Var -> VState () vsmAddLocal ctx v@(Var name _) = do locals <- get'vsLocalVars case locals of @@ -442,7 +418,7 @@ vsmAddHandler handlerName = get'vsHandlersUsed >>= put'vsHandlersUsed . (handlerName:) -vsmWithContext :: SourceContext -> VState a -> VState a +vsmWithContext :: Maybe SourceContext -> VState a -> VState a vsmWithContext srcCtx action = do ctxs <- get'vsContext put'vsContext (srcCtx:ctxs) @@ -485,11 +461,6 @@ safeHead [] = Nothing safeHead (x:_) = Just x -vsmFirstErr :: VState (Maybe CodeErr) -vsmFirstErr = get'vsErr >>= \ l -> case l of - l@(_:_) -> return $ Just $ last l -- list is reversed... - _ -> return Nothing - compileLSLScript' :: Library ->LSLScript -> Validity CompiledLSLScript compileLSLScript' library script = evalState (compileLSLScript script) (emptyValidationState { vsLib = library }) @@ -500,7 +471,7 @@ mapM_ vsmAddGF predefFuncs mapM_ compileGlob globs mapM_ compileState states - err <- get'vsErr -- vsmFirstErr + err <- get'vsErr case err of [] -> do globals <- get'vsGlobals @@ -523,7 +494,7 @@ preprocessGlobDef :: String -> GlobDef -> VState () preprocessGlobDef prefix (GV (Ctx ctx v@(Var name t)) _) = vsmAddGV (Var (prefix ++ name) t) -preprocessGlobDef prefix (GF (Func (FuncDec name t params) _)) = vsmAddGF (FuncDec (fmap (prefix++) name) t params) +preprocessGlobDef prefix (GF (Ctx _ (Func (FuncDec name t params) _))) = vsmAddGF (FuncDec (fmap (prefix++) name) t params) preprocessGlobDef prefix (GI moduleName _ prefix') = do lib <- get'vsLib case lookupModule (ctxItem moduleName) lib of @@ -544,7 +515,7 @@ vsmRegisterGlobal v vsmAddToNamesUsed (varName v') vsmAddGlobal (GDecl v' (fmap ctxItem mexpr)) -compileGlob (GF f@(Func (FuncDec name t params) statements)) = +compileGlob (GF cf@(Ctx ctx f@(Func (FuncDec name t params) statements))) = vsmWithNewScope $ do compileParams params vsmInEntryPoint t False $ do @@ -553,7 +524,7 @@ when (not returns && t /= LLVoid) (vsmAddErr (srcCtx name, ctxItem name ++ ": not all code paths return a value")) vsmRegisterFunc f vsmAddToNamesUsed $ ctxItem name - vsmAddFunc f + vsmAddFunc cf compileGlob (GI (Ctx ctx name) bindings prefix) = vsmWithModule name $ do let imp = (name, sort bindings, prefix) @@ -572,7 +543,7 @@ vsmAddImport imp vsmWithContext ctx $ mapM_ (rewriteGlob' prefix renames (map ctxItem freevars ++ vars')) globs -rewriteGlob' prefix renames vars (GF (Func (FuncDec name t params) statements)) = +rewriteGlob' prefix renames vars (GF (Ctx ctx (Func (FuncDec name t params) statements))) = case lookup (ctxItem name) renames of Nothing -> vsmAddErr (srcCtx name, "can't rename " ++ ctxItem name ++ ": not found") Just name' -> do @@ -582,7 +553,7 @@ else let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) in do vsmAddToNamesUsed name' vsmRegisterFunc rewrittenFunc - vsmAddFunc rewrittenFunc + vsmAddFunc (Ctx ctx rewrittenFunc) rewriteGlob' prefix renames vars (GV (Ctx ctx (Var name t)) mexpr) = case lookup name renames of Nothing -> vsmAddErr (ctx, "can't rename " ++ name ++ ": not found") @@ -798,7 +769,7 @@ return $ Just LLInteger compileCtxExpr (Ctx ctx (Neg expr)) = do mt <- compileCtxExpr expr - (mt `whenIsJust` (==LLList)) $ vsmAddErr (ctx, "operator not applicable to list type") + (mt `whenIsJust` (`elem` [LLList,LLString,LLKey])) $ vsmAddErr (ctx, "operator not applicable to this type") return mt compileCtxExpr (Ctx ctx (Inv expr)) = do mt <- compileCtxExpr expr @@ -1165,77 +1136,6 @@ Just t | t `elem` [LLVoid,LLList] -> vsmAddErr (ctx,"invalid list element") | otherwise -> return () -validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript -validLSLScript library (LSLScript globs states) = - do (typedVars,typedFuncs) <- typeGlobs library globs - let vars = reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - validStates snames [] vars funcDecs states - return (CompiledLSLScript (reverse globvars) funcs states) - where snames = let sname (State cn _) = ctxItem cn in map sname states -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) = - do when (isConstant $ varName v') $ throwError [(srcCtx v, varName v' ++ " is a predefined constant")] - -- find the vars that are defined prior to this global variable -- only one of these - -- vars may be used to initialize the global variable. - when (varName v' `elem` namesUsed) $ throwError [(srcCtx v, varName v' ++ " is already defined")] - let (vars',_) = break (\ var -> varName var == varName v') vars - case mexpr of - Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed) - Just expr -> do - t <- validCtxSimple vars' expr - let vt = varType v' - when (not (matchTypes vt t)) $ throwError [(srcCtx expr, "expression not of the correct type")] - return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed) - where v' = ctxItem v -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) = - do noDupVars [] params - when (ctxItem name `elem` namesUsed) $ throwError [(srcCtx name, ctxItem name ++ " is already defined")] - returns <- validStatements False [] funcDecs vars t [] [[],params'] statements - when (not returns && t /= LLVoid) $ - throwError [(srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value")] - return (globvars,f:funcs,imports,(ctxItem name):namesUsed) - where params' = ctxItems params -validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) = - let context = incontext' (ctx,"module " ++ name) in - do let imp = (name,sort bindings,prefix) - if imp `elem` imports - then return (globvars,funcs,imports,namesUsed) - else context $ do - (LModule globs freevars) <- context $ lookupModule name library - context $ validBindings vars freevars bindings - (vars',funcDecs') <- context $ typeGlobs library globs - let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs - return (gvs,fs,imp:imports',namesUsed') - -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) = - do name' <- incontext (srcCtx name, "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) - return (globvars,rewrittenFunc:funcs,imports,name':namesUsed) -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) = - do name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenGlobVar = GDecl (Var name' t) $ - case mexpr of - Nothing -> Nothing - Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr)) - return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed) -rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) = - do (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library - incontext (ctx,"") $ validBindings vars freevars bindings - bindings' <- mapM rewriteBinding bindings - let imp = (mName,sort bindings',prefix0 ++ prefix) - if (imp `elem` imports) - then return (globvars,funcs,imports,namesUsed) - else do - (vars',funcDecs') <- typeGlobs library globs - let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs - return (gvs,fs,imp:imports',namesUsed') - where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv) - validBindings vars freevars bindings = if length freevars /= length bindings then throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required") @@ -1248,457 +1148,12 @@ | otherwise -> f xys in f bindings -validState snames used vars funcs (State (Ctx ctx name) handlers) = - do when (name `elem` used) $ throwError [(ctx, name ++ " already used")] - incontext (ctx,"") $ validHandlers snames [] funcs vars handlers - return name - -validStates snames used vars funcs [] = return () -validStates snames used vars funcs (s:ss) = - do name <- validState snames used vars funcs s - validStates snames (name:used) vars funcs ss - -validCast t0 t1 = - let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), - (LLInteger,LLString),(LLString,LLInteger), - (LLFloat,LLString),(LLString,LLFloat), - (LLString,LLVector),(LLVector,LLString), - (LLString,LLKey),(LLKey,LLString), - (LLRot,LLString),(LLString,LLRot), - (LLList,LLString),(LLString,LLList)] in - do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1)) - -validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType -validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr - -validSimple :: [Var] -> Expr -> Validity LSLType -validSimple vars (IntLit i) = return LLInteger -validSimple vars (FloatLit f) = return LLFloat -validSimple vars (StringLit s) = return LLString -validSimple vars (KeyLit k) = return LLKey -validSimple vars (Get (Ctx ctx name,All)) = - (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars - return t) - `mplus` (findConstType name) -validSimple vars (Get (Ctx ctx name,_)) = throwError [(ctx,"can't access vector/rotation component in global variable initialization")] -validSimple vars (ListExpr []) = return LLList -validSimple vars (ListExpr (e:es)) = - do t <- validCtxSimple vars e - when (t == LLList) $ throwError [(srcCtx e,"lists cannot contain other lists")] - validSimple vars (ListExpr es) -validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3] -validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4] -validSimple vars (Neg e) = - do t <- validCtxSimple vars e - when (t `notElem` [LLFloat, LLInteger]) $ throwError [(srcCtx e,"operator only applicable to integers and floats in this context")] - return t -validSimple vars e = throwStrError ("expression is not valid in a static context.") - -validSimpleStructure vars t [] = return t -validSimpleStructure vars t (e:es) = - do t' <- validCtxSimple vars e - when (t' `notElem` [LLFloat,LLInteger]) $ throwError [(srcCtx e, "literal of type " ++ - (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t))] - validSimpleStructure vars t es - -validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType -validExpression (Cast t expr) funcs vars locals = - do t' <- validCtxExpr expr funcs vars locals - incontext (srcCtx expr, "") $ validCast t' t - return t -validExpression (Get ((Ctx ctx name),component)) funcs vars locals = - case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of - (Nothing,_) -> throwError [(ctx, "undefined variable or constant: " ++ name)] - (Just LLRot,All) -> return LLRot - (Just LLRot,_) -> return LLFloat - (Just LLVector,All) -> return LLVector - (Just LLVector,S) -> throwError [(ctx,"s is not a valid component of a vector")] - (Just LLVector,_) -> return LLFloat - (Just t,All) -> return t - (Just t,_) -> throwError [(ctx,"only vectors and rotations have components")] -validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs -validExpression (Not expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator")] - return t -validExpression (Neg expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t == LLList) $ throwError [(srcCtx expr, "operator not applicable to list type")] - return t -validExpression (Inv expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator")] - return t -validExpression plus@(Add expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (t,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands plus t0 t1 -validExpression minus@(Sub expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands minus t0 t1 -validExpression expr@(Mul expr1 expr2) funcs vars locals= - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLFloat,LLVector) -> return LLVector - (LLInteger,LLVector) -> return LLVector - (LLVector,LLVector) -> return LLFloat - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Div expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Mod expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - _ -> incompatibleOperands expr t1 t2 -validExpression e@(Equal expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(NotEqual expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals -validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(IncBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(IncBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DecBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DecBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(MulBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error! - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(MulBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DivBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DivBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(ModBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(ModBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) -> incompatibleOperands e t1 t2 -validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--" -validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression expr0@(Set (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLFloat,LLInteger) -> return LLFloat - (LLKey,LLString) -> return LLKey - (LLString,LLKey) -> return LLString - (t1,t2) | t1 == t2 -> return t1 - | otherwise -> incompatibleOperands expr0 t1 t2 -validExpression expr0@(Set (name,S) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression expr0@(Set (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLVector,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLFloat - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression (IntLit i) _ _ _ = return LLInteger -validExpression (FloatLit _) _ _ _ = return LLFloat -validExpression (StringLit _) _ _ _ = return LLString -validExpression (KeyLit _) _ _ _ = return LLKey -validExpression (ListExpr es) fs vs ls = do - mapM (\ e -> validListExprElement e fs vs ls) es - return LLList -validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector" - return LLVector -validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - st <- validCtxExpr sExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation" - return LLRot ---validExpression x funcs vars locals = error ("what to do with " ++ (show x)) - -validListExprElement (Ctx ctx e) funcs vars locals = do - t <- validExpression e funcs vars locals - when (t `elem` [LLVoid,LLList]) $ throwError [(ctx,"invalid type for list element")] - return () - -validMExpression Nothing funcs vars locals = return LLVoid -validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals - -validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es - -validRelExpr (expr1,expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLInteger - (LLFloat, LLInteger) -> return LLInteger - (LLFloat, LLFloat) -> return LLInteger - (t0,t1) -> throwStrError ("operands are of incompatible types") -validBothInteger (expr1, expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") - return LLInteger -validEach (expr1, expr2) funcs vars locals = - do t1 <- validCtxExpr expr1 funcs vars locals - t2 <- validCtxExpr expr2 funcs vars locals - return (t1,t2) - -validNameExpr (Ctx ctx name, expr) funcs vars locals = - case (findType name (concat locals ++ vars), - validCtxExpr expr funcs vars locals) of - (Just t1, Right t2) -> return (t1,t2) - (Nothing, _) -> throwError [(ctx, "variable " ++ name ++ " not defined")] - (_,Left s) -> throwError s -validCall funcs vars locals (Ctx ctx fname) exprs = - do (FuncDec _ t params) <- findFuncDec fname funcs - let vArg _ [] [] = return () - vArg _ (p:ps) [] = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)] - vArg _ [] (a:as) = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)] - vArg n (Var name t:ts) (arg:args) = - do t' <- validCtxExpr arg funcs vars locals - when (not (matchTypes t t')) $ throwError [(ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t))] - vArg (n+1) ts args - vArg 1 (ctxItems params) exprs - return t - -validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls - -validIncDecOp (n@(Ctx ctx name),c) vars locals op = - do failIfNoModify n - case (findType name (concat locals ++ vars),c) of - (Nothing,_) -> throwError [(ctx, "variable " ++ name ++ " not found")] - (Just LLInteger,All) -> return LLInteger - (Just LLFloat,All) -> return LLFloat - (Just LLRot,S) -> return LLFloat - (Just LLVector,S) -> throwError [(ctx, "s is not a valid component of " ++ name)] - (Just t,All) -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)] - (Just LLVector,_) -> return LLFloat - (Just LLRot,_) -> return LLFloat - _ -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)] - -failIfNoModify (Ctx ctx name) = - when (isConstant name) $ throwError [(ctx,"cannot modify " ++ name ++ " because it is a constant")] - -incompatibleOperands expr t0 t1 = - throwStrError ("types of the operands aren't compatible (" ++ - (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")") - defined :: String -> [Var] -> Bool defined n = any (\ (Var n' _) -> n == n') -validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = - do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope - when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant") - case expr of - Nothing -> return ((var:scope):scopes,returns) - Just expr' -> do t' <- validCtxExpr expr' funcs vars locals - when (not $ matchTypes t t') $ throwError [(srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t)] - return ((var:scope):scopes,returns) -validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")] - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")] - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) = - do validExpressions mexpr1 funcs vars locals - validExpressions mexpr3 funcs vars locals - t <- validMExpression mexpr2 funcs vars locals - --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid 'if' condition")] - (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt - (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt - return (locals,returns || ret1 && ret2) -validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns) -validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = - do when (rtype /= LLVoid) (throwStrError "function must return a value") - return (locals,True) -validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = - do t <- validCtxExpr expr funcs vars locals - when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler") - return (locals,True) -validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do - when (not scallow) $ throwStrError "state changes not allowed from this context" - when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state") - return (locals,returns) -validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = - do returns' <- validStatements scallow snames funcs vars rtype labels ([]:locals) stmts - return (locals,returns || returns') -validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False) -validStatement _ _ funcs vars rtype labels locals returns (Jump s) = - do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s) - return (locals,returns) - -validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = - incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt - -validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool -validStatements scallow snames funcs vars rtype labels locals stmts = - do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) - (_,r') <- foldM (\ (l,r) (n, s) -> - validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts - return r' - -validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = - do when (name `elem` used) $ throwError [(ctx,name ++ " already used in state")] - types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers - when (types /= map varType args') $ throwError [(ctx,"invalid argument types for handler " ++ name)] - when (length args /= (length $ nub $ map varName args')) $ throwError [(ctx,"not all argument names are unique for handler " ++ name)] - validStatements True snames funcs vars LLVoid [] [[],args'] stmts - return name - where args' = ctxItems args - -validHandlers _ _ _ _ [] = return () -validHandlers snames used funcs vars (h:hs) = - do name <- validHandler snames used funcs vars h - validHandlers snames (name:used) funcs vars hs - -- Validating a library of modules -compileModule :: LModule -> VState (Validity ([Global],[Func])) +compileModule :: LModule -> VState (Validity ([Global],[Ctx Func])) compileModule m@(LModule globs freevars) = do mapM_ (vsmAddGV . ctxItem) freevars preprocessGlobDefs_ "" globs @@ -1711,17 +1166,6 @@ funcs <- get'vsFuncs return $ Right $ (globals,funcs) _ -> return $ Left errs --- -validModule library m@(LModule globs freevars) = - do --used <- noDupGlobs Nothing "" [] library globs - (typedVars, typedFuncs) <- typeGlobs library globs - let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs) - noDupVars used freevars - let vars = freevars' ++ reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - return (vs,fs) - where freevars' = ctxItems freevars -- this function isn't partiuclarly efficient! moduleDependencies lib chain m = @@ -1768,20 +1212,6 @@ Right gs -> (name,Right (m,gs)):augLib in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) -validLibrary modules = - let checkDep (n,m) = case moduleDependencies modules [] n of - Right deps -> (n,Right (m,deps)) - Left s -> (n,Left s) - categorize (good,bad) (n,Left s) = (good,(n,s):bad) - categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) - (good,bad) = foldl categorize ([],[]) $ map checkDep modules - sorted = sortModules good - validate augLib (name,m) = - case validModule (libFromAugLib augLib) m of - Left s -> (name, Left s):augLib - Right gs -> (name,Right (m,gs)):augLib - in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) - libFromAugLib :: AugmentedLibrary -> Library libFromAugLib augLib = let f (name,Left s) = (name,Left s) @@ -1825,7 +1255,7 @@ globDefFromGlob (GDecl v me) = GV (nullCtx v) (fmap nullCtx me) funcDefsFromState (State ctxnm handlers) = map (funcDefFromHandler (ctxItem ctxnm)) handlers -funcDefFromHandler stateName (Handler ctxnm params stmts) = GF $ Func (FuncDec combinedName LLVoid params) stmts +funcDefFromHandler stateName (Handler ctxnm params stmts) = GF $ nullCtx $ Func (FuncDec combinedName LLVoid params) stmts where combinedName = nullCtx $ stateName ++ "$$" ++ (ctxItem ctxnm) rewriteCtxExpr :: [(String,String)] -> Ctx Expr -> Ctx Expr @@ -1870,5 +1300,3 @@ rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs rewriteMExpression bindings = fmap (rewriteCtxExpr bindings) - - diff --git a/src/Language/Lsl/UnitTest.hs b/src/Language/Lsl/UnitTest.hs --- a/src/Language/Lsl/UnitTest.hs +++ b/src/Language/Lsl/UnitTest.hs @@ -13,9 +13,9 @@ import Language.Lsl.Internal.Exec(Binding(..)) import Language.Lsl.Internal.Util(removeLookup) -data FuncCallExpectations = FuncCallExpectations { +data FuncCallExpectations a = FuncCallExpectations { expectationMode :: ExpectationMode, - callList :: [((String, [Maybe LSLValue]),LSLValue)] } deriving (Show) + callList :: [((String, [Maybe (LSLValue a)]),LSLValue a)] } deriving (Show) data ExpectationMode = Nice | Normal | Exhaust | Strict deriving (Show,Eq) @@ -25,11 +25,11 @@ data LSLUnitTest = LSLUnitTest { unitTestName :: String, entryPoint :: EntryPoint, - initialGlobs :: [Binding], - arguments :: [LSLValue], - expectedCalls :: FuncCallExpectations, - expectedReturn :: Maybe LSLValue, - expectedGlobalVals :: [Binding], + initialGlobs :: [Binding Float], + arguments :: [LSLValue Float], + expectedCalls :: FuncCallExpectations Float, + expectedReturn :: Maybe (LSLValue Float), + expectedGlobalVals :: [Binding Float], expectedNewState :: Maybe String } deriving (Show) @@ -47,7 +47,7 @@ matchFail :: Monad m => m a matchFail = fail "no matching call" -expectedReturns :: (Monad m) => String -> [LSLValue] -> FuncCallExpectations -> m ((String,[Maybe LSLValue]),LSLValue) +expectedReturns :: (RealFloat a,Monad m) => String -> [LSLValue a] -> FuncCallExpectations a -> m ((String,[Maybe (LSLValue a)]),LSLValue a) expectedReturns name args (FuncCallExpectations Strict (match@((name',expectArgs),returns):_)) = if name /= name' || argsMatch expectArgs args == Nothing then matchFail else return match @@ -69,5 +69,5 @@ (Nothing,_) -> matchFail (_,e) -> return e -removeExpectation :: (String,[Maybe LSLValue]) -> FuncCallExpectations -> FuncCallExpectations +removeExpectation :: (RealFloat a) => (String,[Maybe (LSLValue a)]) -> FuncCallExpectations a -> FuncCallExpectations a removeExpectation m fce = fce { callList = removeLookup m (callList fce) } 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 @@ -1,6 +1,7 @@ module Language.Lsl.UnitTestEnv( simStep, simFunc, + simSFunc, hasFunc, SimpleWorld, TestEvent(..), @@ -32,31 +33,31 @@ --trace1 v = trace ("->>" ++ (show v)) v -data SimpleWorld = SimpleWorld { +data SimpleWorld a = SimpleWorld { maxTick :: Int, tick :: Int, msgLog :: [(Int,String)], wScripts :: [(String,Validity CompiledLSLScript)], wLibrary :: [(String,Validity LModule)], - expectations :: FuncCallExpectations, + expectations :: FuncCallExpectations a, breakpointManager :: BreakpointManager } -type SimpleWorldM = ErrorT String (State SimpleWorld) +type SimpleWorldM a = ErrorT String (State (SimpleWorld a)) simpleWorldM = ErrorT . State -getTick :: SimpleWorldM Int +getTick :: SimpleWorldM a Int getTick = get >>= return . tick -getMaxTick :: SimpleWorldM Int +getMaxTick :: SimpleWorldM a Int getMaxTick = get >>= return . maxTick -getMsgLog :: SimpleWorldM [(Int,String)] +getMsgLog :: SimpleWorldM a [(Int,String)] getMsgLog = get >>= return . msgLog -getWScripts :: SimpleWorldM [(String, Validity CompiledLSLScript)] +getWScripts :: SimpleWorldM a [(String, Validity CompiledLSLScript)] getWScripts = get >>= return . wScripts -getWLibrary :: SimpleWorldM [(String, Validity LModule)] +getWLibrary :: SimpleWorldM a [(String, Validity LModule)] getWLibrary = get >>= return . wLibrary -getExpectations :: SimpleWorldM FuncCallExpectations +getExpectations :: SimpleWorldM a (FuncCallExpectations a) getExpectations = get >>= return . expectations -getBreakpointManager :: SimpleWorldM BreakpointManager +getBreakpointManager :: SimpleWorldM a BreakpointManager getBreakpointManager = get >>= return . breakpointManager setTick t = do w <- get; put (w { tick = t }) @@ -75,6 +76,7 @@ tick <- getTick modifyMsgLog ((tick,s):) +doPredef :: (Read a, RealFloat a) => String -> b -> [LSLValue a] -> ErrorT String (State (SimpleWorld a)) (EvalResult,LSLValue a) doPredef n i a = do logMsg $ "call: " ++ renderCall n a case lookup n internalLLFuncs of @@ -108,7 +110,28 @@ Nothing -> return (Left $ "No such script: " ++ name) Just (Left s) -> return $ Left $ "Invalid script: " ++ name Just (Right script) -> return $ Right script + +findValidScript scripts name = + case lookup name scripts of + Nothing -> Left $ "No such script: " ++ name + Just (Left s) -> Left $ "Invalid script: " ++ name + Just (Right script) -> Right script +convertEntryPoint' scripts _ (ScriptFunc scriptName funcName) = do + script <- findValidScript scripts scriptName + return (script,[funcName]) +convertEntryPoint' scripts _ (ScriptHandler scriptName stateName handlerName) = do + script <- findValidScript scripts scriptName + return (script,[stateName,handlerName]) +convertEntryPoint' _ modules (ModuleFunc moduleName funcName) = + case lookup moduleName modules of + Nothing -> Left $ "No such module: " ++ moduleName + Just (Left s) -> Left $ "Invalid module: " ++ moduleName + Just (Right lmodule) -> + case compileLSLScript' modules (mkScript lmodule) of + Left _ -> Left "Invalid entry point (internal error?)" + Right script -> Right (script,[funcName]) + convertEntryPoint (ScriptFunc scriptName funcName) = do script <- getValidScript scriptName return $ liftM2 (,) script (Right [funcName]) @@ -164,7 +187,7 @@ -------------------------------------------------- -- 'Interactive' testing -data TestEvent = TestComplete TestResult | TestSuspended ExecutionInfo | AllComplete +data TestEvent a = TestComplete TestResult | TestSuspended (ExecutionInfo a) | AllComplete data ExecCommand = ExecContinue [Breakpoint] | ExecStep [Breakpoint] | ExecStepOver [Breakpoint] | ExecStepOut [Breakpoint] @@ -179,27 +202,22 @@ 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) + Right (Right (script,path)) -> Right $ isJust (findFunc functionName $ map ctxItem $ 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, + +simSFunc :: (Read a, RealFloat a) => (CompiledLSLScript,[String]) -> [(String,LSLValue a)] -> [LSLValue a] -> Either String (LSLValue a,[(String,LSLValue a)]) +simSFunc (script,path) globs args = + let world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = [], expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } - ep = ModuleFunc moduleName functionName + exec = initStateSimple script doPredef logMsg getTick setTick checkBp 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 + do result <- runEval (setupSimple path globs args) exec + case result of + (Left s, _) -> fail s + (Right (), exec') -> return exec')) world in case init of (Left s, world') -> Left s (Right exec,world') -> @@ -212,6 +230,42 @@ (Right (EvalComplete newState, _),_) -> Left "execution error" (Right (EvalIncomplete,_),_) -> Left "execution error: timeout" (Right _,_) -> Left "execution error" + +-- simFunc' lib (moduleName,functionName) globs args = +-- let ep = ModuleFunc moduleName functionName +simFunc :: (Read a, RealFloat a) => [(String,Validity LModule)] -> (String,String) -> [(String,LSLValue a)] -> [LSLValue a] -> Either String (LSLValue a,[(String,LSLValue a)]) +simFunc lib (moduleName,functionName) globs args = + case convertEntryPoint' [] lib (ModuleFunc moduleName functionName) of + Left s -> Left s + Right (script,path) -> simSFunc (script,path) globs args + +-- simFunc :: (Read a, RealFloat a) => [(String,Validity LModule)] -> (String,String) -> [(String,LSLValue a)] -> [LSLValue a] -> Either String (LSLValue a,[(String,LSLValue a)]) +-- 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 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 @@ -153,7 +153,7 @@ avatarCameraControlParams :: CameraParams, avatarActiveAnimations :: [(Maybe Int,String)], avatarAttachments :: IM.IntMap String, - avatarEventHandler :: !(Maybe (String,[(String,LSLValue)])), + avatarEventHandler :: !(Maybe (String,[(String,LSLValue Float)])), avatarControls :: !Int, avatarControlListener :: !(Maybe AvatarControlListener) } deriving (Show) @@ -213,7 +213,7 @@ primPhysicsBit :: Int primPhysicsBit = 0 -data InventoryItemData = InvScript { invScriptLibId :: String, invScriptState :: Maybe ScriptImage } +data InventoryItemData = InvScript { invScriptLibId :: String, invScriptState :: Maybe (ScriptImage Float) } | InvBodyPart | InvGesture | InvClothing @@ -434,13 +434,13 @@ regionParcels = [Parcel "parcel_0" "default parcel" (0,256,0,256) owner 0xffffffff [] []] }) ] -data Script = Script { scriptImage :: !ScriptImage, +data Script = Script { scriptImage :: !(ScriptImage Float), scriptActive :: Bool, scriptPermissions :: M.Map String Int, scriptLastPerm :: Maybe String, scriptStartTick :: Int, scriptLastResetTick :: Int, - scriptEventQueue :: [Event], + scriptEventQueue :: [Event Float], scriptStartParameter :: Int, scriptCollisionFilter :: !(String,String,Bool), scriptTargetIndex :: !Int, diff --git a/src/Text/ParserCombinators/ParsecExtras/Language.hs b/src/Text/ParserCombinators/ParsecExtras/Language.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/ParsecExtras/Language.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.ParsecExtras.Language +-- Copyright : (c) Daan Leijen 1999-2001 +-- (c) Robert Greayer 2008 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : robgreayer@yahoo.com +-- Stability : provisional +-- Portability : non-portable (uses non-portable module Text.ParserCombinators.ParsecExtras.Token) +-- +-- A helper module that defines some language definitions that can be used +-- to instantiate a token parser (see "Text.ParserCombinators.Parsec.Token"). +-- The 'extras' version exists purely to provide better control over whitespace handling. +-- It is nearly a cut-n-paste copy of the Text.ParserCombinators.Parsec.Language module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.ParsecExtras.Language + ( haskellDef, haskell + , mondrianDef, mondrian + + , emptyDef + , haskellStyle + , javaStyle + , LanguageDef (..) + ) where +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.ParsecExtras.Token + + +----------------------------------------------------------- +-- Styles: haskellStyle, javaStyle +----------------------------------------------------------- +haskellStyle :: LanguageDef st +haskellStyle= emptyDef + { commentStart = "{-" + , commentEnd = "-}" + , commentLine = "--" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter haskellStyle + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + +javaStyle :: LanguageDef st +javaStyle = emptyDef + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "//" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , reservedNames = [] + , reservedOpNames= [] + , caseSensitive = False + } + +----------------------------------------------------------- +-- minimal language definition +----------------------------------------------------------- +emptyDef :: LanguageDef st +emptyDef = LanguageDef + { commentStart = "" + , commentEnd = "" + , commentLine = "" + , nestedComments = True + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter emptyDef + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + , custWhiteSpace = Nothing + } + + + +----------------------------------------------------------- +-- Haskell +----------------------------------------------------------- +haskell :: TokenParser st +haskell = makeTokenParser haskellDef + +haskellDef :: LanguageDef st +haskellDef = haskell98Def + { identLetter = identLetter haskell98Def <|> char '#' + , reservedNames = reservedNames haskell98Def ++ + ["foreign","import","export","primitive" + ,"_ccall_","_casm_" + ,"forall" + ] + } + +haskell98Def :: LanguageDef st +haskell98Def = haskellStyle + { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] + , reservedNames = ["let","in","case","of","if","then","else", + "data","type", + "class","default","deriving","do","import", + "infix","infixl","infixr","instance","module", + "newtype","where", + "primitive" + -- "as","qualified","hiding" + ] + } + + +----------------------------------------------------------- +-- Mondrian +----------------------------------------------------------- +mondrian :: TokenParser st +mondrian = makeTokenParser mondrianDef + +mondrianDef :: LanguageDef st +mondrianDef = javaStyle + { reservedNames = [ "case", "class", "default", "extends" + , "import", "in", "let", "new", "of", "package" + ] + , caseSensitive = True + } + + diff --git a/src/Text/ParserCombinators/ParsecExtras/Token.hs b/src/Text/ParserCombinators/ParsecExtras/Token.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/ParsecExtras/Token.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE PolymorphicComponents, ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.ParsecExtras.Token +-- Copyright : (c) Daan Leijen 1999-2001 +-- : (c) Rob Greayer 2009 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : robgreayer@yahoo.com +-- Stability : provisional +-- Portability : non-portable (uses existentially quantified data constructors) +-- +-- A helper module to parse lexical elements (tokens). +-- A separate version to allow customizable whitespace handling +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.ParsecExtras.Token + ( LanguageDef (..) + , TokenParser (..) + , makeTokenParser + ) where + +import Data.Char (isAlpha,toLower,toUpper,isSpace,digitToInt) +import Data.List (nub,sort) +import Data.Maybe (isJust,fromJust) +import Text.ParserCombinators.Parsec + +----------------------------------------------------------- +-- Language Definition +----------------------------------------------------------- +data LanguageDef st + = LanguageDef + { commentStart :: String + , commentEnd :: String + , commentLine :: String + , nestedComments :: Bool + , identStart :: CharParser st Char + , identLetter :: CharParser st Char + , opStart :: CharParser st Char + , opLetter :: CharParser st Char + , reservedNames :: [String] + , reservedOpNames:: [String] + , caseSensitive :: Bool + , custWhiteSpace :: Maybe (CharParser st String -> CharParser st String -> CharParser st String -> CharParser st ()) + } + +----------------------------------------------------------- +-- A first class module: TokenParser +----------------------------------------------------------- +data TokenParser st + = TokenParser{ identifier :: CharParser st String + , reserved :: String -> CharParser st () + , operator :: CharParser st String + , reservedOp :: String -> CharParser st () + + , charLiteral :: CharParser st Char + , stringLiteral :: CharParser st String + , natural :: CharParser st Integer + , integer :: CharParser st Integer + , float :: CharParser st Double + , naturalOrFloat :: CharParser st (Either Integer Double) + , decimal :: CharParser st Integer + , hexadecimal :: CharParser st Integer + , octal :: CharParser st Integer + + , symbol :: String -> CharParser st String + , lexeme :: forall a. CharParser st a -> CharParser st a + , whiteSpace :: CharParser st () + , simpleSpace :: CharParser st String + , multiLineComment :: CharParser st String + , oneLineComment :: CharParser st String + , parens :: forall a. CharParser st a -> CharParser st a + , braces :: forall a. CharParser st a -> CharParser st a + , angles :: forall a. CharParser st a -> CharParser st a + , brackets :: forall a. CharParser st a -> CharParser st a + -- "squares" is deprecated + , squares :: forall a. CharParser st a -> CharParser st a + + , semi :: CharParser st String + , comma :: CharParser st String + , colon :: CharParser st String + , dot :: CharParser st String + , semiSep :: forall a . CharParser st a -> CharParser st [a] + , semiSep1 :: forall a . CharParser st a -> CharParser st [a] + , commaSep :: forall a . CharParser st a -> CharParser st [a] + , commaSep1 :: forall a . CharParser st a -> CharParser st [a] + } + +----------------------------------------------------------- +-- Given a LanguageDef, create a token parser. +----------------------------------------------------------- +makeTokenParser :: LanguageDef st -> TokenParser st +makeTokenParser languageDef + = TokenParser{ identifier = identifier + , reserved = reserved + , operator = operator + , reservedOp = reservedOp + + , charLiteral = charLiteral + , stringLiteral = stringLiteral + , natural = natural + , integer = integer + , float = float + , naturalOrFloat = naturalOrFloat + , decimal = decimal + , hexadecimal = hexadecimal + , octal = octal + + , symbol = symbol + , lexeme = lexeme + , whiteSpace = whiteSpace + , simpleSpace = simpleSpace + , multiLineComment = multiLineComment + , oneLineComment = oneLineComment + + , parens = parens + , braces = braces + , angles = angles + , brackets = brackets + , squares = brackets + , semi = semi + , comma = comma + , colon = colon + , dot = dot + , semiSep = semiSep + , semiSep1 = semiSep1 + , commaSep = commaSep + , commaSep1 = commaSep1 + } + where + + ----------------------------------------------------------- + -- Bracketing + ----------------------------------------------------------- + parens p = between (symbol "(") (symbol ")") p + braces p = between (symbol "{") (symbol "}") p + angles p = between (symbol "<") (symbol ">") p + brackets p = between (symbol "[") (symbol "]") p + + semi = symbol ";" + comma = symbol "," + dot = symbol "." + colon = symbol ":" + + commaSep p = sepBy p comma + semiSep p = sepBy p semi + + commaSep1 p = sepBy1 p comma + semiSep1 p = sepBy1 p semi + + + ----------------------------------------------------------- + -- Chars & Strings + ----------------------------------------------------------- + -- charLiteral :: CharParser st Char + charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + + characterChar = charLetter <|> charEscape + "literal character" + + charEscape = do{ char '\\'; escapeCode } + charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + + -- stringLiteral :: CharParser st String + stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + + -- stringChar :: CharParser st (Maybe Char) + stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + + stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + + stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + + escapeEmpty = char '&' + escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + + -- escape codes + escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + + -- charControl :: CharParser st Char + charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + + -- charNum :: CharParser st Char + charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + + charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + + charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + + -- escape code tables + escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + + ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] + ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + + ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] + ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + + ----------------------------------------------------------- + -- Numbers + ----------------------------------------------------------- + -- naturalOrFloat :: CharParser st (Either Integer Double) + naturalOrFloat = lexeme (natFloat) "number" + + float = lexeme floating "float" + integer = lexeme int "integer" + natural = lexeme nat "natural" + + + -- floats + floating = do{ n <- decimal + ; fractExponent n + } + + + natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + + zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + + decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + + fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + + fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + + fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + + exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + + -- integers and naturals + int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + + -- sign :: CharParser st (Integer -> Integer) + sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + + nat = zeroNumber <|> decimal + + zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + + decimal = number 10 digit + hexadecimal = do{ oneOf "xX"; number 16 hexDigit } + octal = do{ oneOf "oO"; number 8 octDigit } + + -- number :: Integer -> CharParser st Char -> CharParser st Integer + number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + + ----------------------------------------------------------- + -- Operators & reserved ops + ----------------------------------------------------------- + reservedOp name = + lexeme $ try $ + do{ string name + ; notFollowedBy (opLetter languageDef) ("end of " ++ show name) + } + + operator = + lexeme $ try $ + do{ name <- oper + ; if (isReservedOp name) + then unexpected ("reserved operator " ++ show name) + else return name + } + + oper = + do{ c <- (opStart languageDef) + ; cs <- many (opLetter languageDef) + ; return (c:cs) + } + "operator" + + isReservedOp name = + isReserved (sort (reservedOpNames languageDef)) name + + + ----------------------------------------------------------- + -- Identifiers & Reserved words + ----------------------------------------------------------- + reserved name = + lexeme $ try $ + do{ caseString name + ; notFollowedBy (identLetter languageDef) ("end of " ++ show name) + } + + caseString name + | caseSensitive languageDef = string name + | otherwise = do{ walk name; return name } + where + walk [] = return () + walk (c:cs) = do{ caseChar c msg; walk cs } + + caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) + | otherwise = char c + + msg = show name + + + identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then unexpected ("reserved word " ++ show name) + else return name + } + + + ident + = do{ c <- identStart languageDef + ; cs <- many (identLetter languageDef) + ; return (c:cs) + } + "identifier" + + isReservedName name + = isReserved theReservedNames caseName + where + caseName | caseSensitive languageDef = name + | otherwise = map toLower name + + + isReserved names name + = scan names + where + scan [] = False + scan (r:rs) = case (compare r name) of + LT -> scan rs + EQ -> True + GT -> False + + theReservedNames + | caseSensitive languageDef = sortedNames + | otherwise = map (map toLower) sortedNames + where + sortedNames = sort (reservedNames languageDef) + + + + ----------------------------------------------------------- + -- White space & symbols + ----------------------------------------------------------- + symbol name + = lexeme (string name) + + lexeme p + = do{ x <- p; whiteSpace; return x } + + + --whiteSpace + whiteSpace + | isJust (custWhiteSpace languageDef) = (fromJust (custWhiteSpace languageDef)) simpleSpace oneLineComment multiLineComment + | noLine && noMulti = skipMany (simpleSpace "") + | noLine = skipMany (simpleSpace <|> multiLineComment "") + | noMulti = skipMany (simpleSpace <|> oneLineComment "") + | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + noLine = null (commentLine languageDef) + noMulti = null (commentStart languageDef) + + + simpleSpace = many1 (satisfy isSpace) + + oneLineComment = + do{ try (string (commentLine languageDef)) + ; many (satisfy (/= '\n')) + } + + multiLineComment = + do { try (string (commentStart languageDef)) + ; inComment + } + + inComment + | nestedComments languageDef = inCommentMulti + | otherwise = inCommentSingle + + inCommentMulti + = do{ try (string (commentEnd languageDef)) ; return "" } + <|> do{ cmt <- multiLineComment ; rest <- inCommentMulti; return (cmt ++ rest) } + <|> do{ txt <- many1 (noneOf startEnd) ; rest <- inCommentMulti; return (txt ++ rest) } + <|> do{ ch <- oneOf startEnd ; rest <- inCommentMulti; return (ch:rest) } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) + + inCommentSingle + = do{ try (string (commentEnd languageDef)); return (commentEnd languageDef) } + <|> do{ txt <- many1 (noneOf startEnd) ; rest <- inCommentSingle; return (txt ++ rest) } + <|> do{ c <- oneOf startEnd ; rest <- inCommentSingle; return (c:rest) } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) +