{-# LANGUAGE OverloadedStrings #-}
module Language.Wasm.Script (
    runScript,
    OnAssertFail
) where

import qualified Data.Map as Map
import qualified Data.Vector as Vector
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLEncoding
import qualified Control.Monad.State as State
import Control.Monad.IO.Class (liftIO)
import Numeric.IEEE (identicalIEEE)
import qualified Control.DeepSeq as DeepSeq
import Data.Maybe (fromJust, isNothing)

import Language.Wasm.Parser (
        Ident(..),
        Script,
        ModuleDef(..),
        Command(..),
        Action(..),
        Assertion(..)
    )

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 = String -> Assertion -> IO ()

data ScriptState = ScriptState {
    ScriptState -> Store
store :: Interpreter.Store,
    ScriptState -> Maybe ModuleInstance
lastModule :: Maybe Interpreter.ModuleInstance,
    ScriptState -> Map Text ModuleInstance
modules :: Map.Map TL.Text Interpreter.ModuleInstance,
    ScriptState -> Map Text ModuleInstance
moduleRegistery :: Map.Map TL.Text Interpreter.ModuleInstance
}

emptyState :: ScriptState
emptyState :: ScriptState
emptyState = ScriptState :: Store
-> Maybe ModuleInstance
-> Map Text ModuleInstance
-> Map Text ModuleInstance
-> ScriptState
ScriptState {
    store :: Store
store = Store
Interpreter.emptyStore,
    lastModule :: Maybe ModuleInstance
lastModule = Maybe ModuleInstance
forall a. Maybe a
Nothing,
    modules :: Map Text ModuleInstance
modules = Map Text ModuleInstance
forall k a. Map k a
Map.empty,
    moduleRegistery :: Map Text ModuleInstance
moduleRegistery = Map Text ModuleInstance
forall k a. Map k a
Map.empty
}

type AssertM = State.StateT (ScriptState, String) IO

runScript :: OnAssertFail -> Script -> IO ()
runScript :: OnAssertFail -> Script -> IO ()
runScript OnAssertFail
onAssertFail Script
script = do
    (HostItem
globI32, HostItem
globI64, HostItem
globF32, HostItem
globF64) <- IO (HostItem, HostItem, HostItem, HostItem)
hostGlobals
    (Store
st, ModuleInstance
inst) <- Store -> [(Text, HostItem)] -> IO (Store, ModuleInstance)
Interpreter.makeHostModule Store
Interpreter.emptyStore [
            (Text
"print", ParamsType -> HostItem
hostPrint []),
            (Text
"print_i32", ParamsType -> HostItem
hostPrint [ValueType
Struct.I32]),
            (Text
"print_i32_f32", ParamsType -> HostItem
hostPrint [ValueType
Struct.I32, ValueType
Struct.F32]),
            (Text
"print_f64_f64", ParamsType -> HostItem
hostPrint [ValueType
Struct.F64, ValueType
Struct.F64]),
            (Text
"print_f32", ParamsType -> HostItem
hostPrint [ValueType
Struct.F32]),
            (Text
"print_f64", ParamsType -> HostItem
hostPrint [ValueType
Struct.F64]),
            (Text
"global_i32", HostItem
globI32),
            (Text
"global_i64", HostItem
globI64),
            (Text
"global_f32", HostItem
globF32),
            (Text
"global_f64", HostItem
globF64),
            (Text
"memory", Limit -> HostItem
Interpreter.HostMemory (Limit -> HostItem) -> Limit -> HostItem
forall a b. (a -> b) -> a -> b
$ Natural -> Maybe Natural -> Limit
Struct.Limit Natural
1 (Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
2)),
            (Text
"table", Limit -> HostItem
Interpreter.HostTable (Limit -> HostItem) -> Limit -> HostItem
forall a b. (a -> b) -> a -> b
$ Natural -> Maybe Natural -> Limit
Struct.Limit Natural
10 (Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
20))
        ]
    Script -> ScriptState -> IO ()
go Script
script (ScriptState -> IO ()) -> ScriptState -> IO ()
forall a b. (a -> b) -> a -> b
$ ScriptState
emptyState { store :: Store
store = Store
st, moduleRegistery :: Map Text ModuleInstance
moduleRegistery = Text -> ModuleInstance -> Map Text ModuleInstance
forall k a. k -> a -> Map k a
Map.singleton Text
"spectest" ModuleInstance
inst }
    where
        hostPrint :: ParamsType -> HostItem
hostPrint ParamsType
paramTypes = FuncType -> HostFunction -> HostItem
Interpreter.HostFunction (ParamsType -> ParamsType -> FuncType
Struct.FuncType ParamsType
paramTypes []) (\[Value]
args -> HostFunction
forall (m :: * -> *) a. Monad m => a -> m a
return [])
        hostGlobals :: IO (HostItem, HostItem, HostItem, HostItem)
hostGlobals = do
            let globI32 :: GlobalInstance
globI32 = Value -> GlobalInstance
Interpreter.makeConstGlobal (Value -> GlobalInstance) -> Value -> GlobalInstance
forall a b. (a -> b) -> a -> b
$ Word32 -> Value
Interpreter.VI32 Word32
666
            let globI64 :: GlobalInstance
globI64 = Value -> GlobalInstance
Interpreter.makeConstGlobal (Value -> GlobalInstance) -> Value -> GlobalInstance
forall a b. (a -> b) -> a -> b
$ Word64 -> Value
Interpreter.VI64 Word64
666
            let globF32 :: GlobalInstance
globF32 = Value -> GlobalInstance
Interpreter.makeConstGlobal (Value -> GlobalInstance) -> Value -> GlobalInstance
forall a b. (a -> b) -> a -> b
$ Float -> Value
Interpreter.VF32 Float
666
            let globF64 :: GlobalInstance
globF64 = Value -> GlobalInstance
Interpreter.makeConstGlobal (Value -> GlobalInstance) -> Value -> GlobalInstance
forall a b. (a -> b) -> a -> b
$ Double -> Value
Interpreter.VF64 Double
666
            (HostItem, HostItem, HostItem, HostItem)
-> IO (HostItem, HostItem, HostItem, HostItem)
forall (m :: * -> *) a. Monad m => a -> m a
return (
                    GlobalInstance -> HostItem
Interpreter.HostGlobal GlobalInstance
globI32,
                    GlobalInstance -> HostItem
Interpreter.HostGlobal GlobalInstance
globI64,
                    GlobalInstance -> HostItem
Interpreter.HostGlobal GlobalInstance
globF32,
                    GlobalInstance -> HostItem
Interpreter.HostGlobal GlobalInstance
globF64
                )

        go :: Script -> ScriptState -> IO ()
go [] ScriptState
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go (Command
c:Script
cs) ScriptState
st = ScriptState -> Command -> IO ScriptState
runCommand ScriptState
st Command
c IO ScriptState -> (ScriptState -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Script -> ScriptState -> IO ()
go Script
cs
        
        addToRegistery :: TL.Text -> Maybe Ident -> ScriptState -> ScriptState
        addToRegistery :: Text -> Maybe Ident -> ScriptState -> ScriptState
addToRegistery Text
name Maybe Ident
i ScriptState
st =
            case ScriptState -> Maybe Ident -> Maybe ModuleInstance
getModule ScriptState
st Maybe Ident
i of
                Just ModuleInstance
m -> ScriptState
st { moduleRegistery :: Map Text ModuleInstance
moduleRegistery = Text
-> ModuleInstance
-> Map Text ModuleInstance
-> Map Text ModuleInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name ModuleInstance
m (Map Text ModuleInstance -> Map Text ModuleInstance)
-> Map Text ModuleInstance -> Map Text ModuleInstance
forall a b. (a -> b) -> a -> b
$ ScriptState -> Map Text ModuleInstance
moduleRegistery ScriptState
st }
                Maybe ModuleInstance
Nothing -> [Char] -> ScriptState
forall a. HasCallStack => [Char] -> a
error ([Char] -> ScriptState) -> [Char] -> ScriptState
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot register module with identifier '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Ident -> [Char]
forall a. Show a => a -> [Char]
show Maybe Ident
i  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'. No such module"

        addToStore :: Maybe Ident -> Interpreter.ModuleInstance -> ScriptState -> ScriptState
        addToStore :: Maybe Ident -> ModuleInstance -> ScriptState -> ScriptState
addToStore (Just (Ident Text
ident)) ModuleInstance
m ScriptState
st = ScriptState
st { modules :: Map Text ModuleInstance
modules = Text
-> ModuleInstance
-> Map Text ModuleInstance
-> Map Text ModuleInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
ident ModuleInstance
m (Map Text ModuleInstance -> Map Text ModuleInstance)
-> Map Text ModuleInstance -> Map Text ModuleInstance
forall a b. (a -> b) -> a -> b
$ ScriptState -> Map Text ModuleInstance
modules ScriptState
st }
        addToStore Maybe Ident
Nothing ModuleInstance
_ ScriptState
st = ScriptState
st

        buildImports :: ScriptState -> Interpreter.Imports
        buildImports :: ScriptState -> Imports
buildImports ScriptState
st =
            [((Text, Text), ExternalValue)] -> Imports
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Text, Text), ExternalValue)] -> Imports)
-> [((Text, Text), ExternalValue)] -> Imports
forall a b. (a -> b) -> a -> b
$ [[((Text, Text), ExternalValue)]]
-> [((Text, Text), ExternalValue)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[((Text, Text), ExternalValue)]]
 -> [((Text, Text), ExternalValue)])
-> [[((Text, Text), ExternalValue)]]
-> [((Text, Text), ExternalValue)]
forall a b. (a -> b) -> a -> b
$ ((Text, ModuleInstance) -> [((Text, Text), ExternalValue)])
-> [(Text, ModuleInstance)] -> [[((Text, Text), ExternalValue)]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, ModuleInstance) -> [((Text, Text), ExternalValue)]
toImports ([(Text, ModuleInstance)] -> [[((Text, Text), ExternalValue)]])
-> [(Text, ModuleInstance)] -> [[((Text, Text), ExternalValue)]]
forall a b. (a -> b) -> a -> b
$ Map Text ModuleInstance -> [(Text, ModuleInstance)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text ModuleInstance -> [(Text, ModuleInstance)])
-> Map Text ModuleInstance -> [(Text, ModuleInstance)]
forall a b. (a -> b) -> a -> b
$ ScriptState -> Map Text ModuleInstance
moduleRegistery ScriptState
st
            where
                toImports :: (TL.Text, Interpreter.ModuleInstance) -> [((TL.Text, TL.Text), Interpreter.ExternalValue)]
                toImports :: (Text, ModuleInstance) -> [((Text, Text), ExternalValue)]
toImports (Text
modName, ModuleInstance
mod) = (ExportInstance -> ((Text, Text), ExternalValue))
-> [ExportInstance] -> [((Text, Text), ExternalValue)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ExportInstance -> ((Text, Text), ExternalValue)
asImport Text
modName) ([ExportInstance] -> [((Text, Text), ExternalValue)])
-> [ExportInstance] -> [((Text, Text), ExternalValue)]
forall a b. (a -> b) -> a -> b
$ Vector ExportInstance -> [ExportInstance]
forall a. Vector a -> [a]
Vector.toList (Vector ExportInstance -> [ExportInstance])
-> Vector ExportInstance -> [ExportInstance]
forall a b. (a -> b) -> a -> b
$ ModuleInstance -> Vector ExportInstance
Interpreter.exports ModuleInstance
mod
                asImport :: TL.Text -> Interpreter.ExportInstance -> ((TL.Text, TL.Text), Interpreter.ExternalValue)
                asImport :: Text -> ExportInstance -> ((Text, Text), ExternalValue)
asImport Text
modName (Interpreter.ExportInstance Text
name ExternalValue
val) = ((Text
modName, Text
name), ExternalValue
val)

        addModule :: Maybe Ident -> Struct.Module -> ScriptState -> IO ScriptState
        addModule :: Maybe Ident -> Module -> ScriptState -> IO ScriptState
addModule Maybe Ident
ident Module
m ScriptState
st =
            case Module -> Either ValidationError ValidModule
Validate.validate Module
m of
                Right ValidModule
m -> do
                    (Either [Char] ModuleInstance
res, Store
store') <- Store
-> Imports
-> ValidModule
-> IO (Either [Char] ModuleInstance, Store)
Interpreter.instantiate (ScriptState -> Store
store ScriptState
st) (ScriptState -> Imports
buildImports ScriptState
st) ValidModule
m
                    case Either [Char] ModuleInstance
res of
                        Right ModuleInstance
modInst -> ScriptState -> IO ScriptState
forall (m :: * -> *) a. Monad m => a -> m a
return (ScriptState -> IO ScriptState) -> ScriptState -> IO ScriptState
forall a b. (a -> b) -> a -> b
$ Maybe Ident -> ModuleInstance -> ScriptState -> ScriptState
addToStore Maybe Ident
ident ModuleInstance
modInst (ScriptState -> ScriptState) -> ScriptState -> ScriptState
forall a b. (a -> b) -> a -> b
$ ScriptState
st { lastModule :: Maybe ModuleInstance
lastModule = ModuleInstance -> Maybe ModuleInstance
forall a. a -> Maybe a
Just ModuleInstance
modInst, store :: Store
store = Store
store' }
                        Left [Char]
reason -> [Char] -> IO ScriptState
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ScriptState) -> [Char] -> IO ScriptState
forall a b. (a -> b) -> a -> b
$ [Char]
"Module instantiation failed due to invalid module with reason: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
reason
                Left ValidationError
reason -> [Char] -> IO ScriptState
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ScriptState) -> [Char] -> IO ScriptState
forall a b. (a -> b) -> a -> b
$ [Char]
"Module instantiation failed due to invalid module with reason: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ValidationError -> [Char]
forall a. Show a => a -> [Char]
show ValidationError
reason
        
        getModule :: ScriptState -> Maybe Ident -> Maybe Interpreter.ModuleInstance
        getModule :: ScriptState -> Maybe Ident -> Maybe ModuleInstance
getModule ScriptState
st (Just (Ident Text
i)) = Text -> Map Text ModuleInstance -> Maybe ModuleInstance
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
i (ScriptState -> Map Text ModuleInstance
modules ScriptState
st)
        getModule ScriptState
st Maybe Ident
Nothing = ScriptState -> Maybe ModuleInstance
lastModule ScriptState
st

        asArg :: Struct.Expression -> Interpreter.Value
        asArg :: Expression -> Value
asArg [Struct.I32Const Word32
v] = Word32 -> Value
Interpreter.VI32 Word32
v
        asArg [Struct.F32Const Float
v] = Float -> Value
Interpreter.VF32 Float
v
        asArg [Struct.I64Const Word64
v] = Word64 -> Value
Interpreter.VI64 Word64
v
        asArg [Struct.F64Const Double
v] = Double -> Value
Interpreter.VF64 Double
v
        asArg Expression
_                   = [Char] -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"Only const instructions supported as arguments for actions"

        runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
        runAction :: ScriptState -> Action -> IO (Maybe [Value])
runAction ScriptState
st (Invoke Maybe Ident
ident Text
name [Expression]
args) = do
            case ScriptState -> Maybe Ident -> Maybe ModuleInstance
getModule ScriptState
st Maybe Ident
ident of
                Just ModuleInstance
m -> Store -> ModuleInstance -> Text -> [Value] -> IO (Maybe [Value])
Interpreter.invokeExport (ScriptState -> Store
store ScriptState
st) ModuleInstance
m Text
name ([Value] -> IO (Maybe [Value])) -> [Value] -> IO (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ (Expression -> Value) -> [Expression] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Value
asArg [Expression]
args
                Maybe ModuleInstance
Nothing -> [Char] -> IO (Maybe [Value])
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe [Value])) -> [Char] -> IO (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot invoke function on module with identifier '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Ident -> [Char]
forall a. Show a => a -> [Char]
show Maybe Ident
ident  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'. No such module"
        runAction ScriptState
st (Get Maybe Ident
ident Text
name) = do
            case ScriptState -> Maybe Ident -> Maybe ModuleInstance
getModule ScriptState
st Maybe Ident
ident of
                Just ModuleInstance
m -> Store -> ModuleInstance -> Text -> IO Value
Interpreter.getGlobalValueByName (ScriptState -> Store
store ScriptState
st) ModuleInstance
m Text
name IO Value -> (Value -> IO (Maybe [Value])) -> IO (Maybe [Value])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe [Value] -> IO (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> IO (Maybe [Value]))
-> (Value -> Maybe [Value]) -> Value -> IO (Maybe [Value])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value])
-> (Value -> [Value]) -> Value -> Maybe [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [])
                Maybe ModuleInstance
Nothing -> [Char] -> IO (Maybe [Value])
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe [Value])) -> [Char] -> IO (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot invoke function on module with identifier '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Ident -> [Char]
forall a. Show a => a -> [Char]
show Maybe Ident
ident  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'. No such module"

        isValueEqual :: Interpreter.Value -> Interpreter.Value -> Bool
        isValueEqual :: Value -> Value -> Bool
isValueEqual (Interpreter.VI32 Word32
v1) (Interpreter.VI32 Word32
v2) = Word32
v1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
v2
        isValueEqual (Interpreter.VI64 Word64
v1) (Interpreter.VI64 Word64
v2) = Word64
v1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v2
        isValueEqual (Interpreter.VF32 Float
v1) (Interpreter.VF32 Float
v2) = (Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v1 Bool -> Bool -> Bool
&& Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v2) Bool -> Bool -> Bool
|| Float -> Float -> Bool
forall a. IEEE a => a -> a -> Bool
identicalIEEE Float
v1 Float
v2
        isValueEqual (Interpreter.VF64 Double
v1) (Interpreter.VF64 Double
v2) = (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v1 Bool -> Bool -> Bool
&& Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v2) Bool -> Bool -> Bool
|| Double -> Double -> Bool
forall a. IEEE a => a -> a -> Bool
identicalIEEE Double
v1 Double
v2
        isValueEqual Value
_ Value
_ = Bool
False

        isNaNReturned :: Action -> Assertion -> AssertM ()
        isNaNReturned :: Action -> Assertion -> AssertM ()
isNaNReturned Action
action Assertion
assert = do
            Maybe [Value]
result <- Action -> AssertM (Maybe [Value])
runActionInAssert Action
action
            case Maybe [Value]
result of
                Just [Interpreter.VF32 Float
v] ->
                    if Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v
                    then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected NaN, but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Float -> [Char]
forall a. Show a => a -> [Char]
show Float
v) Assertion
assert
                Just [Interpreter.VF64 Double
v] ->
                    if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v
                    then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected NaN, but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
v) Assertion
assert
                Maybe [Value]
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected NaN, but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Value] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [Value]
result) Assertion
assert
        
        buildModule :: ModuleDef -> (Maybe Ident, Struct.Module)
        buildModule :: ModuleDef -> (Maybe Ident, Module)
buildModule (RawModDef Maybe Ident
ident Module
m) = (Maybe Ident
ident, Module
m)
        buildModule (TextModDef Maybe Ident
ident Text
textRep) =
            let Right Module
m = ByteString -> Either [Char] [Lexeme]
Lexer.scanner (Text -> ByteString
TLEncoding.encodeUtf8 Text
textRep) Either [Char] [Lexeme]
-> ([Lexeme] -> Either [Char] Module) -> Either [Char] Module
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Lexeme] -> Either [Char] Module
Parser.parseModule in
            (Maybe Ident
ident, Module
m)
        buildModule (BinaryModDef Maybe Ident
ident ByteString
binaryRep) =
            let Right Module
m = ByteString -> Either [Char] Module
Binary.decodeModuleLazy ByteString
binaryRep in
            (Maybe Ident
ident, Module
m)

        checkModuleInvalid :: Struct.Module -> IO ()
        checkModuleInvalid :: Module -> IO ()
checkModuleInvalid Module
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        getFailureString :: Validate.ValidationError -> [TL.Text]
        getFailureString :: ValidationError -> [Text]
getFailureString (Validate.TypeMismatch Arrow
_ Arrow
_) = [Text
"type mismatch"]
        getFailureString ValidationError
Validate.ResultTypeDoesntMatch = [Text
"type mismatch"]
        getFailureString ValidationError
Validate.MoreThanOneMemory = [Text
"multiple memories"]
        getFailureString ValidationError
Validate.MoreThanOneTable = [Text
"multiple tables"]
        getFailureString (Validate.LocalIndexOutOfRange Natural
idx) = [Text
"unknown local", Text
"unknown local " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
TL.pack (Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
idx)]
        getFailureString (Validate.MemoryIndexOutOfRange Natural
idx) = [Text
"unknown memory", Text
"unknown memory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
TL.pack (Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
idx)]
        getFailureString (Validate.TableIndexOutOfRange Natural
idx) = [Text
"unknown table", Text
"unknown table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
TL.pack (Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
idx)]
        getFailureString ValidationError
Validate.FunctionIndexOutOfRange = [Text
"unknown function", Text
"unknown function 0"]
        getFailureString (Validate.GlobalIndexOutOfRange Natural
idx) = [Text
"unknown global", Text
"unknown global " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
TL.pack (Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
idx)]
        getFailureString ValidationError
Validate.LabelIndexOutOfRange = [Text
"unknown label"]
        getFailureString ValidationError
Validate.TypeIndexOutOfRange = [Text
"unknown type"]
        getFailureString ValidationError
Validate.MinMoreThanMaxInMemoryLimit = [Text
"size minimum must not be greater than maximum"]
        getFailureString ValidationError
Validate.MemoryLimitExceeded = [Text
"memory size must be at most 65536 pages (4GiB)"]
        getFailureString ValidationError
Validate.AlignmentOverflow = [Text
"alignment", Text
"alignment must not be larger than natural"]
        getFailureString (Validate.DuplicatedExportNames [[Char]]
_) = [Text
"duplicate export name"]
        getFailureString ValidationError
Validate.InvalidConstantExpr = [Text
"constant expression required"]
        getFailureString ValidationError
Validate.InvalidResultArity = [Text
"invalid result arity"]
        getFailureString ValidationError
Validate.GlobalIsImmutable = [Text
"global is immutable"]
        getFailureString ValidationError
Validate.InvalidStartFunctionType = [Text
"start function"]
        getFailureString ValidationError
Validate.InvalidTableType = [Text
"size minimum must not be greater than maximum"]
        getFailureString ValidationError
r = [[Text] -> Text
TL.concat [Text
"not implemented ", ([Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ValidationError -> [Char]
forall a. Show a => a -> [Char]
show ValidationError
r)]]

        printFailedAssert :: String -> Assertion -> AssertM ()
        printFailedAssert :: [Char] -> Assertion -> AssertM ()
printFailedAssert [Char]
msg Assertion
assert = do
            (ScriptState
_, [Char]
pos) <- StateT (ScriptState, [Char]) IO (ScriptState, [Char])
forall s (m :: * -> *). MonadState s m => m s
State.get
            IO () -> AssertM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AssertM ()) -> IO () -> AssertM ()
forall a b. (a -> b) -> a -> b
$ OnAssertFail
onAssertFail ([Char]
pos [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg) Assertion
assert

        runActionInAssert :: Action -> AssertM (Maybe [Interpreter.Value])
        runActionInAssert :: Action -> AssertM (Maybe [Value])
runActionInAssert Action
action = do
            (ScriptState
st, [Char]
_) <- StateT (ScriptState, [Char]) IO (ScriptState, [Char])
forall s (m :: * -> *). MonadState s m => m s
State.get
            IO (Maybe [Value]) -> AssertM (Maybe [Value])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Value]) -> AssertM (Maybe [Value]))
-> IO (Maybe [Value]) -> AssertM (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ ScriptState -> Action -> IO (Maybe [Value])
runAction ScriptState
st Action
action

        runAssert :: Assertion -> AssertM ()
        runAssert :: Assertion -> AssertM ()
runAssert assert :: Assertion
assert@(AssertReturn Action
action [Expression]
expected) = do
            (ScriptState
st, [Char]
_) <- StateT (ScriptState, [Char]) IO (ScriptState, [Char])
forall s (m :: * -> *). MonadState s m => m s
State.get
            Maybe [Value]
result <- Action -> AssertM (Maybe [Value])
runActionInAssert Action
action
            case Maybe [Value]
result of
                Just [Value]
result -> do
                    if [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
result Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expression] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression]
expected Bool -> Bool -> Bool
&& ((Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Bool) -> [Value] -> [Value] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> Bool
isValueEqual [Value]
result ((Expression -> Value) -> [Expression] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Value
asArg [Expression]
expected))
                    then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show ((Expression -> Value) -> [Expression] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Value
asArg [Expression]
expected) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show [Value]
result) Assertion
assert
                Maybe [Value]
Nothing -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show ((Expression -> Value) -> [Expression] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Value
asArg [Expression]
expected) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but action returned Trap") Assertion
assert
        runAssert assert :: Assertion
assert@(AssertReturnCanonicalNaN Action
action) = Action -> Assertion -> AssertM ()
isNaNReturned Action
action Assertion
assert
        runAssert assert :: Assertion
assert@(AssertReturnArithmeticNaN Action
action) = Action -> Assertion -> AssertM ()
isNaNReturned Action
action Assertion
assert
        runAssert assert :: Assertion
assert@(AssertInvalid ModuleDef
moduleDef Text
failureString) =
            let (Maybe Ident
_, Module
m) = ModuleDef -> (Maybe Ident, Module)
buildModule ModuleDef
moduleDef in
            case Module -> Either ValidationError ValidModule
Validate.validate Module
m of
                Right ValidModule
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert [Char]
"An invalid module passed validation step" Assertion
assert
                Left ValidationError
reason ->
                    if Text
failureString Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ValidationError -> [Text]
getFailureString ValidationError
reason
                    then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else
                        let msg :: [Char]
msg = [Char]
"Module is invalid for other reason. Expected "
                                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
failureString
                                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but actual is "
                                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show (ValidationError -> [Text]
getFailureString ValidationError
reason)
                        in [Char] -> Assertion -> AssertM ()
printFailedAssert [Char]
msg Assertion
assert
        runAssert assert :: Assertion
assert@(AssertMalformed (TextModDef Maybe Ident
_ Text
textRep) Text
failureString) =
            case Either [Char] Module -> Either [Char] Module
forall a. NFData a => a -> a
DeepSeq.force (Either [Char] Module -> Either [Char] Module)
-> Either [Char] Module -> Either [Char] Module
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] [Lexeme]
Lexer.scanner (Text -> ByteString
TLEncoding.encodeUtf8 Text
textRep) Either [Char] [Lexeme]
-> ([Lexeme] -> Either [Char] Module) -> Either [Char] Module
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Lexeme] -> Either [Char] Module
Parser.parseModule of
                Right Module
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Module parsing should fail with failure string " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
failureString) Assertion
assert
                Left [Char]
_ -> () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        runAssert assert :: Assertion
assert@(AssertMalformed (BinaryModDef Maybe Ident
ident ByteString
binaryRep) Text
failureString) =
            case ByteString -> Either [Char] Module
Binary.decodeModuleLazy ByteString
binaryRep of
                Right Module
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Module decoding should fail with failure string " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
failureString) Assertion
assert
                Left [Char]
_ -> () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        runAssert assert :: Assertion
assert@(AssertMalformed (RawModDef Maybe Ident
_ Module
_) Text
failureString) = () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        runAssert assert :: Assertion
assert@(AssertUnlinkable ModuleDef
moduleDef Text
failureString) =
            let (Maybe Ident
_, Module
m) = ModuleDef -> (Maybe Ident, Module)
buildModule ModuleDef
moduleDef in
            case Module -> Either ValidationError ValidModule
Validate.validate Module
m of
                Right ValidModule
m -> do
                    ScriptState
st <- (ScriptState, [Char]) -> ScriptState
forall a b. (a, b) -> a
fst ((ScriptState, [Char]) -> ScriptState)
-> StateT (ScriptState, [Char]) IO (ScriptState, [Char])
-> StateT (ScriptState, [Char]) IO ScriptState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (ScriptState, [Char]) IO (ScriptState, [Char])
forall s (m :: * -> *). MonadState s m => m s
State.get
                    (Either [Char] ModuleInstance
res, Store
_) <- IO (Either [Char] ModuleInstance, Store)
-> StateT
     (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] ModuleInstance, Store)
 -> StateT
      (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store))
-> IO (Either [Char] ModuleInstance, Store)
-> StateT
     (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store)
forall a b. (a -> b) -> a -> b
$ Store
-> Imports
-> ValidModule
-> IO (Either [Char] ModuleInstance, Store)
Interpreter.instantiate (ScriptState -> Store
store ScriptState
st) (ScriptState -> Imports
buildImports ScriptState
st) ValidModule
m
                    case Either [Char] ModuleInstance
res of
                        Left [Char]
err -> () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Right ModuleInstance
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Module linking should fail with failure string " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
failureString) Assertion
assert
                Left ValidationError
reason -> [Char] -> AssertM ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> AssertM ()) -> [Char] -> AssertM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Module linking failed due to invalid module with reason: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ValidationError -> [Char]
forall a. Show a => a -> [Char]
show ValidationError
reason
        runAssert assert :: Assertion
assert@(AssertTrap (Left Action
action) Text
failureString) = do
            Maybe [Value]
result <- Action -> AssertM (Maybe [Value])
runActionInAssert Action
action
            if Maybe [Value] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [Value]
result
            then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected trap, but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show (Maybe [Value] -> [Value]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Value]
result)) Assertion
assert
        runAssert assert :: Assertion
assert@(AssertTrap (Right ModuleDef
moduleDef) Text
failureString) =
            let (Maybe Ident
_, Module
m) = ModuleDef -> (Maybe Ident, Module)
buildModule ModuleDef
moduleDef in
            case Module -> Either ValidationError ValidModule
Validate.validate Module
m of
                Right ValidModule
m -> do
                    ScriptState
st <- (ScriptState, [Char]) -> ScriptState
forall a b. (a, b) -> a
fst ((ScriptState, [Char]) -> ScriptState)
-> StateT (ScriptState, [Char]) IO (ScriptState, [Char])
-> StateT (ScriptState, [Char]) IO ScriptState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (ScriptState, [Char]) IO (ScriptState, [Char])
forall s (m :: * -> *). MonadState s m => m s
State.get
                    (Either [Char] ModuleInstance
res, Store
store') <- IO (Either [Char] ModuleInstance, Store)
-> StateT
     (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] ModuleInstance, Store)
 -> StateT
      (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store))
-> IO (Either [Char] ModuleInstance, Store)
-> StateT
     (ScriptState, [Char]) IO (Either [Char] ModuleInstance, Store)
forall a b. (a -> b) -> a -> b
$ Store
-> Imports
-> ValidModule
-> IO (Either [Char] ModuleInstance, Store)
Interpreter.instantiate (ScriptState -> Store
store ScriptState
st) (ScriptState -> Imports
buildImports ScriptState
st) ValidModule
m
                    case Either [Char] ModuleInstance
res of
                        Left [Char]
"Start function terminated with trap" ->
                            ((ScriptState, [Char]) -> (ScriptState, [Char])) -> AssertM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (((ScriptState, [Char]) -> (ScriptState, [Char])) -> AssertM ())
-> ((ScriptState, [Char]) -> (ScriptState, [Char])) -> AssertM ()
forall a b. (a -> b) -> a -> b
$ \(ScriptState
st, [Char]
pos) -> (ScriptState
st { store :: Store
store = Store
store' }, [Char]
pos)
                        Either [Char] ModuleInstance
_ -> [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Module linking should fail with trap during execution of a start function") Assertion
assert
                Left ValidationError
reason -> [Char] -> AssertM ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> AssertM ()) -> [Char] -> AssertM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Module linking failed due to invalid module with reason: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ValidationError -> [Char]
forall a. Show a => a -> [Char]
show ValidationError
reason
        runAssert assert :: Assertion
assert@(AssertExhaustion Action
action Text
failureString) = do
            Maybe [Value]
result <- Action -> AssertM (Maybe [Value])
runActionInAssert Action
action
            if Maybe [Value] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [Value]
result
            then () -> AssertM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else [Char] -> Assertion -> AssertM ()
printFailedAssert ([Char]
"Expected exhaustion, but action returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show (Maybe [Value] -> [Value]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Value]
result)) Assertion
assert

        runCommand :: ScriptState -> Command -> IO ScriptState
        runCommand :: ScriptState -> Command -> IO ScriptState
runCommand ScriptState
st (ModuleDef ModuleDef
moduleDef) =
            let (Maybe Ident
ident, Module
m) = ModuleDef -> (Maybe Ident, Module)
buildModule ModuleDef
moduleDef in
            Maybe Ident -> Module -> ScriptState -> IO ScriptState
addModule Maybe Ident
ident Module
m ScriptState
st
        runCommand ScriptState
st (Register Text
name Maybe Ident
i) = ScriptState -> IO ScriptState
forall (m :: * -> *) a. Monad m => a -> m a
return (ScriptState -> IO ScriptState) -> ScriptState -> IO ScriptState
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Ident -> ScriptState -> ScriptState
addToRegistery Text
name Maybe Ident
i ScriptState
st
        runCommand ScriptState
st (Action Action
action) = ScriptState -> Action -> IO (Maybe [Value])
runAction ScriptState
st Action
action IO (Maybe [Value]) -> IO ScriptState -> IO ScriptState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScriptState -> IO ScriptState
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptState
st
        runCommand ScriptState
st (Assertion Int
pos Assertion
assertion) = do
            (ScriptState, [Char]) -> ScriptState
forall a b. (a, b) -> a
fst ((ScriptState, [Char]) -> ScriptState)
-> IO (ScriptState, [Char]) -> IO ScriptState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AssertM () -> (ScriptState, [Char]) -> IO (ScriptState, [Char]))
-> (ScriptState, [Char]) -> AssertM () -> IO (ScriptState, [Char])
forall a b c. (a -> b -> c) -> b -> a -> c
flip AssertM () -> (ScriptState, [Char]) -> IO (ScriptState, [Char])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT (ScriptState
st, ([Char]
"Line " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
pos)) (Assertion -> AssertM ()
runAssert Assertion
assertion)
        runCommand ScriptState
st Command
_ = ScriptState -> IO ScriptState
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptState
st