LslPlus 0.3.6 → 0.4.0
raw patch · 18 files changed
+1365/−169 lines, 18 filesdep +ghc
Dependencies added: ghc
Files
- LslPlus.cabal +6/−2
- src/Language/Lsl/Internal/CompilationServer.hs +205/−0
- src/Language/Lsl/Internal/Compiler.hs +23/−6
- src/Language/Lsl/Internal/DOMCombinators.hs +176/−0
- src/Language/Lsl/Internal/DOMProcessing.hs +99/−1
- src/Language/Lsl/Internal/Exec.hs +9/−9
- src/Language/Lsl/Internal/FuncSigs.hs +15/−1
- src/Language/Lsl/Internal/Load.hs +21/−17
- src/Language/Lsl/Internal/Optimize.hs +19/−16
- src/Language/Lsl/Internal/SerializationGenerator.hs +420/−0
- src/Language/Lsl/Internal/SerializationInstances.hs +11/−0
- src/Language/Lsl/Internal/Util.hs +17/−0
- src/Language/Lsl/Parse.hs +285/−81
- src/Language/Lsl/Render.hs +23/−11
- src/Language/Lsl/Syntax.hs +21/−20
- src/Language/Lsl/UnitTestEnv.hs +1/−1
- src/LslPlus.hs +8/−2
- src/Text/Here.hs +6/−2
LslPlus.cabal view
@@ -1,5 +1,5 @@ Name: LslPlus -version: 0.3.6 +version: 0.4.0 Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, @@ -20,7 +20,7 @@ Extra-source-files: NOTICE Executable LslPlus - Build-Depends: base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3, + 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 @@ -35,8 +35,10 @@ Language.Lsl.Internal.BreakpointsDeserialize Language.Lsl.Internal.BuiltInModules Language.Lsl.Internal.CodeHelper + Language.Lsl.Internal.CompilationServer Language.Lsl.Internal.Compiler Language.Lsl.Internal.Constants + Language.Lsl.Internal.DOMCombinators Language.Lsl.Internal.DOMProcessing Language.Lsl.Internal.DOMSourceDescriptor Language.Lsl.Internal.DOMUnitTestDescriptor @@ -57,6 +59,8 @@ Language.Lsl.Internal.OptimizerOptions Language.Lsl.Internal.Physics Language.Lsl.Internal.Pragmas + Language.Lsl.Internal.SerializationGenerator + Language.Lsl.Internal.SerializationInstances Language.Lsl.Internal.SHA1 Language.Lsl.Internal.SimMetaData Language.Lsl.Internal.SystemTester
+ src/Language/Lsl/Internal/CompilationServer.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS_GHC -XFlexibleContexts -XNoMonomorphismRestriction -XTemplateHaskell #-} +module Language.Lsl.Internal.CompilationServer where + +import Control.Monad +import Control.Monad.Instances +import Control.Monad.Error + +import Data.Data +import Data.Either +import Data.Generics +import Data.Generics.Extras.Schemes +import qualified Data.Map as M +import Language.Lsl.Internal.Compiler +import Language.Lsl.Internal.Load(loadScript) +import Language.Lsl.Internal.Pragmas +import Language.Lsl.Syntax +import Language.Lsl.Parse +import Language.Lsl.Internal.Util +import Language.Lsl.Internal.DOMProcessing +import Language.Lsl.Internal.DOMSourceDescriptor +import qualified Language.Lsl.Internal.XmlCreate as E +import Text.XML.HaXml.Parse hiding (fst3,snd3,thd3) +import Language.Lsl.Internal.SerializationGenerator +import Language.Lsl.Internal.DOMCombinators +import Language.Lsl.Internal.SerializationInstances +import System.Directory +import System.FilePath(replaceExtension) + +-- a module or a script +data CodeElement = CodeElement { codeElementName :: String, codeElementText :: String } + deriving (Show,Eq) + +data CompilationCommand = Init (Bool,[(String,String)],[(String,String)]) -- compile all the modules and scripts (writing out .lsl files!) + | UpdateModule (String,String) -- update the given module, recompiling affected scripts (and writing out .lsl files!) + | UpdateScript (String,String) -- compile the given script (writing out the .lsl file) + | RemoveScript (String,String) + | RemoveModule (String,String) + | CheckModule CodeElement -- check the module + | CheckScript CodeElement -- check the script + deriving (Show,Eq) + +data CompilationResponse = FullSourceValidation ([CompilationStatus],[CompilationStatus]) + | ModuleResponse (LModule,[ErrInfo]) + | ScriptResponse (LSLScript,[ErrInfo]) + +data EPKind = EPFunc | EPHandler deriving (Show,Eq) + +data EPSummary = EPSummary { epKind :: EPKind, epName :: String, epType :: LSLType, epParams :: [(String,LSLType)] } + deriving (Show,Eq) +data GlobalSummary = GlobalSummary { globalName :: String, globalType :: LSLType } + deriving (Show,Eq) + +data CompilationStatus = CompilationStatus { csName :: !String, csInfo :: !(Either [ErrInfo] ([GlobalSummary],[EPSummary])) } + deriving (Show,Eq) + +data ErrInfo = ErrInfo (Maybe TextLocation) String deriving (Show,Eq) + +toErrInfo (Nothing,msg) = ErrInfo Nothing msg +toErrInfo (Just srcCtx, msg) = ErrInfo (Just $ srcTextLocation srcCtx) msg + +parseErrorToErrInfo pe = + let (x,y) = (sourcePosToTextLocation $ errorPos pe, + showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" (errorMessages pe)) + in ErrInfo (Just x) y + +sourcePosToTextLocation pos = (TextLocation line col line col name) + where line = sourceLine pos + col = sourceColumn pos + name = sourceName pos + +gsummary :: Data a => a -> [Either GlobalSummary EPSummary] +gsummary = everythingBut (False `mkQ` string `extQ` srcContext) (++) [] ([] `mkQ` fsum `extQ` gsum) + where gsum (GDecl (Ctx _ (Var n t)) _) = [Left $ GlobalSummary n t] + fsum (FuncDec fnm t parms) = [Right $ EPSummary EPFunc (ctxItem fnm) t (map ((\ (Var n t) -> (n,t)) . ctxItem) parms)] + string :: String -> Bool + string _ = True + srcContext :: SourceContext -> Bool + srcContext _ = True + +ssummary :: [Ctx State] -> [EPSummary] +ssummary = concatMap go + where go (Ctx _ (State nm hs)) = map (hsum (ctxItem nm)) hs + hsum snm (Ctx _ (Handler hnm parms _)) = + EPSummary EPHandler (snm ++ "." ++ ctxItem hnm) LLVoid (map ((\ (Var n t) -> (n,t)) . ctxItem) parms) + +moduleSummary :: LModule -> ([GlobalSummary],[EPSummary]) +moduleSummary (LModule gdefs _) = partitionEithers (gsummary gdefs) + +scriptSummary :: CompiledLSLScript -> ([GlobalSummary],[EPSummary]) +scriptSummary (CompiledLSLScript _ gs fs ss) = (map sumg gs,map sumf fs ++ ssummary ss) + where sumg (GDecl (Ctx _ (Var n t)) _) = GlobalSummary n t + sumf (Ctx _ (Func (FuncDec fnm t parms) _)) = + EPSummary EPFunc (ctxItem fnm) t (map ((\ (Var n t) -> (n,t)) . ctxItem) parms) + +validationSummary :: (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) -> ([CompilationStatus],[CompilationStatus]) +validationSummary (ms,ss) = (msum,ssum) + where msum = map mkMSum ms + ssum = map mkSSum ss + mkMSum (nm, Left errs) = CompilationStatus nm $ Left (map toErrInfo errs) + mkMSum (nm, Right (lmodule,_)) = CompilationStatus nm $ Right (moduleSummary lmodule) + mkSSum (nm, Left errs) = CompilationStatus nm $ Left (map toErrInfo errs) + mkSSum (nm, Right cscript) = CompilationStatus nm $ Right (scriptSummary cscript) + +data Tup3 a b c = Tup3 a b c + +data Tst = Tst (Double,Int,Char) + +data Tst1 = Tst1 (Tup3 Double Int Char) + +$(deriveJavaRep ''TextLocation) +$(deriveJavaRep ''LSLType) +$(deriveJavaRep ''EPKind) +$(deriveJavaRep ''EPSummary) +$(deriveJavaRep ''GlobalSummary) +$(deriveJavaRep ''CodeElement) +$(deriveJavaRep ''CompilationCommand) +$(deriveJavaRep ''ErrInfo) +$(deriveJavaRep ''CompilationStatus) +$(deriveJavaRep ''State) +$(deriveJavaRep ''GlobDef) +$(deriveJavaRep ''Handler) +$(deriveJavaRep ''Ctx) +$(deriveJavaRep ''Expr) +$(deriveJavaRep ''SourceContext) +$(deriveJavaRep ''Pragma) +$(deriveJavaRep ''LSLScript) +$(deriveJavaRep ''Statement) +$(deriveJavaRep ''Component) +$(deriveJavaRep ''Func) +$(deriveJavaRep ''FuncDec) +$(deriveJavaRep ''Var) +$(deriveJavaRep ''LModule) +$(deriveJavaRep ''CompilationResponse) +$(deriveJavaRep ''Tup3) +$(deriveJavaRep ''Tst) +$(deriveJavaRep ''Tst1) + +data CState = CState { + optimize :: Bool, + modulePaths :: M.Map String String, + scriptPaths :: M.Map String String, + modules :: M.Map String (Validity (LModule,ModuleInfo)), + scripts :: M.Map String (Validity CompiledLSLScript) } + +emptyCState = CState { optimize = False, modulePaths = M.empty, scriptPaths = M.empty, modules = M.empty, scripts = M.empty } + +mkCState (opt,mpaths,spaths) (lib,scripts) = + CState { optimize = opt, modulePaths = M.fromList mpaths, scriptPaths = M.fromList spaths, modules = M.fromList lib, scripts = M.fromList scripts } + +toLib = libFromAugLib . M.toList + +handler :: CState -> String -> IO (CState, String) +handler s0 input = case parse elemDescriptor input of + Left s -> return $ (s0, E.emit "error" [] [showString (E.xmlEscape s)] "") + Right Nothing -> return $ (s0, E.emit "error" [] [showString ("unexpected root element")] "") + Right (Just command) -> handleCommand s0 command + +handleCommand _ (Init srcInfo) = do + compilationResult <- compileAndEmit srcInfo + return (mkCState srcInfo compilationResult, xmlSerialize Nothing (FullSourceValidation $ validationSummary compilationResult) "") +handleCommand cs (UpdateScript scriptInfo) = do + (id,result) <- loadScript (toLib $ modules cs) scriptInfo + let cs' = cs { scripts = M.insert id result (scripts cs) } + renderScriptsToFiles (optimize cs') [(id,result)] [scriptInfo] + return (cs',xmlSerialize Nothing (FullSourceValidation $ validationSummary (M.toList $ modules cs', M.toList $ scripts cs')) "") +handleCommand cs (UpdateModule minfo) = do -- this doesn't quite do what it says it does (yet) + let srcInfo = (optimize cs, M.toList (M.insert (fst minfo) (snd minfo) (modulePaths cs)), M.toList (scriptPaths cs)) + handleCommand cs (Init srcInfo) +handleCommand cs (RemoveModule minfo) = do + let srcInfo = (optimize cs, M.toList (M.delete (fst minfo) (modulePaths cs)),M.toList (scriptPaths cs)) + handleCommand cs (Init srcInfo) +handleCommand cs (RemoveScript scriptInfo) = do + let cs' = cs { scriptPaths = M.delete (fst scriptInfo) (scriptPaths cs), scripts = M.delete (fst scriptInfo) (scripts cs) } + let summary = FullSourceValidation $ validationSummary (M.toList (modules cs'), M.toList (scripts cs')) + let filePath = replaceExtension (snd scriptInfo) ".lsl" + exists <- doesFileExist filePath + when exists $ removeFile filePath + return (cs',xmlSerialize Nothing summary "") +handleCommand cs (CheckModule (CodeElement name text)) = + let (m, errs) = alternateModuleParser name text + lib1 = compileLibrary + (M.toList + (M.insert name m + (M.fromList + [ (n,m) | (n,Right m) <- libFromAugLib $ M.toList (modules cs)]))) + errs' = map parseErrorToErrInfo errs ++ case lookup name lib1 of + Nothing -> [] + Just (Right _) -> [] + Just (Left errs) -> map toErrInfo errs + in return (cs,xmlSerialize Nothing (ModuleResponse (m,errs')) "") +handleCommand cs (CheckScript (CodeElement name text)) = + let (s, errs) = alternateScriptParser name text + lib = libFromAugLib $ M.toList (modules cs) + errs' = map parseErrorToErrInfo errs ++ case compileLSLScript' lib s of + Left errs -> map toErrInfo errs + _ -> [] + in return (cs,xmlSerialize Nothing (ScriptResponse (s,errs')) "") + +compilationServer :: IO () +compilationServer = processLinesSIO emptyCState "quit" handler + +codeGen loc pkg = do + setCurrentDirectory loc + saveReps pkg $ $(collectReps [''CompilationResponse,''CompilationCommand]) pkg
src/Language/Lsl/Internal/Compiler.hs view
@@ -2,7 +2,13 @@ -- issue a report on all the errors it has found -- generate LSL scripts for those LSL+ scripts that successfully 'compiled' -module Language.Lsl.Internal.Compiler(compile,main0) where +module Language.Lsl.Internal.Compiler( + compile, + main0, + compileEmitSummarize, + compileAndEmit, + formatCompilationSummary, + renderScriptsToFiles) where import Control.Monad(when) import qualified Data.ByteString as B @@ -34,6 +40,16 @@ renderScriptsToFiles optimize compiledScripts scriptInfo putStr $ formatCompilationSummary results +compileEmitSummarize sourceInfo@(optimize,_,scriptInfo) = do + results <- compile sourceInfo + renderScriptsToFiles optimize (snd results) scriptInfo + return (results,formatCompilationSummary results) + +compileAndEmit sourceInfo@(optimize,_,scriptInfo) = do + results <- compile sourceInfo + renderScriptsToFiles optimize (snd results) scriptInfo + return results + main0 = readCompileEmit stdin compile :: (Bool,[(String,String)],[(String,String)]) -> IO (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) @@ -58,12 +74,13 @@ ([emit "name" [showString name]] ++ case result of Left errs -> [emit "status" [emit "ok" [showString "false"], emit "errs" (map formatErr errs)]] - Right (CompiledLSLScript globals funcs states) -> + Right (CompiledLSLScript _ globals funcs states) -> [emit "status" [emit "ok" [showString "true"]], emit "entryPoints" (map emitFunc funcs ++ concatMap stateEntryPointEmitters states), emit "globals" (map emitGlobal globals)]) where funcNames = map (\ (Func dec _) -> ctxItem $ funcName dec) - handlerPaths = concatMap (\ (State ctxName handlers) -> map (\ (Handler ctxName1 _ _) -> ctxItem ctxName ++ "." ++ ctxItem ctxName1) handlers) + handlerPaths = concatMap (\ (Ctx _ (State ctxName handlers)) -> map (\ (Ctx _ (Handler ctxName1 _ _)) -> + ctxItem ctxName ++ "." ++ ctxItem ctxName1) handlers) formatModuleCompilationSummary (name,result) = emit "item" @@ -82,16 +99,16 @@ emit "returnType" [showString (lslTypeString $ funcType fd)], emit "params" (emitParams $ map ctxItem (funcParms fd))] -emitGlobal (GDecl (Var n t) _) = emit "global" (emitNameTypePair n t) +emitGlobal (GDecl (Ctx _ (Var n t)) _) = emit "global" (emitNameTypePair n t) emitFreeVar ctxvar = let (Var n t) = ctxItem ctxvar in emit "global" (emitNameTypePair n t) emitNameTypePair n t = [emit "name" [showString n], emit "type" [showString $ lslTypeString t]] -stateEntryPointEmitters (State ctxName handlers) = map (emitHandler $ ctxItem ctxName) handlers +stateEntryPointEmitters (Ctx _ (State ctxName handlers)) = map (emitHandler $ ctxItem ctxName) handlers -emitHandler state (Handler ctxName ctxVars _) = +emitHandler state (Ctx _ (Handler ctxName ctxVars _)) = emit "entryPoint" [ emit "name" [showString (state ++ "." ++ ctxItem ctxName)], emit "returnType" [showString "void"],
+ src/Language/Lsl/Internal/DOMCombinators.hs view
@@ -0,0 +1,176 @@+{-# OPTIONS_GHC -XNoMonomorphismRestriction #-} +module Language.Lsl.Internal.DOMCombinators where + +import Control.Monad.State +import Control.Monad.Error + +import Data.Maybe +import Language.Lsl.Internal.DOMProcessing +import Text.XML.HaXml(Attribute,AttValue(..),Document(..),Element(..),Content(..),Reference(..),xmlParse,info) +import Text.XML.HaXml.Posn(Posn(..),noPos) +import Language.Lsl.Internal.Util(readM) +import Debug.Trace + +type ContentAcceptor a = [Content Posn] -> Either String a +type ContentFinder a = StateT [Content Posn] (Either String) a +type ElementAcceptor a = Posn -> Element Posn -> Either String a +type ElementTester a = Posn -> Element Posn -> Either String (Maybe a) +type AttributeAcceptor a = Posn -> [Attribute] -> Either String a +type AttributeFinder a = StateT (Posn,[Attribute]) (Either String) a +type AttributeTester a = Posn -> Attribute -> Either String (Maybe a) +type AttributesTester a = Posn -> [Attribute] -> Either String (Maybe a) + +el :: String -> (b -> a) -> ContentAcceptor b -> ElementTester a +el tag f cf p (Elem name _ cs) | tag /= name = Right Nothing + | otherwise = case cf cs of + Left s -> Left ("at " ++ show p ++ ": " ++ s) + Right v -> Right (Just (f v)) + +elWith :: String -> (a -> b -> c) -> AttributeAcceptor (Maybe a) -> ContentAcceptor b -> ElementTester c +elWith tag f af cf p (Elem name attrs cs) | tag /= name = Right Nothing + | otherwise = do + av <- af p attrs + case av of + Nothing -> Right Nothing + Just av -> do + cv <- cf cs + return (Just (f av cv)) + +liftElemTester :: (Posn -> (Element Posn) -> Either String (Maybe a)) -> (Content Posn -> Either String (Maybe a)) +liftElemTester ef (CElem e pos) = case ef pos e of + Left s -> Left ("at " ++ show pos ++ ": " ++ s) + Right v -> Right v + +canHaveElem :: ElementTester a -> ContentFinder (Maybe a) +canHaveElem ef = get >>= \ cs -> + mapM (\ c -> (lift . liftElemTester ef) c >>= return . (,) c) [ e | e@(CElem _ _) <- cs ] + >>= (\ vs -> case span (isNothing . snd) vs of + (bs,[]) -> put (map fst bs) >> return Nothing + (bs,c:cs) -> put (map fst (bs ++ cs)) >> return (snd c)) + +mustHaveElem :: ElementTester a -> ContentFinder a +mustHaveElem ef = get >>= \ cs -> + mapM (\ c -> (lift . liftElemTester ef) c >>= return . (,) c) [ e | e@(CElem _ _) <- cs ] + >>= (\ vs -> case span (isNothing . snd) vs of + (bs,[]) -> throwError ("element not found") + (bs,c:cs) -> put (map fst (bs ++ cs)) >> return (fromJust $ snd c)) + +mustHave :: String -> ContentAcceptor a -> ContentFinder a +mustHave s ca = catchError (mustHaveElem (el s id ca)) (\ e -> throwError (e ++ " (" ++ s ++ ")")) + +canHave :: String -> ContentAcceptor a -> ContentFinder (Maybe a) +canHave s ca = canHaveElem (el s id ca) + +comprises :: ContentFinder a -> ContentAcceptor a +comprises cf cs = case runStateT cf cs of + Left s -> throwError s + Right (v,cs') -> empty cs' >> return v + +many :: ElementTester a -> ContentAcceptor [a] +many et cs = case runStateT go cs of + Left s -> throwError ("many: " ++ s) + Right (v,cs') -> empty cs' >> return v + where go = do + isEmpty <- get >>= return . null + if isEmpty then return [] + else do + v <- mustHaveElem et + vs <- go + return (v:vs) + +attContent :: AttValue -> String +attContent (AttValue xs) = foldl (flip (flip (++) . either id refToString)) [] xs + +refToString (RefEntity s) = refEntityString s +refToString (RefChar i) = [toEnum i] + +attrIs :: String -> String -> AttributeTester () +attrIs k v _ (nm,attv) | v == attContent attv && k == nm = return (Just ()) + | otherwise = return Nothing + +hasAttr :: AttributeTester a -> AttributeFinder (Maybe a) +hasAttr at = get >>= \ (pos,attrs) -> mapM (lift . at pos) attrs >>= return . zip attrs >>= (\ ps -> case span (isNothing . snd) ps of + (bs,[]) -> return Nothing + (bs,c:cs) -> put (pos,map fst (bs ++ cs)) >> return (snd c)) + +thisAttr :: String -> String -> AttributesTester () +thisAttr k v p atts = case runStateT (hasAttr (attrIs k v)) (p,atts) of + Left s -> throwError ("at " ++ show p ++ ": " ++ s) + Right (Nothing,(_,l)) -> return Nothing + Right (v,(_,[])) -> return v + _ -> throwError ("at " ++ show p ++ ": unexpected attributes") + +infixr 1 <|> + +(<|>) :: ElementTester a -> ElementTester a -> ElementTester a +(<|>) l r p e = case l p e of + Left s -> throwError ("at: " ++ show p ++ s) + Right Nothing -> r p e + Right v -> return v + +nope :: ElementTester a +nope _ _ = return Nothing + +choice :: [ElementTester a] -> ElementTester a +choice = foldl (<|>) nope + +boolContent cs = simpleContent cs >>= (\ v -> case v of + "true" -> Right True + "false" -> Right False + s -> Left ("unrecognized bool " ++ s)) + +readableContent :: Read a => ContentAcceptor a +readableContent cs = simpleContent cs >>= readM + +refEntityString "lt" = "<" +refEntityString "gt" = ">" +refEntityString "amp" = "&" +refEntityString "quot" = "\"" +refEntityString "apos" = "'" +refEntityString _ = "?" + +simpleContent :: ContentAcceptor String +simpleContent cs = mapM processContentItem cs >>= return . concat + where + processContentItem (CElem (Elem name _ _) _) = Left ("unexpected content element (" ++ name ++ ")") + processContentItem (CString _ s _) = Right s + processContentItem (CRef (RefEntity s) _) = Right $ refEntityString s + processContentItem (CRef (RefChar i) _) = Right $ [toEnum i] + processContentItem (CMisc _ _) = Right "unexpected content" + +empty :: ContentAcceptor () +empty [] = Right () +empty (c:_) = Left ("unexpected content at" ++ show (info c)) +---------------------- + + + +data Foo = Bar { x :: Int, y :: String, z :: Maybe Double } + | Baz { q :: String, r :: Int } + deriving Show + +bar :: ContentAcceptor Foo +bar = comprises $ do + x <- mustHave "x" readableContent + y <- mustHave "y" simpleContent + z <- canHave "z" readableContent + return (Bar x y z) +baz = comprises $ do + q <- mustHave "q" simpleContent + r <- mustHave "r" readableContent + return (Baz q r) + +fooE = el "BarFoo" id bar + <|> el "BazFoo" id baz + +fooAs :: String -> ElementTester Foo +fooAs s = elWith s (const id) (thisAttr "class" "BarFoo") bar + <|> elWith s (const id) (thisAttr "class" "BazFoo") baz + +data Zzz = Zzz { content :: [Foo], bleah :: Foo } deriving Show + +zzzE = el "Zzz" id $ comprises (mustHave "content" (many fooE) >>= \ cs -> mustHaveElem (fooAs "bleah") >>= \ b -> return $ Zzz cs b) + +parse :: ElementAcceptor a -> String -> Either String a +parse eaf s = eaf noPos el + where Document _ _ el _ = xmlParse "" s
src/Language/Lsl/Internal/DOMProcessing.hs view
@@ -7,6 +7,8 @@ findValueOrDefault, findBoolOrDefault, findValue, + findOptionalValue, + findOptionalBool, valueAcceptor, -- String -> ElemAcceptor m t ctxelem, simple, @@ -29,10 +31,11 @@ --module Text.XML.HaXml.Posn ) where +import Data.Maybe import Control.Monad(MonadPlus(..),liftM2) import Control.Monad.Error(MonadError(..)) import Language.Lsl.Internal.Util(readM) -import Text.XML.HaXml(AttValue(..),Document(..),Element(..),Content(..),Reference(..),xmlParse) +import Text.XML.HaXml(Attribute,AttValue(..),Document(..),Element(..),Content(..),Reference(..),xmlParse) import Text.XML.HaXml.Posn(Posn(..)) data Monad m => ElemAcceptor m t = ElemAcceptor { acceptorTag :: String, acceptorFunc :: (Element Posn -> m t) } @@ -117,6 +120,22 @@ value <- readM sval return (value,rest) +findOptionalValue name contents = + do (v,rest) <- findOptionalElement (simpleElement name) contents + case v of + Nothing -> return (Nothing,contents) + Just s -> do + value <- readM s + return (value, rest) + +findOptionalBool name contents = + do (v,rest) <- findOptionalElement (simpleElement name) contents + case v of + Nothing -> return (Nothing,contents) + Just "true" -> return (Just True,rest) + Just "false" -> return (Just False,rest) + Just s -> fail ("unable to parse " ++ s) + findBoolOrDefault def name contents = do (sval,rest) <- findOptionalElement (simpleElement name) contents case sval of @@ -139,3 +158,82 @@ decode (Left v) = v decode (Right (RefEntity ent)) = "&"++ent++";" decode (Right (RefChar cref)) = "&"++show cref++";" + +-- type ContentAcceptor a = [Content Posn] -> Either String a +-- type ContentFinder a = [Content Posn] -> Either String (Maybe a, [Content Posn]) +-- type ElementAcceptor a = Element Posn -> Either String a +-- type ElementTester a = Element Posn -> Either String (Maybe a) +-- type AttributeAcceptor a = [Attribute] -> Either String a + +-- mustBe :: String -> (b -> a) -> ContentAcceptor b -> ElementAcceptor a +-- mustBe tag f cf (Elem name _ cs) | tag /= name = Left ("expected " ++ tag) +-- | otherwise = case cf cs of +-- Left s -> Left s +-- Right v -> Right (f v) + +-- canBe :: String -> (b -> a) -> ContentAcceptor b -> ElementTester a +-- canBe tag f cf (Elem name _ cs) | tag /= name = Right Nothing +-- | otherwise = case cf cs of +-- Left s -> Left s +-- Right v -> Right (Just (f v)) + +-- mustBeWith :: String -> (a -> b -> c) -> AttributeAcceptor a -> ContentAcceptor b -> ElementAcceptor c +-- mustBeWith tag f af cf (Elem name attrs cs) | tag /= name = Left ("expected " ++ tag) +-- | otherwise = do +-- av <- af attrs +-- cv <- cf cs +-- return (f av cv) + +-- canBeWith :: String -> (a -> b -> c) -> AttributeAcceptor a -> ContentAcceptor b -> ElementTester c +-- canBeWith tag f af cf (Elem name attrs cs) | tag /= name = Right Nothing +-- | otherwise = do +-- av <- af attrs +-- cv <- cf cs +-- return (Just (f av cv)) + +-- liftElemTester :: ((Element Posn) -> Either String (Maybe a)) -> (Content Posn -> Either String (Maybe a)) +-- liftElemAcceptor ef (CElem e pos) = case ef e of +-- Left s -> Left ("at " ++ show pos ++ ": " ++ s) +-- Right v -> Right v +-- +-- canHaveElem :: ElementAcceptor a -> ContentFinder a +-- canHaveElem ef cs = mapM (\ c -> liftElemAcceptor ef c >>= return . (,) c) cs >>= (\ vs -> case span (isNothing . snd) vs of +-- (bs,[]) -> Right (Nothing,map fst bs) +-- (bs,c:cs) -> Right (snd c,map fst $ bs ++ cs)) +-- +-- mustHaveElem :: ElementAcceptor a -> ContentFinder a +-- mustHaveElem ef cs = mapM (\ c -> liftElemAcceptor ef c >>= return . (,) c) cs >>= (\ vs -> case span (isNothing . snd) vs of +-- (bs,[]) -> Left ("element not found") +-- (bs,c:cs) -> Right (snd c,map fst $ bs ++ cs)) + +-- boolContent cs = simpleContent cs >>= (\ v -> case v of +-- "true" -> Right True +-- "false" -> Right False +-- s -> Left ("unrecognized bool " ++ s)) +-- +-- readableContent :: Read a => ContentAcceptor a +-- readableContent cs = simpleContent cs >>= readM + +-- simpleContent :: ContentAcceptor String +-- simpleContent cs = mapM processContentItem cs >>= return . concat +-- where +-- processContentItem (CElem (Elem name _ _) _) = Left ("unexpected content element (" ++ name ++ ")") +-- processContentItem (CString _ s _) = Right s +-- processContentItem (CRef (RefEntity "lt") _) = Right "<" +-- processContentItem (CRef (RefEntity "gt") _) = Right ">" +-- processContentItem (CRef (RefEntity "amp") _) = Right "&" +-- processContentItem (CRef (RefEntity "quot") _) = Right "\"" +-- processContentItem (CRef (RefEntity "apos") _) = Right "'" +-- processContentItem (CMisc _ _) = Right "unexpected content" + +-- empty :: ContentAcceptor () +-- empty [] = Right () +-- empty _ = Left "unexpected content" + +-- data FooBar = FooBar { foo :: Int, bar :: String } + +-- fooE :: ElementAcceptor Int +-- fooE = mustBe "foo" id readableContent + +-- -- foobar = mustBe "FooBar" (\ _ -> FooBar 0 "") ( \ cs -> do +-- mustHave (mustBe "foo"
src/Language/Lsl/Internal/Exec.hs view
@@ -67,14 +67,14 @@ -- initialize a script for execution initLSLScript :: RealFloat a => CompiledLSLScript -> ScriptImage a -initLSLScript (CompiledLSLScript globals fs ss) = +initLSLScript (CompiledLSLScript _ globals fs ss) = ScriptImage { scriptImageName = "", curState = "default", executionState = Waiting, glob = initGlobals globals, funcs = map ctxItem fs, - states = ss, + states = map ctxItem ss, valueStack = [], callStack = [], stepManager = emptyStepManager, @@ -259,7 +259,7 @@ 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 +initGlobal globals (GDecl (Ctx _ (Var name t)) mexpr) = initVar name t $ fmap (evalLit globals) mexpr evalCtxLit globals (Ctx _ expr) = evalLit globals expr @@ -280,7 +280,7 @@ VecExpr a b c -> VVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c) RotExpr a b c d -> RVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c) (litExpr2Float d) Get (Ctx _ nm,All) -> - case find (\ (GDecl (Var nm' t) mexpr') -> nm == nm') globals of + case find (\ (GDecl (Ctx _ (Var nm' t)) mexpr') -> nm == nm') globals of Nothing -> case findConstVal nm of Nothing -> error ("invalid global " ++ nm ++ " referenced in initializer") @@ -582,13 +582,13 @@ deriving (Show,Eq) matchEvent (Event name _ _) [] = fail ("no such handler" ++ name) -matchEvent event@(Event name values _) ((Handler (Ctx ctx name') parms stmts):hs) +matchEvent event@(Event name values _) ((Ctx _ (Handler (Ctx ctx name') parms stmts)):hs) | name == name' = do mem <- bindParms (ctxItems parms) values return (mem,stmts,name,ctx) | otherwise = matchEvent event hs findHandler name handlers = ctx ("finding handler " ++ name) $ - findM (\ (Handler (Ctx _ name') _ _) -> name' == name) handlers + findM (\ (Ctx _ (Handler (Ctx _ name') _ _)) -> name' == name) handlers evalScriptSimple :: (Read a, RealFloat a, Monad w) => Int -> [String] -> [Binding a] -> [LSLValue a] -> Eval w a (EvalResult,Maybe (LSLValue a)) @@ -630,7 +630,7 @@ getEntryPoint [stateName,handlerName] = do states <- getStates (State _ handlers) <- findState stateName states - (Handler name params stmts) <- findHandler handlerName handlers + (Ctx _ (Handler name params stmts)) <- findHandler handlerName handlers return (ctxItems params,stmts, srcCtx name) incontext s f = @@ -937,7 +937,7 @@ (FVal f1,IVal i2) -> FVal (f1 / fromInt i2) (FVal f1,FVal f2) -> FVal (f1/f2) (v@(VVal _ _ _),IVal i) -> let f = 1.0 / fromInt i in vecMulScalar v f - (v@(VVal _ _ _),FVal f) -> vecMulScalar v f + (v@(VVal _ _ _),FVal f) -> vecMulScalar v (1/f) (v@(VVal _ _ _),r@(RVal _ _ _ _)) -> rotMulVec (invRot r) v (r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> rotMul r1 $ invRot r2 _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) @@ -1114,4 +1114,4 @@ hasActiveHandler simage handler = case find ( \ (State ctxname _) -> curState simage == ctxItem ctxname) (states simage) of Nothing -> False - Just (State _ handlers) -> isJust $ find (\ (Handler ctxname _ _) -> handler == ctxItem ctxname) handlers + Just (State _ handlers) -> isJust $ find (\ (Ctx _ (Handler ctxname _ _)) -> handler == ctxItem ctxname) handlers
src/Language/Lsl/Internal/FuncSigs.hs view
@@ -97,8 +97,10 @@ ("llGetEnergy",LLFloat,[]), ("llGetForce",LLVector,[]), ("llGetFreeMemory",LLInteger,[]), -- SEMI-INTERNAL!!!+ ("llGetFreeURLs",LLInteger,[]), ("llGetGMTclock",LLFloat,[]), ("llGetGeometricCenter",LLVector,[]),+ ("llGetHTTPHeader",LLString, [LLKey,LLString]), ("llGetInventoryCreator",LLKey,[LLString]), ("llGetInventoryKey",LLKey,[LLString]), ("llGetInventoryName",LLString,[LLInteger,LLInteger]),@@ -176,6 +178,7 @@ ("llGroundRepel",LLVoid,[LLFloat,LLInteger,LLFloat]), ("llGroundSlope",LLVector,[LLVector]), ("llHTTPRequest",LLKey,[LLString,LLList,LLString]),+ ("llHTTPResponse",LLVoid,[LLKey,LLInteger,LLString]), ("llInsertString",LLString,[LLString,LLInteger,LLString]), ("llInstantMessage",LLVoid,[LLKey,LLString]), ("llIntegerToBase64",LLString,[LLInteger]),@@ -237,6 +240,7 @@ ("llRegionSay",LLVoid,[LLInteger,LLString]), ("llReleaseCamera",LLVoid,[LLKey]), ("llReleaseControls",LLVoid,[]),+ ("llReleaseURL",LLVoid, [LLString]), ("llRemoteDataReply",LLVoid,[LLKey,LLKey,LLString,LLInteger]), ("llRemoteDataSetRegion",LLVoid,[]), ("llRemoteLoadScript",LLVoid,[LLKey,LLString,LLInteger,LLInteger]), -- deprecated/removed@@ -248,6 +252,8 @@ ("llRequestAgentData",LLKey,[LLKey,LLInteger]), ("llRequestInventoryData",LLKey,[LLString]), ("llRequestPermissions",LLVoid,[LLKey,LLInteger]),+ ("llRequestSecureURL", LLString, []),+ ("llRequestURL", LLKey, []), ("llRequestSimulatorData",LLKey,[LLString,LLInteger]), ("llResetLandBanList",LLVoid,[]), ("llResetLandPassList",LLVoid,[]),@@ -588,6 +594,7 @@ ("llGroundContour",(["v"],"returns the ground contour below the object position + v\n")), ("llGetAttached",([],"returns the object attachment point or 0 if not attached\n")), ("llGetFreeMemory",([],"returns the available heap space for the current script\n")),+ ("llGetFreeURLs",([],"Returns an integer that is the number of available URLs.\n")), ("llGetRegionName",([],"returns the current region name\n")), ("llGetRegionTimeDilation",([],"returns the current time dilation as a float between 0 and 1\n")), ("llGetRegionFPS",([],"returns the mean region frames per second\n")),@@ -641,6 +648,7 @@ ("llGetNumberOfNotecardLines",(["name"],"Returns number of lines in notecard 'name' via the dataserver event (cast return value to integer)\n")), ("llGetBoundingBox",(["object"],"Returns the bounding box around an object (including any linked prims) relative to the root prim, in a list: [ (vector) min_corner, (vector) max_corner ]\n")), ("llGetGeometricCenter",([],"Returns the geometric center of the linked set the script is attached to.\n")),+ ("llGetHTTPHeader",(["request_id", "header"],"Returns a string that is the value for header for request_id.\n")), ("llGetPrimitiveParams",(["params"],"Gets primitive parameters specified in the params list.\n")), ("llIntegerToBase64",(["number"],"Big endian encode of of integer as a Base64 string.\n")), ("llBase64ToInteger",(["str"],"Big endian decode of a Base64 string into an integer.\n")),@@ -683,6 +691,7 @@ ("llGetRegionFlags",([],"Get the region flags (REGION_FLAG_*) for the region the object is in.\n")), ("llXorBase64StringsCorrect",(["s1","s2"],"Correctly performs an exclusive or on two Base 64 strings and returns a Base 64 string. s2 repeats if it is shorter than s1.\n")), ("llHTTPRequest",(["url","parameters","body"],"Send an HTTP request.\n")),+ ("llHTTPResponse",(["request_id", "status", "body"],"Responds to request_id with status and body.\n")), ("llResetLandBanList",([],"Removes all residents from the land ban list.\n")), ("llResetLandPassList",([],"Removes all residents from the land access/pass list.\n")), ("llGetObjectPrimCount",(["object_id"],"Returns the total number of prims for an object.\n")),@@ -701,4 +710,9 @@ ("llDetectedTouchST", (["index"], "Returns a vector that is the surface coordinates for where the prim was touched. The x & y vector positions contain the horizontal (s) & vertical (t) face coordinates respectively (<s, t, 0.0>). Each component is in the interval [0.0, 1.0].\n")), ("llDetectedTouchUV", (["index"], "Returns a vector that is the texture coordinates for where the prim was touched. The x & y vector positions contain the u & v face coordinates respectively (<u, v, 0.0>).\n")), ("llGetRegionAgentCount", ([], "Returns an integer that is the number of avatars in the region.\n")),- ("llGetAgentLanguage", (["key"], "Returns a string that is the language code of the preferred interface language of the user avatar.\n"))]+ ("llGetAgentLanguage", (["key"], "Returns a string that is the language code of the preferred interface language of the user avatar.\n")),+ ("llReleaseURL", (["url"], "Releases the specified URL, it will no longer be usable.\n")),+ ("llRequestSecureURL", ([], "Requests one HTTPS:// (SSL) url for use by this object. The http_request event is tiggered with results.\n")),+ ("llRequestSecureURL", ([], "Requests one HTTP:// url for use by this object. The http_request event is tiggered with results.\n"))+ ]+
src/Language/Lsl/Internal/Load.hs view
@@ -1,22 +1,24 @@ module Language.Lsl.Internal.Load( + loadScript, loadScripts, loadModules) where import Control.Exception(SomeException(..),tryJust) import Control.Monad.Error(liftIO) +import Control.Monad.Trans(MonadIO(..)) import Language.Lsl.Internal.BuiltInModules(avEventGen) -import Language.Lsl.Syntax(SourceContext(..),compileLSLScript',compileLibrary) +import Language.Lsl.Syntax(SourceContext(..),compileLSLScript',compileLibrary,Library,CompiledLSLScript,Validity) import Language.Lsl.Parse(parseModule, parseScript) -parseFiles p files = - let parseFile (name,path) = - do result <- tryJust (\ e@(SomeException x) -> Just (show e)) $ p path - case result of - 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 +parseFiles p files = mapM (parseFile p) files +parseFile p (name,path) = + do result <- tryJust (\ e@(SomeException x) -> Just (show e)) $ p path + case result of + Left msg -> return (name,Left (Nothing,msg)) + Right (Left err) -> return (name,Left err) + Right (Right m) -> return (name,Right m) + loadModules files = do parseResults <- parseFiles parseModule files let (bad,ok) = splitResults parseResults @@ -30,16 +32,18 @@ -- return (augLib ++ (map (\ (n,err) -> (n,Left [err])) bad)) -- --return (validated ++ (map (\ (n,err) -> (n,Left err)) bad)) -loadScripts library files = - do parseResults <- parseFiles parseScript files - let (bad,ok) = splitResults parseResults - return $ (map (\ (n,script) -> (n,compileLSLScript' library script)) ok) ++ - (map (\ (n,err) -> (n,Left [err])) bad) - --- loadScripts' library files = +loadScript :: Library -> (t,String) -> IO (t,Validity CompiledLSLScript) +loadScript lib sinfo = + parseFile parseScript sinfo + >>= \ r -> case r of + (t,Left e) -> return (t,Left [e]) + (t,Right script) -> return (t, compileLSLScript' lib script) +loadScripts library = mapM (loadScript library) + +-- loadScripts library files = -- do parseResults <- parseFiles parseScript files -- let (bad,ok) = splitResults parseResults --- return $ (map (\ (n,script) -> (n,validLSLScript library script)) ok) ++ +-- return $ (map (\ (n,script) -> (n,compileLSLScript' library script)) ok) ++ -- (map (\ (n,err) -> (n,Left [err])) bad) splitResults [] = ([],[])
src/Language/Lsl/Internal/Optimize.hs view
@@ -32,7 +32,8 @@ optionInlining = elem OptimizationInlining optimizeScript :: [OptimizerOption] -> CompiledLSLScript -> CompiledLSLScript -optimizeScript options script@(CompiledLSLScript gs fsIn ss) = CompiledLSLScript gsReachable fsReachable ss1 +optimizeScript options script@(CompiledLSLScript comment gs fsIn ss) = + CompiledLSLScript comment gsReachable fsReachable ss1 where inline = optionInlining options gcs = globalConstants gs fsIn ss scc = graphInfo fsIn @@ -47,8 +48,8 @@ fsReachable = reachableFuncs ss1 (simp fs') -- funcs that are still reachable from handlers gsReachable = reachableGlobs (simp 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)) + runInliningOnState s@(Ctx sc (State nm hs)) = if noinlining nm then s + else (Ctx sc (State nm (map (runInliningOnHandler funFacts ifs' gs) hs))) hasPragma p (Ctx (Just SourceContext { srcPragmas = l }) _) | p `elem` l = True | otherwise = False @@ -59,8 +60,9 @@ 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 +stateEdges :: [Ctx State] -> [(EPKey,EPKey,[EPKey])] +stateEdges ss = concatMap (\ (Ctx _ (State (Ctx _ nm) hs)) -> (map (\ h@(Ctx _ (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 @@ -102,7 +104,7 @@ funcCallsFuncs :: Ctx Func -> [String] funcCallsFuncs = everythingBut stopCondition (++) [] ([] `mkQ` exprCallsFuncDirectly) -handlerCallsFuncs :: Handler -> [String] +handlerCallsFuncs :: Ctx Handler -> [String] handlerCallsFuncs = everythingBut stopCondition (++) [] ([] `mkQ` exprCallsFuncDirectly) fname (Ctx _ (Func (FuncDec (Ctx _ name) _ _) _)) = name @@ -392,7 +394,7 @@ 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)) + evalState (performInliningOnFunc f) (freshOptimizerState ff fs (map (\ (GDecl (Ctx _ (Var nm _)) _) -> nm) gs)) performInliningOnFunc :: Ctx Func -> OState (Ctx Func) performInliningOnFunc f@(Ctx ctx (Func (FuncDec nm t parms) stmts)) = @@ -407,9 +409,9 @@ 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)) +runInliningOnHandler :: M.Map String FunctionFacts -> [Ctx Func] -> [Global] -> Ctx Handler -> Ctx Handler +runInliningOnHandler ff fs gs h = if noinlining (handlerName $ ctxItem h) then h else + nullCtx $ evalState (performInliningOnHandler $ ctxItem h) (freshOptimizerState ff fs (map (\ (GDecl (Ctx _ (Var nm _)) _) -> nm) gs)) performInliningOnHandler :: Handler -> OState Handler performInliningOnHandler h@(Handler nm parms stmts) = @@ -791,16 +793,17 @@ comp :: Component -> Bool comp _ = True -reachableGlobs gs fs ss = [ g | g@(GDecl (Var nm _) _) <- gs, nm `elem` reachableNames] +reachableGlobs gs fs ss = [ g | g@(GDecl (Ctx _ (Var nm _)) _) <- gs, nm `elem` reachableNames] where reachableNames = (gnms `areUsedIn` ss) ++ (gnms `areUsedIn` fs) ++ (gnms `areUsedIn` gs) - gnms = [ nm | g@(GDecl (Var nm _) _) <- gs] + gnms = [ nm | g@(GDecl (Ctx _ (Var nm _)) _) <- gs] -globalConstants :: [Global] -> [Ctx Func] -> [State] -> M.Map String Expr +globalConstants :: [Global] -> [Ctx Func] -> [Ctx State] -> M.Map String Expr globalConstants gs fs ss = foldl globalConstant M.empty gs - where globalConstant m (GDecl (Var nm t) mexpr) = if nm `notElem` nonConsts then M.insert nm (mexpr2expr m t mexpr) m else m + where globalConstant m (GDecl (Ctx _ (Var nm t)) mexpr) = + if nm `notElem` nonConsts then M.insert nm (mexpr2expr m t mexpr) m else m nonConsts = arentConstants gnms fs ++ arentConstants gnms ss - gnms = [nm | (GDecl (Var nm _) _) <- gs] + gnms = [nm | (GDecl (Ctx _ (Var nm _)) _) <- gs] -- isAConst nm = isConstant nm fs && isConstant nm ss expr2expr :: M.Map String Expr -> Expr -> Expr expr2expr m = everywhere (mkT go) @@ -1051,4 +1054,4 @@ srcContext _ = True stopCondition :: Data a => a -> Bool -stopCondition = (False `mkQ` string `extQ` srcContext) +stopCondition = (False `mkQ` string `extQ` srcContext)
+ src/Language/Lsl/Internal/SerializationGenerator.hs view
@@ -0,0 +1,420 @@+{-# OPTIONS_GHC -XTemplateHaskell -XFlexibleInstances -XTypeSynonymInstances + -XScopedTypeVariables -XOverlappingInstances + #-} +module Language.Lsl.Internal.SerializationGenerator where + +import Language.Haskell.TH +import Control.Monad +import Data.Maybe +import qualified Control.Monad.State as State +import qualified Data.Map as M +import Language.Lsl.Internal.XmlCreate +import Language.Lsl.Internal.DOMProcessing +import Language.Lsl.Internal.DOMCombinators +import Data.Generics +import Data.Int +import Data.List +import Debug.Trace +import Text.XML.HaXml.Parse hiding (fst3,snd3,thd3) +import Text.XML.HaXml.Posn + +class JavaRep a where + representative :: a + xmlSerialize :: Maybe String -> a -> String -> String + xmlDefaultTag :: a -> String + subElemDescriptor :: String -> ElementTester a + elemDescriptor :: ElementTester a + contentFinder :: String -> ContentFinder a + +instance JavaRep Int where + representative = (0 :: Int) + xmlSerialize t i = emit (maybe "int" id t) [] [shows i] + xmlDefaultTag _ = "int" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "int" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Int32 where + representative = (0 :: Int32) + xmlSerialize t i = emit (maybe "int" id t) [] [shows i] + xmlDefaultTag _ = "int" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "int" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Int64 where + representative = (0 :: Int64) + xmlSerialize t i = emit (maybe "long" id t) [] [shows i] + xmlDefaultTag _ = "long" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "int" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Float where + representative = (0 :: Float) + xmlSerialize t i = emit (maybe "float" id t) [] [shows i] + xmlDefaultTag _ = "float" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "float" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Double where + representative = (0 :: Double) + xmlSerialize t i = emit (maybe "double" id t) [] [shows i] + xmlDefaultTag _ = "double" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "double" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Char where + representative = (' ') + xmlSerialize t c = emit (maybe "char" id t) [] [shows c] + xmlDefaultTag _ = "char" + subElemDescriptor tag = el tag id readableContent + elemDescriptor = el "char" id readableContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep Bool where + representative = True + xmlSerialize t b = emit (maybe "boolean" id t) [] [shows b] + xmlDefaultTag _ = "boolean" + subElemDescriptor tag = el tag id boolContent + elemDescriptor = el "boolean" id boolContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep String where + representative = "" + xmlSerialize t s = emit (maybe "string" id t) (maybe [] (const [("class","string")]) t) [showString s] + xmlDefaultTag _ = "string" + subElemDescriptor tag = el tag id simpleContent + elemDescriptor = el "string" id simpleContent + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +instance JavaRep a => JavaRep [a] where + representative = [ (representative :: a) ] + xmlSerialize t l = + emit (maybe (xmlDefaultTag (representative :: [a])) id t) (maybe [] (const [("class","linked-list")]) t) + (map (\ v -> xmlSerialize Nothing v) l) + xmlDefaultTag _ = "linked-list" + subElemDescriptor tag = el tag id (many $ elemDescriptor) + elemDescriptor = el (xmlDefaultTag (representative :: [a])) id (many $ elemDescriptor) + contentFinder tag = mustHaveElem $ subElemDescriptor tag + +-- instance JavaRep a => JavaRep (Maybe a) where +-- representative = Just (representative :: a) +-- xmlSerialize t Nothing = id +-- xmlSerialize t (Just v) = xmlSerialize t v +-- xmlDefaultTag x = xmlDefaultTag (representative :: a) +-- subElemDescriptor tag = \ p e -> subElemDescriptor tag p e >>= return . Just +-- elemDescriptor = \ p e -> elemDescriptor p e >>= return . Just +-- contentFinder tag = (canHaveElem $ (\ p e -> subElemDescriptor tag p e)) + +deriveJavaRepTups l = mapM deriveJavaRepTup l >>= return . concat + +deriveJavaRepTup n = do + let ns = show n + vs <- mapM newName (replicate n "v") + let ctx = mapM (appT javaRepCon . varT) vs + let typ = appT javaRepCon $ foldl appT (tupleT n) (map varT vs) + let representativeD = + valD (varP 'representative) (normalB $ tupE (replicate n (varE 'representative))) [] + let nameE = stringE ("Tuple" ++ show n) + let repGenE = do + pkgVarName <- newName "pkg" + let pkgE = varE pkgVarName + let pkgP = varP pkgVarName + let tparms = intercalate "," (zipWith (\ x y -> x ++ show y) (replicate n "E") [1..n]) + let fields = concatMap (\ i -> " public E" ++ show i ++ " el" ++ show i ++ ";\n") [1..n] + let clsE = [| "package " ++ $pkgE ++ + $(stringE ( concat [ + ";\nimport com.thoughtworks.xstream.XStream;\n", + "public class Tuple", ns, "<", tparms, "> {\n", fields, + " public static void init(XStream xstream) {\n", + " xstream.alias(\"Tuple", ns, "\",Tuple", ns, ".class); //$NON-NLS-1$\n }\n", + "}\n"])) |] + lam1E pkgP ([|[($nameE,$clsE)]|]) + let mkClause = do + tagName <- newName "tag" + vs <- mapM newName (replicate n "v") + let tagNmE = varE tagName + let tagE = [| maybe $nameE id $tagNmE |] + let attrsE = [| maybe [] (const [("class",$nameE)]) $tagNmE |] + let subElem i x = [e|xmlSerialize (Just $(stringE ("el" ++ show i))) $(varE x)|] + let lst = listE (zipWith subElem [1..n] vs) + let expr = [| emit $tagE $attrsE $lst |] + clause [varP tagName, return (TupP (map VarP vs))] (normalB $ expr) [] + let xmlSerD = funD 'xmlSerialize [mkClause] + let stmts vs [] = return [noBindS [| return $(tupE (map varE vs))|] ] + stmts vs ((t,v):ts) = do + rest <- stmts vs ts + let stmt = bindS (varP v) [| contentFinder $(stringE t) |] + return (stmt : rest) + let fields vs terms = doE =<< (stmts vs terms) + let subElemDescriptorD = do + tagNm <- newName "tag" + vs <- mapM newName (replicate n "v") + let tagNmE = varE tagNm + let tags = map (("el" ++) . show) [1..n] + let terms = zip tags vs + let elE = [| el $tagNmE id $ + comprises $(fields vs terms) |] + funD 'subElemDescriptor [clause [varP tagNm] (normalB elE) []] + let elemDescriptorD = do + vs <- mapM newName (replicate n "v") + let tags = map (("el" ++) . show) [1..n] + let terms = zip tags vs + let elE = [| el $nameE id (comprises $(fields vs terms)) |] + funD 'elemDescriptor [clause [] (normalB elE) []] + let contentFinderD = do + tagNm <- newName "tag" + funD 'contentFinder + [clause [(varP tagNm)] (normalB [| mustHaveElem (subElemDescriptor $(varE tagNm)) |]) [] ] + sequence [instanceD ctx typ [representativeD,xmlSerD,funD 'xmlDefaultTag [clause [wildP] (normalB nameE) []], + subElemDescriptorD, elemDescriptorD, contentFinderD], + valD (varP $ mkName ("jrep'" ++ "Tuple" ++ show n)) (normalB repGenE) []] + +deriveJavaRep nm = if nm == ''[] then return [] else + do info <- reify nm + case info of + TyConI d -> deriveInstance d + _ -> fail $ ("can't generate serializer for specified name: " ++ show nm) + where + deriveInstance (DataD _ tnm vs cs _) = do + checkAllFields cs + sequence [instanceD ctx typ [representativeD,xmlSerializeD,dec1, + subElemDescriptorD,elemDescriptorD,contentFinderD], + valD (varP (mkName $ "jrep'" ++ (nameBase tnm))) (normalB representationE) []] + where ctx = mapM (appT javaRepCon . varT) vs + typ = appT javaRepCon $ foldl appT (conT tnm) (map varT vs) + representativeV = varE 'representative + mkRepresentative [] = [e|undefined|] + mkRepresentative (c:_) = getCInfo c >>= + \ (cnm,fts) -> foldl appE (conE cnm) (replicate (length fts) representativeV) + representativeD = firstDec [d|representative = $(mkRepresentative cs)|] + nameE = stringE (nameBase tnm) + representationE = do + pkgVarName <- newName "pkg" + let pkgE = varE pkgVarName + let pkgP = varP pkgVarName + let tparms = zipWith (\ v i -> (v, "E" ++ show i)) vs [1..] + let gparms = if null tparms then "" else "<" ++ intercalate "," (map snd tparms) ++ ">" + let baseclassBody = + "import com.thoughtworks.xstream.XStream;\n" ++ + "public class " ++ (nameBase tnm ++ gparms) ++ "{\n" ++ + " public static void init(XStream xstream) {\n" ++ + " xstream.alias(\"" ++ (nameBase tnm) ++ "\"," ++ + (nameBase tnm) ++ ".class); //$NON-NLS-1$\n }\n}\n" + let baseclass = [|"package " ++ $pkgE ++ ";\n" ++ $(stringE baseclassBody)|] + let mkSubClassExpr c = do + (cnm,fts) <- getCInfo c + let cname = (nameBase tnm) ++ "_" ++ (nameBase cnm) + let basenm = (nameBase tnm) + fts' <- forM fts $ (\ (nm,t) -> (deSyn [] t) >>= return . (,) nm) + let importList = hasList (map snd fts') + let fields = + flip concatMap fts' (\ (nm,t) -> + " public " ++ (repT tparms 0 t) ++ + " " ++ nameBase nm ++ ";\n") + let classStr = "import com.thoughtworks.xstream.XStream;\n" ++ + (if importList + then "import java.util.LinkedList;\n" + else "") ++ + "public class " ++ cname ++ gparms ++ + " extends " ++ basenm ++ gparms ++ "{\n" ++ + fields ++ + " public static void init(XStream xstream) {\n" ++ + " xstream.alias(\"" ++ cname ++ "\"," ++ cname ++ ".class); //$NON-NLS-1$\n" ++ + " }\n}\n" + let subclass = [|"package " ++ $pkgE ++ ";\n" ++ $(stringE classStr)|] + [e|($(nameE) ++ "_" ++ $(stringE $ nameBase cnm),$subclass)|] + let subClassExprs = map mkSubClassExpr cs + lam1E pkgP [e| ($nameE,$baseclass) : $(listE subClassExprs) |] + xmlSerializeD = funD (mkName "xmlSerialize") (map mkClause cs) + dec1 = funD (mkName "xmlDefaultTag") [clause [wildP] (normalB nameE) []] + computeVarInfo (nm,_) = newName "x" >>= return . ((,) nm) + mkClause c = do + (cnm,fts) <- getCInfo c + vis <- mapM computeVarInfo fts + tagVarName <- newName "tag" + let tagVarE = varE tagVarName + let cnmE = [| $(nameE) ++ "__" ++ $(stringE $ nameBase cnm)|] + let cnmEA = [| $(nameE) ++ "_" ++ $(stringE $ nameBase cnm)|] + let termf (fnm,vnm) = [|xmlSerialize (Just $(stringE $ nameBase fnm)) $(varE vnm)|] + let terms = map termf vis + let maybeE = [| maybe $cnmE id $tagVarE|] + let attrs = [| maybe [] (const [("class",$cnmEA)]) $tagVarE|] + let termsE = listE (if null terms then [] else [foldl1 (\ x y -> [| $x . $y |]) terms]) + let exp = [| emit $maybeE $attrs $termsE |] + clause [varP tagVarName,conP cnm (map (varP . snd) vis)] (normalB exp) [] + mkNoBindS cnm vs = [noBindS $ [| return $(foldl (appE) (conE cnm) (map varE $ reverse vs)) |]] + mkCnmE cnm = [| $(nameE) ++ "__" ++ $(stringE $ nameBase cnm)|] + mkCnmEA cnm = [| $(nameE) ++ "_" ++ $(stringE $ nameBase cnm)|] + stmts cnm vs [] = return (mkNoBindS cnm vs) + stmts cnm vs ((fnm,_):vis) = do + vn <- newName "v" + rest <- stmts cnm (vn:vs) vis + let stmt = bindS (varP vn) [| contentFinder $(stringE (nameBase fnm)) |] + return $ stmt : rest + fields cnm vis = doE =<< (stmts cnm [] vis) + contentE cnm vis = [| comprises $(fields cnm vis) |] + subElemDescriptorD = do + tagNm <- newName "tag" + let choices = listE (map (mkChoice tagNm) cs) + funD 'subElemDescriptor + [clause [(varP tagNm)] (normalB [| choice $choices |]) []] + where mkChoice tagNm c = do + (cnm,fts) <- getCInfo c + let tagNmE = varE tagNm + let cnmE = mkCnmEA cnm + vis <- mapM computeVarInfo fts + [| elWith $tagNmE (const id) (thisAttr "class" $cnmE) $(contentE cnm vis) |] + elemDescriptorD = do + funD 'elemDescriptor [clause [] (normalB [| choice $choices |]) []] + where choices = listE (map mkChoice cs) + mkChoice c = do + (cnm,fts) <- getCInfo c + let cnmE = mkCnmE cnm + vis <- mapM computeVarInfo fts + [| el $cnmE id $(contentE cnm vis) |] + contentFinderD = do + tagNm <- newName "tag" + funD 'contentFinder + [clause [(varP tagNm)] + (normalB [| mustHaveElem (subElemDescriptor $(varE tagNm)) |]) []] + deriveInstance dec = fail ("can't derive instance for: " ++ show (ppr dec) ++ " (" ++ show dec ++ ")") + +getCInfo c = case c of + RecC cnm fvs -> return (cnm, map (\ (f,_,t) -> (f,t)) fvs) + NormalC cnm vs -> return (cnm, zipWith (\ i (_,t) -> (mkName $ "el" ++ show i, t)) [1..(length vs)] vs) + _ -> fail ("can't create java representation for " ++ show (ppr c)) + +checkField (_,t) | appliesVar t = fail ("can't generate serializer for type with type variables of kind other than '*'") + | otherwise = return () +checkFields = mapM checkField + +checkAllFields = mapM (\ c -> getCInfo c >>= \ (_,fts) -> checkFields fts) + +appliesVar :: Type -> Bool +appliesVar = everything (||) (False `mkQ` chkApp) + where chkApp :: Type -> Bool + chkApp (AppT (VarT _) _) = True + chkApp t = False + +cName :: Type -> [Name] +cName (ConT nm) = [nm] +cName _ = [] + +deriveRep nm = case nameBase nm of +-- '(':cs -> deriveJavaRepTups [(length cs)] + _ -> deriveJavaRep nm + +predef nm = nm `elem` [''Char,''Int,''Float,''Double,''String,''[],''Bool {-,''Maybe -}] + +subst args t@(VarT nm) = maybe t id (lookup nm args) +subst args (AppT t0 t1) = AppT (subst args t0) (subst args t1) +subst args t = t + +firstDec :: Q [Dec] -> Q Dec +firstDec = liftM head + +collectReps names = do + allNames <- foldM go M.empty names >>= return . catMaybes . M.elems + let allFuncs = listE $ map (varE . mkName . ("jrep'" ++)) allNames + [| \ pkg -> concatMap (\ f -> f pkg) $allFuncs |] + where go m n = case M.lookup n m of + Just _ -> return m + Nothing -> reify n >>= \ info -> case info of + PrimTyConI _ _ _ -> return (M.insert n Nothing m) + TyConI (DataD _ nm _ cs _) -> case nameBase nm of + '(':rest -> return (M.insert nm (Just $ "Tuple" ++ show (length rest)) m) + _ -> foldM collectCReps (M.insert nm (Just $ nameBase nm) m) cs + TyConI (NewtypeD _ nm _ c _) -> collectCReps (M.insert nm (Just $ nameBase nm) m) c + TyConI (TySynD _ _ t1) -> decomposeType (M.insert n Nothing m) t1 + decomposeType m (VarT _) = return m + decomposeType m (TupleT n) = return m + decomposeType m ListT = return m + decomposeType m (ConT nm) | nm == ''Bool || + nm == ''Int || + nm == ''Char || + nm == ''[] || + -- nm == ''Maybe || + nm == ''Float || + nm == ''Double = return m + | otherwise = go m nm + decomposeType m (AppT x y) = decomposeType m x >>= flip decomposeType y + collectCReps m (NormalC _ sts) = foldM decomposeType m (map snd sts) + collectCReps m (RecC _ vsts) = foldM decomposeType m (map (\ (_,_,t) -> t) vsts) + collectCReps m (InfixC (_,t0) _ (_,t1)) = decomposeType m t0 >>= \ m' -> decomposeType m' t1 + +saveReps :: String -> [(String,String)] -> IO () +saveReps pkg codeInfo = do + mapM_ ( \ (nm,txt) -> writeFile (nm ++ ".java") txt) codeInfo + writeFile "InitAll.java" $ + "package " ++ pkg ++ ";\n" ++ + "import com.thoughtworks.xstream.XStream;\n" ++ + "public class InitAll {\n" ++ + " public static void initAll(XStream xstream) {\n" ++ + concatMap (\ (nm,_) -> " " ++ nm ++ ".init(xstream);\n") codeInfo ++ + " }\n" ++ + "}\n" + + + +concatNM = '(++) +concatV = varE concatNM + +specialNames = [(''[],"LinkedList"), + (''(,),"Tuple2"), + (''(,,),"Tuple3"), + (''(,,,),"Tuple4"), + (''(,,,,),"Tuple5"), + (''(,,,,,),"Tuple6"), + (''(,,,,,,),"Tuple7"), + (''Int,"Integer"), + (''Bool,"Boolean"), + (''Char,"Character"), + (''Int32,"Integer"), + (''Int64,"Long")] + +deriveName nm = case lookup nm specialNames of + Nothing -> nameBase nm + Just s -> s + +stringForms = [AppT ListT (ConT ''Char),AppT (ConT ''[]) (ConT ''Char)] + +hasList :: [Type] -> Bool +hasList = foldl (\ x y -> x || hasList' y) False + where hasList' (VarT _) = False + hasList' (ConT nm) | nm == ''[] = True + | otherwise = False + hasList' form@(AppT x y) | form `elem` stringForms = False + | otherwise = hasList' x || hasList' y + hasList' _ = False + +repT :: [(Name,String)] -> Int -> Type -> String +repT dict _ (ConT nm) = deriveName nm +repT dict _ (VarT nm) = maybe "?" id (lookup nm dict) +repT dict mult (AppT (ConT nm) y) | nm == ''[] && y == (ConT ''Char) = "String" + -- | nm == ''Maybe = repT dict mult y + | otherwise = (deriveName nm) ++ "<" ++ repT dict 0 y ++ (if mult /= 0 then "," else ">") +repT dict mult (AppT ListT y) = "LinkedList" ++ "<" ++ repT dict 0 y ++ ">" ++ (if mult == 0 then ">" else ",") +repT dict mult (AppT x y) = repT dict (mult + 1) x ++ repT dict 0 y ++ if mult == 0 then ">" else "," + +deSyn :: [Type] -> Type -> Q Type +deSyn targs t@(ConT nm) = reify nm >>= \ info -> case info of + PrimTyConI _ _ _ -> return (foldl AppT t targs) + TyConI (DataD _ _ _ _ _) -> return (foldl AppT t targs) + TyConI (NewtypeD _ _ _ _ _) -> return (foldl AppT t targs) + TyConI (TySynD _ params t1) -> return (foldl AppT (subst t1) targs') + where targs' = drop (length params) targs + substs = zip params targs + subst t@(VarT nm) = maybe t id (lookup nm substs) + subst (AppT x y) = (AppT (subst x) (subst y)) + subst t = t + other -> fail ("can't handle " ++ show (ppr other)) +deSyn targs (AppT x y) = do + arg <- deSyn [] y + deSyn (arg:targs) x +deSyn targs t@(VarT nm) = return $ foldl AppT t targs + +javaRepCon = conT ''JavaRep
+ src/Language/Lsl/Internal/SerializationInstances.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -XTemplateHaskell -XScopedTypeVariables #-} +module Language.Lsl.Internal.SerializationInstances where + +import Language.Lsl.Internal.SerializationGenerator + +$(deriveJavaRepTups [2..10]) + +$(deriveJavaRep ''Either) +$(deriveJavaRep ''Maybe) + +
src/Language/Lsl/Internal/Util.hs view
@@ -19,8 +19,12 @@ unescape, processLines, processLinesS, + processLinesSIO, generatePermutation, fac, + fst3, + snd3, + thd3, module Language.Lsl.Internal.Math ) where @@ -135,6 +139,15 @@ processLinesS newState term f where escape = escapeURIString isUnescapedInURI +processLinesSIO state term f = + do s <- getLine + when (term /= s) $ do + (newState,s') <- f state (unescape s) + putStrLn (escape s') + hFlush stdout + processLinesSIO newState term f + where escape = escapeURIString isUnescapedInURI + -- TODO: fix this definition! fac :: Integer -> Integer fac 0 = 1 @@ -159,3 +172,7 @@ (xs,y:ys) -> y : (generatePermutation (xs ++ ys) (i `mod` modulus)) _ -> error "" else error "no such permutation!!!" + +fst3 (x,_,_) = x +snd3 (_,y,_) = y +thd3 (_,_,z) = z
src/Language/Lsl/Parse.hs view
@@ -1,4 +1,8 @@+{-# OPTIONS_GHC -XDeriveDataTypeable #-} +{-# OPTIONS_GHC -XQuasiQuotes #-} module Language.Lsl.Parse( + alternateScriptParser, + alternateModuleParser, parseScript, parseModule, exprParser, @@ -6,11 +10,20 @@ parseScriptFromString, parseModuleFromString, parseScriptFromStringAQ, - parseModuleFromStringAQ + parseModuleFromStringAQ, + ParseError, + SourcePos, + errorMessages, + errorPos, + showErrorMessages, + sourceLine, + sourceColumn, + sourceName ) where import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 +import Data.Data import Data.Char(digitToInt) import Data.List(intersperse) import Language.Lsl.Internal.Pragmas(Pragma(..)) @@ -20,38 +33,64 @@ 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 Text.ParserCombinators.Parsec.Pos +import Text.Here import Debug.Trace data ParseState = ParseState { atStart :: !Bool, + initialComment :: !String, parseAntiQuotations :: !Bool, pendingPragmas :: ![Pragma], trailingWS :: !String, - leadingWS :: !String + leadingWS :: !String, + preWSPos :: !(Maybe SourcePos) } getAQState = getState >>= return . parseAntiQuotations -newAQState = ParseState { atStart = True, parseAntiQuotations = True, pendingPragmas = [], trailingWS = "", leadingWS = "" } -newNoAQState = ParseState { atStart = True, parseAntiQuotations = False, pendingPragmas = [], trailingWS = "", leadingWS = "" } +newAQState = ParseState { + atStart = True, + initialComment = "", + parseAntiQuotations = True, + pendingPragmas = [], + trailingWS = "", + leadingWS = "", + preWSPos = Nothing } +newNoAQState = ParseState { + atStart = True, + initialComment = "", + parseAntiQuotations = False, + pendingPragmas = [], + trailingWS = "", + leadingWS = "", + preWSPos = Nothing } data WS = WSSimple { wsText :: String } | WSSingle { wsText :: String } | WSMulti { wsText :: String } deriving Show + custWS simpleSpace oneLineComment multiLineComment = do + startPos <- getPosition 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 + let (initComment,leading') = if atStart st + then findInitialComment True [] leading + else (initialComment st, leading) setState st { atStart = False, + initialComment = initComment, pendingPragmas = pragmas, trailingWS = wsCat trailing, - leadingWS = wsCat leading } - where wsCat = concatMap wsText + leadingWS = wsCat leading', + preWSPos = Just startPos } + where wsCat = concatMap showWS + showWS (WSSimple txt) = txt + showWS (WSSingle txt) = "//" ++ txt + showWS (WSMulti txt) = "/*" ++ txt ++ "*/" extractTrailing [] = ([],[]) extractTrailing (WSSimple txt:rest) = case break (=='\n') txt of @@ -63,7 +102,14 @@ | otherwise = let (t,rest') = extractTrailing rest in (ws:t,rest') extractPragma ps (WSSingle txt) = maybe ps (:ps) (parsePragma txt) extractPragma ps _ = ps - + findInitialComment :: Bool -> [WS] -> [WS] -> (String,[WS]) + findInitialComment _ rleading [] = ("",reverse rleading) + findInitialComment onNewLine rleading (ws@(WSSimple txt):wss) + | null txt = findInitialComment onNewLine rleading wss + | (onNewLine && newlines txt > 0) || newlines txt > 1 = (wsCat (reverse (ws:rleading)), wss) + | otherwise = findInitialComment (last txt == '\n') (ws:rleading) wss + findInitialComment onNewLine rleading (ws:wss) = findInitialComment False (ws:rleading) wss + newlines s = length [ c | c <- s, c == '\n'] parsePragma :: String -> Maybe Pragma parsePragma txt = case parse parser "" txt of @@ -81,7 +127,15 @@ pragma <- (reserved "inline" >> return PragmaInline) <|> (reserved "noinlining" >> return PragmaNoInline) eof return pragma - + +getPreWSPos = getState >>= return . preWSPos + +-- get the position after the last non-whitespace character parsed so far +getEndPosition = getPreWSPos >>= maybe getPosition return + +getTrailingWS = getState >>= return . trailingWS +getLeadingWS = getState >>= return . leadingWS + -- define basic rules for lexical analysis lslStyle = javaStyle { P.reservedOpNames= ["*","/","+","++","-","--","^","&","&&", @@ -91,7 +145,7 @@ "while","for","do","jump","return","default", "$import", "$module","quaternion"], P.caseSensitive = True, P.identStart = letter <|> char '_', - P.opLetter = oneOf "*/+:!#$%&*+./=?@\\^|-~", + P.opLetter = oneOf "*/+:!#$%&*+/=?@\\^|-~", P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~", P.custWhiteSpace = Just custWS } lexer :: P.TokenParser ParseState @@ -133,18 +187,18 @@ decimalFraction w = do char '.' fracPart True w - + fracPart reqDigit w = do digits <- (if reqDigit then many1 else many) digit <?> "fractional part of decimal" p <- option 1.0 expon return $ p * (w + (foldr (\ b d -> (b + d) / 10.0) 0 $ map (fromIntegral.digitToInt) digits)) - + expon :: GenParser Char st Double expon = do oneOf "eE" s <- option '+' (oneOf "+-") let k x = if s == '+' then x else 1/x digits <- many1 digit <?> "exponent" let p = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt digits - return ((k (10^p))) + return (k (10^p)) hex = do oneOf "xX" digits <- many1 hexDigit <?> "hex digit" @@ -158,6 +212,7 @@ naturalOrFloat = do v <- natOrFloat <?> "number" whiteSpace return v + natOrFloat = (decimalFraction 0.0 >>= return . Right) <|> do char '0' option (Left 0) prefZeroNum @@ -166,6 +221,7 @@ prefZeroNum = (hex >>= return . Left) <|> (decimalFraction 0.0 >>= return . Right) <|> decimalOrFloat + decimalOrFloat = do wholeDigits <- many1 digit <?> "number" let w = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt wholeDigits @@ -301,32 +357,6 @@ exprs <- (brackets $ commaSep expr) <?> "list expression" return $ ListExpr exprs --- structExpr = do whiteSpace --- char '<' <?> "vector/rotation expression" --- whiteSpace --- e1 <- expr --- mtrace "structExpr:1 " e1 --- char ',' --- whiteSpace --- e2 <- expr --- mtrace "structExpr:2 " e2 --- char ',' --- whiteSpace --- e3 <- expr --- mtrace "structExpr:3 " e3 --- return (e1,e2,e3) --- vecRotExpr = do (x,y,z) <- structExpr --- mtrace "vec/rot" "hi" --- (do char '>' --- whiteSpace --- return $ VecExpr x y z) <|> --- (do char ',' --- whiteSpace --- e <- expr --- char '>' --- whiteSpace --- return $ RotExpr x y z e) - -- there's a conflict between a relational expression embedded in the last component of a vector/rotation and the -- the normal end of the expression... in particular: -- v = <1,1,1 > -<1,2,3>>; @@ -373,10 +403,12 @@ ctxify f = do pragmas <- getState >>= return . pendingPragmas + pre <- getLeadingWS pos0 <- getPosition v <- f - pos1 <- getPosition - return $ Ctx (pos2Ctx (pos0,pos1) pragmas) v + pos1 <- getEndPosition + post <- getTrailingWS + return $ Ctx (pos2Ctx (pos0,pos1) pre post pragmas) v notExpr = ctxify ((char '!' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Not) invExpr = ctxify ((char '~' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Inv) @@ -545,7 +577,8 @@ handlerName name = try (do id <- symbol name; notFollowedBy identLetter; return id) -handler' name types = do ctxname <- ctxify $ handlerName name +handler' name types = + ctxify $ do ctxname <- ctxify $ handlerName name parms <- parens (hparams types) stmts <- braces statements return $ Handler ctxname parms stmts @@ -557,28 +590,35 @@ stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier] -stateDecl = do name <- ctxify stateName - handlers <- braces $ many handler - return $ State name handlers +stateDecl = do ctxify $ do + name <- ctxify stateName + handlers <- braces $ many handler + return $ State name handlers stateDecls = many stateDecl -------------------------------------------------------------- varOrFunc = do pos0 <- getPosition + pre <- getLeadingWS pragmas <- getState >>= return . pendingPragmas (Ctx ctx (t,id)) <- ctxify $ do t <- try typeName id <- ctxify identifier <?> "identifier" return (t,id) - choice [func t id pragmas pos0, gvar ctx t id] + choice [func t id pragmas pos0 pre, gvar ctx t id] <|> do pos0 <- getPosition + pre <- getLeadingWS pragmas <- getState >>= return . pendingPragmas id <- ctxify identifier <?> "identifier" - func LLVoid id pragmas pos0 -func t id pragmas pos0 = do ps <- parens params + func LLVoid id pragmas pos0 pre +func t id pragmas pos0 pre = + do ps <- parens params stmts <- braces statements - pos1 <- getPosition - return $ GF $ Ctx (pos2Ctx (pos0, pos1) pragmas) $ Func (FuncDec id t ps) stmts + pos1 <- getEndPosition + post <- getTrailingWS + return $ GF $ Ctx (pos2Ctx (pos0, pos1) pre post pragmas) $ Func (FuncDec id t ps) stmts +--------------------------------------------------------------- +-- GLOBAL VARIABLES parsing gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp' "=" >> expr >>= return . Just) semi return $ GV (Ctx ctx (Var id t)) mexpr @@ -591,25 +631,6 @@ return $ Var id t params = commaSep param --- function = do (t,id,ps) <- try $ do t <- option LLVoid typeName <?> "type name" --- id <- ctxify identifier <?> "function name" --- ps <- parens params --- return (t,id,ps) --- stmts <- braces statements --- return $ GF $ Func (FuncDec id t ps) stmts ---------------------------------------------------------------- --- GLOBAL VARIABLES parsing - --- globals allow no initialization or initialization by 'constant' expressions... --- we can allow any expressions though and have semantic analysis catch problems - --- globvar = do var <- ctxify $ do --- t <- typeName <?> "type name" --- id <- identifier --- return (Var id t) --- mexpr <- option Nothing (reservedOp "=" >> expr >>= return.Just) --- semi --- return $ GV var mexpr ---------------------------------------------------------------- -- IMPORT (meta-lsl directive) parsing @@ -625,16 +646,17 @@ prefix <- option "" identifier semi return $ GI id bindings prefix ----------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- all globals parsing - -globals = many $ choice [gimport,varOrFunc] +global = choice [gimport,varOrFunc] +globals = many global lslParser = do whiteSpace globs <- globals ss <- stateDecls eof - return $ LSLScript globs ss + comment <- getState >>= return . initialComment + return $ LSLScript comment globs ss moduleParser = do whiteSpace reserved "$module" @@ -643,6 +665,133 @@ eof return $ LModule globs freevars +-- error recovering parser? +data PResult a = PResult { + resultInput :: !String, + resultPosition :: !SourcePos, + resultItem :: !a } + +-- stateInitial = do +-- name <- ctxify stateName +-- lexeme (char '{') +-- hs <- many $ try handler +-- return (State name hs) + +withRest a p = do + setPosition p + v <- a + st <- getParserState + return PResult { resultInput = stateInput st, resultPosition = statePos st, resultItem = v } + +-- parsePartialInitial = withRest $ do +-- whiteSpace +-- name <- ctxify stateName +-- lexeme (char '{') +-- hs <- many $ try handler +-- return (State name hs) +-- parse as many globals then states without failing +parseGreedy1 = withRest $ + (do try whiteSpace + gs <- many $ try global + ss <- many $ try stateDecl + return (gs,ss)) <|> return ([],[]) +-- parse one global or state +parseStrict1 = withRest $ + do whiteSpace + v <- choice [global >>= return . Left, stateDecl >>= return . Right] + return v +parsePartial = withRest $ + ctxify $ + do whiteSpace + name <- ctxify stateName + lexeme (char '{') + hs <- many $ try handler + return (State name hs) +parseResume = withRest $ ctxify ( + (do whiteSpace + hs <- many $ try handler + lexeme (char '}') + ss <- many $ try stateDecl + return (hs,ss)) <|> -- failed to find end of state + (do whiteSpace + s <- stateDecl + ss <- many $ try stateDecl + return ([],s:ss))) +parseGreedy2 = withRest $ + (do try whiteSpace + many $ try stateDecl) <|> return [] +parseStrict2 = withRest stateDecl + +alternateScriptParser srcName string = goGreedy1 False ([],[],[]) (initialPos "") string + where doParse p pos = runParser (p pos) newNoAQState srcName + goGreedy1 _ (gs,ss,errs) pos [] = (LSLScript "" gs ss, reverse errs) + goGreedy1 skipErr (gs,ss,errs) pos s = + case doParse parseGreedy1 pos s of + Left err -> error ("parseGreedy1 should never return an error, but returned: " ++ show err) + Right (PResult [] _ (gs',ss')) -> (LSLScript "" (gs ++ gs') (ss ++ ss'),errs) + Right (PResult rest pos' (gs',ss')) -> goStrict1 False (gs ++ gs',ss ++ ss',errs) pos' rest + goStrict1 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs) + goStrict1 skipErr (gs,ss,errs) pos s@(c:cs) = + case doParse parseStrict1 pos s of + Left err -> goPartial1 True (gs,ss,if skipErr then errs else err:errs) pos s + Right (PResult rest pos' (Left g)) -> goGreedy1 False (gs ++ [g],ss,errs) pos' rest + Right (PResult rest pos' (Right s)) -> goGreedy2 False (gs,ss ++ [s], errs) pos' rest + goPartial1 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs) + goPartial1 skipErr (gs,ss,errs) pos s@(c:cs) = + case doParse parsePartial pos s of + Left err -> goStrict1 True (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs + Right (PResult rest pos' state) -> goResume True state (gs,ss, errs) pos' rest + goResume skipErr state (gs,ss,errs) _ [] = (LSLScript "" gs (ss ++ [state]),reverse errs) + goResume skipErr state@(Ctx c0 (State nm hs)) (gs,ss,errs) pos s@(c:cs) = + case doParse parseResume pos s of + Left err -> goResume True state (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs + Right (PResult rest pos' (Ctx c1 (hs',ss'))) -> + goGreedy2 False (gs,ss ++ (Ctx (combineContexts1 c0 c1) (State nm (hs ++ hs')):ss'),errs) pos' rest + goGreedy2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs) + goGreedy2 skipErr (gs,ss,errs) pos s = + case doParse parseGreedy2 pos s of + Left err -> error ("parseGreedy2 parser should never return an error, but returned: " ++ show err) + Right (PResult [] _ ss') -> (LSLScript "" gs (ss ++ ss'),reverse errs) + Right (PResult rest pos' ss') -> goStrict2 True (gs,ss ++ ss',errs) pos' rest + goStrict2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs) + goStrict2 skipErr (gs,ss,errs) pos s@(c:cs) = + case doParse parseStrict2 pos s of + Left err -> goPartial2 True (gs,ss,if skipErr then errs else err:errs) pos s + Right (PResult rest pos' s) -> goGreedy2 False (gs,ss ++ [s],errs) pos rest + goPartial2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs) + goPartial2 skipErr (gs,ss,errs) pos s@(c:cs) = + case doParse parsePartial pos s of + Left err -> goStrict2 True (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs + Right (PResult rest pos' state) -> goResume True state (gs,ss,errs) pos' rest + +alternateModuleParser srcName string = goStart string + where doParse p pos = runParser (p pos) newNoAQState srcName + startPos = initialPos "" + goStart s = + case doParse parseStart startPos s of + Left err -> goStrict True ([],[],[err]) startPos s + Right (PResult rest pos freevars) -> goGreedy False (freevars,[],[]) pos rest + goGreedy _ (fv,gs,errs) _ [] = (LModule gs fv, errs) + goGreedy skip (fv,gs,errs) pos s = + case doParse parseGreedy pos s of + Left err -> error ("the greedy parser should never return an error, but returned: " ++ show err) + Right (PResult [] _ gs') -> (LModule (gs ++ gs') fv, reverse errs) + Right (PResult rest pos' gs') -> goStrict False (fv,gs ++ gs',errs) pos' rest + goStrict skip (fv,gs,errs) pos [] = (LModule gs fv, reverse errs) + goStrict skip (fv,gs,errs) pos s@(c:cs) = + case doParse parseStrict pos s of + Left err -> goStrict True (fv,gs,if skip then errs else err:errs) (updatePosChar pos c) cs + Right (PResult rest pos' gs') -> goGreedy False (fv,gs ++ [gs'], errs) pos' rest + parseGreedy = withRest $ many (try global) + parseStrict = withRest global + parseStart = withRest $ do + whiteSpace + reserved "$module" + option [] $ parens params + + +----------------------------------------------------------------------------- + parseFromString parser string = case runParser parser newNoAQState "" string of Left err -> Left (snd (fromParseError err)) @@ -662,7 +811,7 @@ parseModuleFromStringAQ :: String -> Either ParseError LModule parseModuleFromStringAQ s = runParser moduleParser newAQState "" s -parseModule :: (MonadIO m) => SourceName -> m (Either (Maybe SourceContext,String) LModule) +parseModule :: SourceName -> IO (Either (Maybe SourceContext,String) LModule) parseModule file = parseFile moduleParser file parseScript file = parseFile lslParser file @@ -678,28 +827,83 @@ msg) parseFile p file = - do s <- (liftIO $ B.readFile file) >>= return . UTF8.toString + do s <- 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 newNoAQState file -pos2Loc (pos0,pos1) = +pos2Loc (pos0,pos1) pre post = SourceContext TextLocation { textName = sourceName pos0, textColumn0 = sourceColumn pos0, textLine0 = sourceLine pos0, textColumn1 = sourceColumn pos1, textLine1 = sourceLine pos1 - } "" "" [] + } pre post [] -pos2Ctx (pos0,pos1) pragmas = Just (pos2Loc (pos0,pos1)) { srcPragmas = pragmas } +pos2Ctx (pos0,pos1) pre post pragmas = + Just (pos2Loc (pos0,pos1) "" "") { srcPreText = pre, srcPostTxt = post, 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 _ )) = +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 +combineContexts1 Nothing _ = Nothing +combineContexts1 _ Nothing = Nothing +combineContexts1 + (Just (SourceContext (TextLocation l0 c0 _ _ n) pre _ prag)) + (Just (SourceContext (TextLocation _ _ l1 c1 _) _ post _)) = + (Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag)) + +tst = [$here|@ + integer foo() { + return 1; + } + @ + default { + state_entry() { + } + } + |] + +tst1 = [$here| + integer foo() { + return 1; + } + + default { + @ + state_entry() { + } + } + |] + +tst2 = [$here| + @ + $module (integer x) + + integer foo() { + } + + |] + +tst3 = [$here| + integer foo() { + return 0; + } + + default { + state_entry() { + llOwnerSay(); + } + } + + state boo { + } + |]
src/Language/Lsl/Render.hs view
@@ -2,21 +2,23 @@ import Data.List(foldl',intersperse) import Language.Lsl.Syntax(Expr(..),Func(..),FuncDec(..),Global(..),Handler(..),State(..),Statement(..), - Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,CompiledLSLScript(..)) + Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,CompiledLSLScript(..), + SourceContext(..)) import Debug.Trace tr s x = trace (s ++ show x) x -- | Generate a string representing an LSL script from a timestamp (string) -- and a compiled (i.e. validated, with referenced modules included) LSL script. renderCompiledScript :: String -> CompiledLSLScript -> String -renderCompiledScript stamp (CompiledLSLScript globals funcs states) = +renderCompiledScript stamp (CompiledLSLScript comment globals funcs states) = (renderString "// LSL script generated: " . renderString stamp . renderString "\n" . + renderString comment . renderGlobals globals . renderFuncs funcs . renderStates states) "" renderSequence r = (foldl' (.) blank) . (map r) renderGlobals = renderSequence renderGlobal -renderGlobal (GDecl var val) = renderVar var . +renderGlobal (GDecl (Ctx sc var) val) = renderPreText sc . renderVar var . case val of Nothing -> renderString ";\n" Just expr -> renderString " = " . renderSimple expr . renderString ";\n" @@ -40,17 +42,19 @@ renderStates = renderSequence renderState -renderState (State (Ctx _ "default") handlers) = +renderState (Ctx ssc (State (Ctx sc "default") handlers)) = + renderPreText ssc . renderString "default {\n" . renderHandlers handlers . renderString "}\n" -renderState (State (Ctx _ name) handlers) = +renderState (Ctx ssc (State (Ctx _ name) handlers)) = + renderPreText ssc . renderString "state " . renderString name . renderString " {\n" . renderHandlers handlers . renderString "}\n" renderHandlers = renderSequence renderHandler -renderHandler (Handler (Ctx _ name) vars stmts) = renderHandler' name vars stmts +renderHandler (Ctx _ (Handler (Ctx sc name) vars stmts)) = renderPreText1 (renderIndent 0) sc . renderHandler' name vars stmts renderHandler' name vars stmts = - renderIndent 0 . renderString name . renderChar '(' . renderVarList (ctxItems vars) . renderString ") {\n" . + renderString name . renderChar '(' . renderVarList (ctxItems vars) . renderString ") {\n" . renderStatements 1 stmts . renderIndent 0 . renderString "}\n" renderChar = showChar @@ -193,11 +197,13 @@ renderExpression (ModBy va expr) = renderAssignment va "%=" expr renderExpression (Equal expr1 expr2) = renderBinExpr "==" expr1 expr2 renderExpression (NotEqual expr1 expr2) = renderBinExpr "!=" expr1 expr2 -renderExpression (PostInc va) = renderVarAccess va . renderString "++" -renderExpression (PostDec va) = renderVarAccess va . renderString "--" -renderExpression (PreInc va) = renderString "++" . renderVarAccess va -renderExpression (PreDec va) = renderString "--" . renderVarAccess va +renderExpression (PostInc va) = renderInParens (renderVarAccess va . renderString "++") +renderExpression (PostDec va) = renderInParens (renderVarAccess va . renderString "--") +renderExpression (PreInc va) = renderInParens (renderString "++" . renderVarAccess va) +renderExpression (PreDec va) = renderInParens (renderString "--" . renderVarAccess va) +renderInParens f = renderChar '(' . f . renderChar ')' + renderBinExpr op expr1 expr2 = renderChar '(' . renderCtxExpr expr1 . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr2 . renderChar ')' renderAssignment va op expr = @@ -222,3 +228,9 @@ blank :: String -> String blank = id + +renderPreText :: (Maybe SourceContext) -> String -> String +renderPreText = maybe blank (renderString . srcPreText) + +renderPreText1 :: (String -> String) -> (Maybe SourceContext) -> String -> String +renderPreText1 f = maybe f (renderString . srcPreText)
src/Language/Lsl/Syntax.hs view
@@ -74,7 +74,7 @@ --trace1 s v = trace (s ++ show v) v data TextLocation = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } - deriving (Show,Typeable,Data) + deriving (Show,Eq,Typeable,Data) data SourceContext = SourceContext { srcTextLocation :: TextLocation, srcPreText :: String, srcPostTxt :: String, srcPragmas :: [Pragma] } deriving (Show,Typeable,Data) @@ -197,7 +197,7 @@ -- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals -- for a script is derived after analyzing all included modules. -data Global = GDecl Var (Maybe Expr) +data Global = GDecl (Ctx Var) (Maybe Expr) deriving (Show,Typeable,Data) -- | A global definition (a function, a variable, or a module import statement). @@ -212,11 +212,11 @@ goodHandlers = simpleLslEventDescriptors -- | An LSL state definition. -data State = State CtxName [Handler] +data State = State CtxName [Ctx Handler] deriving (Show,Typeable,Data) -- | An LSL script. -data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) +data LSLScript = LSLScript String [GlobDef] [Ctx State] deriving (Show,Typeable,Data) type ModuleInfo = ([Global],[Ctx Func]) -- | A collection of modules. @@ -263,9 +263,10 @@ matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) data CompiledLSLScript = CompiledLSLScript { + scriptComment :: !String, scriptGlobals :: ![Global], scriptFuncs :: ![Ctx Func], - scriptStates :: ![State]} + scriptStates :: ![Ctx State]} deriving (Show) data RefPos = RefPos { refPosName :: !String, refPosLine :: !Int, refPosCol :: !Int } @@ -279,7 +280,7 @@ vsRefs :: !(M.Map RefPos SourceContext), vsLabels :: ![[String]], vsModules :: ![String], - vsStates :: ![State], + vsStates :: ![Ctx State], vsGlobals :: ![Global], vsFuncs :: ![Ctx Func], vsErr :: ![CodeErr], @@ -373,7 +374,7 @@ vsmAddGlobal :: Global -> VState () vsmAddGlobal global = get'vsGlobals >>= put'vsGlobals . (global :) -vsmAddState :: State -> VState () +vsmAddState :: Ctx State -> VState () vsmAddState state = get'vsStates >>= put'vsStates . (state :) vsmAddLocal :: Maybe SourceContext -> Var -> VState () @@ -486,7 +487,7 @@ warnLabelsMany = concatMap warnLabels warnLabelsStates = concatMap warnLabelsState - where warnLabelsState (State _ hs) = warnLabelsMany hs + where warnLabelsState (Ctx _ (State _ hs)) = warnLabelsMany hs warnLabels :: Data a => a -> [CodeErr] warnLabels x = map (\ (name,ctx) -> (ctx,"label " ++ name ++ " is already defined (problem for LSL/Mono)")) problems @@ -496,7 +497,7 @@ fstEq = flip ((==) . fst) . fst compileLSLScript :: LSLScript -> VState (Validity CompiledLSLScript) -compileLSLScript (LSLScript globs states) = do +compileLSLScript (LSLScript comment globs states) = do preprocessGlobDefs_ "" globs preprocessStates states mapM_ vsmAddGF predefFuncs @@ -510,11 +511,11 @@ states <- get'vsStates -- for now, error on label warnings since we have no warnings return $ case warnLabelsStates states ++ warnLabelsMany funcs of - [] -> Right $ CompiledLSLScript (reverse globals) (reverse funcs) (reverse states) + [] -> Right $ CompiledLSLScript comment (reverse globals) (reverse funcs) (reverse states) errs -> Left errs _ -> return $ Left $ reverse err -preprocessStates states = let snames = map (\ (State cn _) -> ctxItem cn) states in put'vsStateNames snames +preprocessStates states = let snames = map (\ (Ctx _ (State cn _)) -> ctxItem cn) states in put'vsStateNames snames preprocessGlobDefs :: String -> [GlobDef] -> VState ([Var],[FuncDec]) preprocessGlobDefs prefix globs = do @@ -548,7 +549,7 @@ whenJust mt $ \ t -> when (not (varType v' `matchTypes` t)) (vsmAddErr (srcCtx v, "expression not of the correct type")) vsmRegisterGlobal v vsmAddToNamesUsed (varName v') - vsmAddGlobal (GDecl v' (fmap ctxItem mexpr)) + vsmAddGlobal (GDecl v (fmap ctxItem mexpr)) compileGlob (GF cf@(Ctx ctx f@(Func (FuncDec name t params) statements))) = vsmWithNewScope $ do compileParams params @@ -595,7 +596,7 @@ namesUsed <- get'vsNamesUsed if name' `elem` namesUsed then vsmAddErr (ctx, name' ++ " imported from module is already defined") - else let rewrittenGlobVar = GDecl (Var name' t) (fmap (ctxItem . (rewriteCtxExpr renames)) mexpr) + else let rewrittenGlobVar = GDecl (nullCtx (Var name' t)) (fmap (ctxItem . (rewriteCtxExpr renames)) mexpr) in do vsmAddToNamesUsed name' vsmRegisterGlobal (Ctx ctx (Var name' t)) vsmAddGlobal rewrittenGlobVar @@ -619,16 +620,16 @@ Nothing -> vsmAddErr (ctx, rn ++ ": not found") >> return (fv,rn) Just rn' -> return (fv,rn') -compileState :: State -> VState () -compileState state@(State nm handlers) = +compileState :: Ctx State -> VState () +compileState state@(Ctx _ (State nm handlers)) = vsmWithinState $ do states <- get'vsStates - when (isJust (find (\ (State x _)-> ctxItem x == ctxItem nm) states)) $ + when (isJust (find (\ (Ctx _ (State x _))-> ctxItem x == ctxItem nm) states)) $ vsmAddErr (srcCtx nm, ctxItem nm ++ " already defined") mapM_ compileHandler handlers vsmAddState state -compileHandler (Handler (Ctx ctx name) args stmts) = +compileHandler (Ctx _ (Handler (Ctx ctx name) args stmts)) = vsmWithNewScope $ do used <- get'vsHandlersUsed if name `elem` used then vsmAddErr (ctx, name ++ " already used in this state") @@ -1295,9 +1296,9 @@ globDefsFromFuncs = map GF funcDefsFromStates = concatMap funcDefsFromState -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 $ nullCtx $ Func (FuncDec combinedName LLVoid params) stmts +globDefFromGlob (GDecl v me) = GV v (fmap nullCtx me) +funcDefsFromState (Ctx _ (State ctxnm handlers)) = map (funcDefFromHandler (ctxItem ctxnm)) handlers +funcDefFromHandler stateName (Ctx _ (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
src/Language/Lsl/UnitTestEnv.hs view
@@ -102,7 +102,7 @@ else fail ("unexpected call: " ++ renderCall n a) mkScript (LModule globdefs vars) = - LSLScript (varsToGlobdefs ++ globdefs) [L.State (nullCtx "default") []] + LSLScript "" (varsToGlobdefs ++ globdefs) [nullCtx $ L.State (nullCtx "default") []] where varsToGlobdefs = map (\ v -> GV v Nothing) vars getValidScript name =
src/LslPlus.hs view
@@ -6,18 +6,19 @@ import qualified Language.Lsl.Internal.SimMetaData as SimMetaData import qualified Language.Lsl.Internal.SystemTester as SystemTester import qualified Language.Lsl.Internal.UnitTester as UnitTester +import qualified Language.Lsl.Internal.CompilationServer as CompilationServer import Control.Monad import IO import System import System.Exit -version="0.3.6" +version="0.4.0" usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" main = do progName <- getProgName args <- getArgs - when (length args /= 1) $ do + when (length args < 1) $ do hPutStrLn stderr "Invalid number of command line arguments" hPutStrLn stderr (usage progName) exitFailure @@ -29,6 +30,11 @@ "SimMetaData" -> SimMetaData.printSimMeta "SystemTester" -> SystemTester.testSystem "UnitTester" -> UnitTester.main2 + "CompilationServer" -> CompilationServer.compilationServer + "_CodeGen_" -> case tail args of + [path,packageName] -> CompilationServer.codeGen path packageName + _ -> hPutStrLn stderr ("The super secret _CodeGen_ function " ++ + "requires that you supply a path and a package name for the generated Java code.") val -> do hPutStrLn stderr ("Invalid argument: " ++ val) hPutStrLn stderr (usage progName)
src/Text/Here.hs view
@@ -18,10 +18,14 @@ import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote(QuasiQuoter(..),dataToPatQ,dataToExpQ) +filt [] = [] +filt ('\r':'\n':cs) = '\n':filt cs +filt (c:cs) = c:filt cs + herePat :: String -> TH.Q TH.Pat -herePat s = dataToPatQ (const Nothing) s +herePat s = dataToPatQ (const Nothing) (filt s) hereExp :: String -> TH.Q TH.Exp -hereExp s = dataToExpQ (const Nothing) s +hereExp s = dataToExpQ (const Nothing) (filt s) -- | A quasi-quoter for a string... here :: QuasiQuoter