diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index bef46f3..343aa86 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -5,6 +5,8 @@ module Language.Wasm.Interpreter ( Value(..), + Store, + ModuleInstance, instantiate, invoke, invokeExport, diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index ddf8cc6..45726c4 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -29,7 +29,14 @@ module Language.Wasm.Parser ( Index(..), Ident(..), ParamType(..), - FuncType(..) + FuncType(..), + -- script + Script, + ModuleDef(..), + Command(..), + Action(..), + Assertion(..), + Meta(..) ) where import Language.Wasm.Structure ( @@ -323,7 +330,7 @@ name :: { TL.Text } : string { $1 } ident :: { Ident } - : id { Ident (TL.toStrict (TLEncoding.decodeUtf8 $1)) } + : id { Ident (TLEncoding.decodeUtf8 $1) } valtype :: { ValueType } : 'i32' { I32 } @@ -1017,8 +1024,8 @@ command1 :: { Command } | meta1 { Meta $1 } module1 :: { ModuleDef } - : 'module' opt(ident) 'binary' list(string) ')' { BinaryModDef $2 $4 } - | 'module' opt(ident) 'quote' list(string) ')' { TextModDef $2 $4 } + : 'module' opt(ident) 'binary' list(string) ')' { BinaryModDef $2 (TLEncoding.encodeUtf8 $ TL.concat $4) } + | 'module' opt(ident) 'quote' list(string) ')' { TextModDef $2 (TL.concat $4) } | 'module' opt(ident) list(modulefield) ')' { RawModDef $2 (desugarize $ concat $3) } | modulefield1 list(modulefield) { RawModDef Nothing (desugarize $ $1 ++ concat $2) } @@ -1141,7 +1148,7 @@ data ParamType = ParamType { paramType :: ValueType } deriving (Show, Eq) -newtype Ident = Ident T.Text deriving (Show, Eq) +newtype Ident = Ident TL.Text deriving (Show, Eq) data Index = Named Ident | Index Natural deriving (Show, Eq) @@ -1366,8 +1373,8 @@ type Expression = [Instruction] data ModuleDef = RawModDef (Maybe Ident) S.Module - | TextModDef (Maybe Ident) [TL.Text] - | BinaryModDef (Maybe Ident) [TL.Text] + | TextModDef (Maybe Ident) TL.Text + | BinaryModDef (Maybe Ident) LBS.ByteString deriving (Show, Eq) data Command diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs new file mode 100644 index 0000000..56b1cea --- /dev/null +++ b/src/Language/Wasm/Script.hs @@ -0,0 +1,70 @@ +module Language.Wasm.Script ( + runScript, + OnAssertFail +) where + +import qualified Data.Map as Map +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLEncoding + +import Language.Wasm.Parser ( + Ident(..), + Script, + ModuleDef(..), + Command(..), + Action(..), + Assertion(..), + Meta(..) + ) + +import qualified Language.Wasm.Interpreter as Interpreter +import qualified Language.Wasm.Validate as Validate +import qualified Language.Wasm.Structure as Struct +import qualified Language.Wasm.Parser as Parser +import qualified Language.Wasm.Lexer as Lexer +import qualified Language.Wasm.Binary as Binary + +type OnAssertFail = Assertion -> IO () + +data ScriptState = ScriptState { + store :: Interpreter.Store, + lastModule :: Maybe Interpreter.ModuleInstance, + modules :: Map.Map TL.Text Interpreter.ModuleInstance, + moduleRegistery :: Map.Map TL.Text Interpreter.ModuleInstance +} + +emptyState :: ScriptState +emptyState = ScriptState { + store = Interpreter.emptyStore, + lastModule = Nothing, + modules = Map.empty, + moduleRegistery = Map.empty +} + +runScript :: OnAssertFail -> Script -> IO () +runScript onAssertFail script = go script emptyState + where + go [] _ = return () + go (c:cs) st = runCommand st c >>= go cs + + addToRegistery :: Maybe Ident -> Interpreter.ModuleInstance -> ScriptState -> ScriptState + addToRegistery (Just (Ident ident)) m st = st { moduleRegistery = Map.insert ident m $ moduleRegistery st } + addToRegistery Nothing _ st = st + + addModule :: Maybe Ident -> Struct.Module -> ScriptState -> IO ScriptState + addModule ident m st = + case Validate.validate m of + Validate.Valid -> do + (modInst, store') <- Interpreter.instantiate (store st) Interpreter.emptyImports m + return $ addToRegistery ident modInst $ st { lastModule = Just modInst, store = store' } + reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason + + runCommand :: ScriptState -> Command -> IO ScriptState + runCommand st (ModuleDef (RawModDef ident m)) = addModule ident m st + runCommand st (ModuleDef (TextModDef ident textRep)) = + let Right m = Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) in + addModule ident m st + runCommand st (ModuleDef (BinaryModDef ident binaryRep)) = + let Right m = Binary.decodeModuleLazy binaryRep in + addModule ident m st + runCommand st _ = return st diff --git a/tests/Test.hs b/tests/Test.hs index bad3c76..c5051c7 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -16,6 +16,7 @@ import qualified Language.Wasm.Structure as Structure import qualified Language.Wasm.Binary as Binary import qualified Language.Wasm.Validate as Validate import qualified Language.Wasm.Interpreter as Interpreter +import qualified Language.Wasm.Script as Script import qualified Debug.Trace as Debug @@ -33,44 +34,9 @@ compile file = do main :: IO () main = do files <- Directory.listDirectory "tests/samples" - -- let files = ["call_indirect.wast"] - -- compile "fact.wast" - syntaxTestCases <- (`mapM` files) $ \file -> do + scriptTestCases <- (`mapM` files) $ \file -> do content <- LBS.readFile $ "tests/samples/" ++ file - let result = Parser.parseScript <$> Lexer.scanner content - return $ testCase ("Parse module from core Test Suit: " ++ file) $ - assertBool "Module parsed" $ isRight result - -- binaryTestCases <- (`mapM` files) $ \file -> do - -- content <- LBS.readFile $ "tests/samples/" ++ file - -- let Right mod = Parser.parseModule <$> Lexer.scanner content - -- let Right mod' = Binary.decodeModuleLazy $ Binary.dumpModuleLazy mod - -- return $ testCase ("Dump module to binary and parse back: " ++ file) $ - -- assertEqual "Module matched" mod mod' - -- validationTestCases <- (`mapM` files) $ \file -> do - -- content <- LBS.readFile $ "tests/samples/" ++ file - -- let Right mod = Parser.parseModule <$> Lexer.scanner content - -- return $ testCase ("Validate module: " ++ file) $ - -- case file of - -- "import.wast" -> - -- assertEqual "Too many tables" Validate.MoreThanOneTable $ Validate.validate mod - -- _ -> - -- assertBool "Module matched" $ Validate.isValid $ Validate.validate mod - -- interpretFactTestCases <- do - -- content <- LBS.readFile "tests/samples/fact.wast" - -- let Right mod = Parser.parseModule <$> Lexer.scanner content - -- (modInst, store) <- Interpreter.instantiate Interpreter.emptyStore Interpreter.emptyImports mod - -- (`mapM` ["fac-rec", "fac-rec-named", "fac-iter", "fac-iter-named", "fac-opt"]) $ \fn -> do - -- let fac = \n -> Interpreter.invokeExport store modInst fn [Interpreter.VI64 n] - -- fac3 <- fac 3 - -- fac5 <- fac 5 - -- fac8 <- fac 8 - -- return $ testCase ("Interprete " ++ show fn) $ do - -- assertEqual "Fact 3! == 6" [Interpreter.VI64 6] fac3 - -- assertEqual "Fact 5! == 120" [Interpreter.VI64 120] fac5 - -- assertEqual "Fact 8! == 40320" [Interpreter.VI64 40320] fac8 - defaultMain $ testGroup "tests" [ - testGroup "Syntax parsing" syntaxTestCases - -- testGroup "Binary format" binaryTestCases, - -- testGroup "Validation" validationTestCases, - -- testGroup "Interpretation" interpretFactTestCases - ] + let Right script = Parser.parseScript <$> Lexer.scanner content + return $ testCase file $ do + Script.runScript (assertFailure . ("Failed assert: " ++) . show) script + defaultMain $ testGroup "Wasm Core Test Suit" scriptTestCases diff --git a/wasm.cabal b/wasm.cabal index ccf4761..0ed91c5 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -41,6 +41,7 @@ library Language.Wasm.Binary Language.Wasm.Validate Language.Wasm.Interpreter + Language.Wasm.Script Language.Wasm other-modules: Paths_wasm