{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}

module Language.Wasm.Validate (
    ValidationError(..),
    ValidationResult(..),
    validate,
    isValid,
    ValidModule,
    getModule
) where

import Language.Wasm.Structure
import qualified Data.Set as Set
import Data.List (foldl')
import qualified Data.Text.Lazy as TL
import Data.Maybe (fromMaybe, maybeToList, catMaybes)
import Numeric.Natural (Natural)
import Prelude hiding ((<>))

import Control.Monad (foldM)
import Control.Monad.Reader (ReaderT, runReaderT, withReaderT, ask)
import Control.Monad.Except (Except, runExcept, throwError)

import Debug.Trace as Debug

data ValidationError =
    DuplicatedExportNames [String]
    | InvalidTableType
    | MinMoreThanMaxInMemoryLimit
    | MemoryLimitExceeded
    | AlignmentOverflow
    | MoreThanOneMemory
    | MoreThanOneTable
    | FunctionIndexOutOfRange
    | TableIndexOutOfRange Natural
    | MemoryIndexOutOfRange Natural
    | LocalIndexOutOfRange Natural
    | GlobalIndexOutOfRange Natural
    | LabelIndexOutOfRange
    | TypeIndexOutOfRange
    | ResultTypeDoesntMatch
    | TypeMismatch { ValidationError -> Arrow
actual :: Arrow, ValidationError -> Arrow
expected :: Arrow }
    | InvalidResultArity
    | InvalidConstantExpr
    | InvalidStartFunctionType
    | GlobalIsImmutable
    deriving (Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationError] -> ShowS
$cshowList :: [ValidationError] -> ShowS
show :: ValidationError -> String
$cshow :: ValidationError -> String
showsPrec :: Int -> ValidationError -> ShowS
$cshowsPrec :: Int -> ValidationError -> ShowS
Show, ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c== :: ValidationError -> ValidationError -> Bool
Eq)

type ValidationResult = Either ValidationError ()

-- semigroup definition for Either a b is in conflict with my ad-hoc instance
-- to keep an old code Prelude version is hidden and redefined locally
<> :: ValidationResult -> ValidationResult -> ValidationResult
(<>) = ValidationResult -> ValidationResult -> ValidationResult
forall a. Monoid a => a -> a -> a
mappend

instance Monoid ValidationResult where
    mempty :: ValidationResult
mempty = () -> ValidationResult
forall a b. b -> Either a b
Right ()
    mappend :: ValidationResult -> ValidationResult -> ValidationResult
mappend (Right ()) ValidationResult
vr = ValidationResult
vr
    mappend ValidationResult
vr (Right ()) = ValidationResult
vr
    mappend ValidationResult
vr ValidationResult
_ = ValidationResult
vr

isValid :: ValidationResult -> Bool
isValid :: ValidationResult -> Bool
isValid (Right ()) = Bool
True
isValid (Left ValidationError
reason) = String -> Bool -> Bool
forall a. String -> a -> a
Debug.trace (String
"Module mismatched with reason " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValidationError -> String
forall a. Show a => a -> String
show ValidationError
reason) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
False

type Validator = Module -> ValidationResult

data VType =
    Val ValueType
    | Var
    | Any
    deriving (Int -> VType -> ShowS
[VType] -> ShowS
VType -> String
(Int -> VType -> ShowS)
-> (VType -> String) -> ([VType] -> ShowS) -> Show VType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VType] -> ShowS
$cshowList :: [VType] -> ShowS
show :: VType -> String
$cshow :: VType -> String
showsPrec :: Int -> VType -> ShowS
$cshowsPrec :: Int -> VType -> ShowS
Show, VType -> VType -> Bool
(VType -> VType -> Bool) -> (VType -> VType -> Bool) -> Eq VType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VType -> VType -> Bool
$c/= :: VType -> VType -> Bool
== :: VType -> VType -> Bool
$c== :: VType -> VType -> Bool
Eq)

type End = [VType]

empty :: [ValueType]
empty :: [ValueType]
empty = []

class ToEnd a where
    toEnd :: a -> [VType]

instance ToEnd VType where
    toEnd :: VType -> [VType]
toEnd VType
val = [VType
val]

instance ToEnd ValueType where
    toEnd :: ValueType -> [VType]
toEnd ValueType
val = [ValueType -> VType
Val ValueType
val]

instance ToEnd [ValueType] where
    toEnd :: [ValueType] -> [VType]
toEnd = (ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val

instance ToEnd [VType] where
    toEnd :: [VType] -> [VType]
toEnd = [VType] -> [VType]
forall a. a -> a
id

data Arrow = Arrow End End deriving (Int -> Arrow -> ShowS
[Arrow] -> ShowS
Arrow -> String
(Int -> Arrow -> ShowS)
-> (Arrow -> String) -> ([Arrow] -> ShowS) -> Show Arrow
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arrow] -> ShowS
$cshowList :: [Arrow] -> ShowS
show :: Arrow -> String
$cshow :: Arrow -> String
showsPrec :: Int -> Arrow -> ShowS
$cshowsPrec :: Int -> Arrow -> ShowS
Show, Arrow -> Arrow -> Bool
(Arrow -> Arrow -> Bool) -> (Arrow -> Arrow -> Bool) -> Eq Arrow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arrow -> Arrow -> Bool
$c/= :: Arrow -> Arrow -> Bool
== :: Arrow -> Arrow -> Bool
$c== :: Arrow -> Arrow -> Bool
Eq)

(==>) :: (ToEnd a, ToEnd b) => a -> b -> Arrow
==> :: a -> b -> Arrow
(==>) a
a b
b = [VType] -> [VType] -> Arrow
Arrow (a -> [VType]
forall a. ToEnd a => a -> [VType]
toEnd a
a) (b -> [VType]
forall a. ToEnd a => a -> [VType]
toEnd b
b)

asArrow :: FuncType -> Arrow
asArrow :: FuncType -> Arrow
asArrow (FuncType [ValueType]
params [ValueType]
results) = [VType] -> [VType] -> Arrow
Arrow ((ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val [ValueType]
params) ((ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val ([ValueType] -> [VType]) -> [ValueType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [ValueType] -> [ValueType]
forall a. [a] -> [a]
reverse [ValueType]
results)

isArrowMatch :: Arrow -> Arrow -> Bool
isArrowMatch :: Arrow -> Arrow -> Bool
isArrowMatch ([VType]
f `Arrow` [VType]
t) ( [VType]
f' `Arrow` [VType]
t') = [VType] -> [VType] -> Bool
isEndMatch [VType]
f [VType]
f' Bool -> Bool -> Bool
&& [VType] -> [VType] -> Bool
isEndMatch [VType]
t [VType]
t'
    where
        isEndMatch :: End -> End -> Bool
        isEndMatch :: [VType] -> [VType] -> Bool
isEndMatch (VType
Any:[VType]
l) (VType
Any:[VType]
r) =
            let ([VType]
leftTail, [VType]
rightTail) = [(VType, VType)] -> ([VType], [VType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(VType, VType)] -> ([VType], [VType]))
-> [(VType, VType)] -> ([VType], [VType])
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType] -> [(VType, VType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
l) ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
r) in
            [VType] -> [VType] -> Bool
isEndMatch ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
leftTail) ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
rightTail)
        isEndMatch (VType
Any:[VType]
l) [VType]
r =
            let ([VType]
leftTail, [VType]
rightTail) = [(VType, VType)] -> ([VType], [VType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(VType, VType)] -> ([VType], [VType]))
-> [(VType, VType)] -> ([VType], [VType])
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType] -> [(VType, VType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
l) ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
r) in
            [VType] -> [VType] -> Bool
isEndMatch ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
leftTail) ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
rightTail)
        isEndMatch [VType]
l (VType
Any:[VType]
r) =
            let ([VType]
leftTail, [VType]
rightTail) = [(VType, VType)] -> ([VType], [VType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(VType, VType)] -> ([VType], [VType]))
-> [(VType, VType)] -> ([VType], [VType])
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType] -> [(VType, VType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
l) ((VType -> Bool) -> [VType] -> [VType]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (VType -> VType -> Bool
forall a. Eq a => a -> a -> Bool
/= VType
Any) ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ [VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
r) in
            [VType] -> [VType] -> Bool
isEndMatch ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
leftTail) ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
rightTail)
        isEndMatch (VType
Var:[VType]
l) (VType
x:[VType]
r) =
            let subst :: [VType] -> [VType]
subst = VType -> VType -> [VType] -> [VType]
forall a. Eq a => a -> a -> [a] -> [a]
replace VType
Var VType
x in
            [VType] -> [VType] -> Bool
isEndMatch ([VType] -> [VType]
subst [VType]
l) ([VType] -> [VType]
subst [VType]
r)
        isEndMatch (VType
x:[VType]
l) (VType
Var:[VType]
r) =
            let subst :: [VType] -> [VType]
subst = VType -> VType -> [VType] -> [VType]
forall a. Eq a => a -> a -> [a] -> [a]
replace VType
Var VType
x in
            [VType] -> [VType] -> Bool
isEndMatch ([VType] -> [VType]
subst [VType]
l) ([VType] -> [VType]
subst [VType]
r)
        isEndMatch (Val ValueType
v:[VType]
l) (Val ValueType
v':[VType]
r) = ValueType
v ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
v' Bool -> Bool -> Bool
&& [VType] -> [VType] -> Bool
isEndMatch [VType]
l [VType]
r
        isEndMatch [] [] = Bool
True
        isEndMatch [VType]
_ [VType]
_ = Bool
False

data Ctx = Ctx {
    Ctx -> [FuncType]
types :: [FuncType],
    Ctx -> [FuncType]
funcs :: [FuncType],
    Ctx -> [TableType]
tables :: [TableType],
    Ctx -> [Limit]
mems :: [Limit],
    Ctx -> [GlobalType]
globals :: [GlobalType],
    Ctx -> [ValueType]
locals :: [ValueType],
    Ctx -> [[ValueType]]
labels :: [[ValueType]],
    Ctx -> [ValueType]
returns :: [ValueType],
    Ctx -> Natural
importedGlobals :: Natural
} deriving (Int -> Ctx -> ShowS
[Ctx] -> ShowS
Ctx -> String
(Int -> Ctx -> ShowS)
-> (Ctx -> String) -> ([Ctx] -> ShowS) -> Show Ctx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ctx] -> ShowS
$cshowList :: [Ctx] -> ShowS
show :: Ctx -> String
$cshow :: Ctx -> String
showsPrec :: Int -> Ctx -> ShowS
$cshowsPrec :: Int -> Ctx -> ShowS
Show, Ctx -> Ctx -> Bool
(Ctx -> Ctx -> Bool) -> (Ctx -> Ctx -> Bool) -> Eq Ctx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ctx -> Ctx -> Bool
$c/= :: Ctx -> Ctx -> Bool
== :: Ctx -> Ctx -> Bool
$c== :: Ctx -> Ctx -> Bool
Eq)

type Checker = ReaderT Ctx (Except ValidationError)

freshVar :: Checker VType
freshVar :: Checker VType
freshVar = VType -> Checker VType
forall (m :: * -> *) a. Monad m => a -> m a
return VType
Var

runChecker :: Ctx -> Checker a -> Either ValidationError a
runChecker :: Ctx -> Checker a -> Either ValidationError a
runChecker Ctx
ctx = Except ValidationError a -> Either ValidationError a
forall e a. Except e a -> Either e a
runExcept (Except ValidationError a -> Either ValidationError a)
-> (Checker a -> Except ValidationError a)
-> Checker a
-> Either ValidationError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Checker a -> Ctx -> Except ValidationError a)
-> Ctx -> Checker a -> Except ValidationError a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Checker a -> Ctx -> Except ValidationError a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Ctx
ctx

(!?) :: [a] -> Natural -> Maybe a
!? :: [a] -> Natural -> Maybe a
(!?) (a
x:[a]
_) Natural
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
(!?) (a
_:[a]
rest) Natural
n = [a]
rest [a] -> Natural -> Maybe a
forall a. [a] -> Natural -> Maybe a
!? (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1)
(!?) [] Natural
_ = Maybe a
forall a. Maybe a
Nothing

safeHead :: [a] -> Maybe a
safeHead :: [a] -> Maybe a
safeHead (a
x: [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
safeHead [] = Maybe a
forall a. Maybe a
Nothing

maybeToEither :: ValidationError -> Maybe a -> Checker a
maybeToEither :: ValidationError -> Maybe a -> Checker a
maybeToEither ValidationError
_ (Just a
a) = a -> Checker a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
maybeToEither ValidationError
l Maybe a
Nothing = ValidationError -> Checker a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
l

asType :: GlobalType -> VType
asType :: GlobalType -> VType
asType (Const ValueType
v) = ValueType -> VType
Val ValueType
v
asType (Mut ValueType
v) = ValueType -> VType
Val ValueType
v

shouldBeMut :: GlobalType -> Checker ()
shouldBeMut :: GlobalType -> Checker ()
shouldBeMut (Mut ValueType
_) = () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
shouldBeMut (Const ValueType
v) = ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
GlobalIsImmutable

getLabel :: LabelIndex -> Checker [ValueType]
getLabel :: Natural -> Checker [ValueType]
getLabel Natural
lbl = do
    Ctx { [[ValueType]]
labels :: [[ValueType]]
$sel:labels:Ctx :: Ctx -> [[ValueType]]
labels } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    case [[ValueType]]
labels [[ValueType]] -> Natural -> Maybe [ValueType]
forall a. [a] -> Natural -> Maybe a
!? Natural
lbl of
        Maybe [ValueType]
Nothing -> ValidationError -> Checker [ValueType]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
LabelIndexOutOfRange
        Just [ValueType]
v -> [ValueType] -> Checker [ValueType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ValueType]
v

withLabel :: [ValueType] -> Checker a -> Checker a
withLabel :: [ValueType] -> Checker a -> Checker a
withLabel [ValueType]
result = (Ctx -> Ctx) -> Checker a -> Checker a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\Ctx
ctx -> Ctx
ctx { $sel:labels:Ctx :: [[ValueType]]
labels = [ValueType]
result [ValueType] -> [[ValueType]] -> [[ValueType]]
forall a. a -> [a] -> [a]
: Ctx -> [[ValueType]]
labels Ctx
ctx })

isMemArgValid :: Int -> MemArg -> Checker ()
isMemArgValid :: Int -> MemArg -> Checker ()
isMemArgValid Int
sizeInBytes MemArg { Natural
$sel:align:MemArg :: MemArg -> Natural
align :: Natural
align } = if Int
2 Int -> Natural -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Natural
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sizeInBytes then () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
AlignmentOverflow

checkMemoryInstr :: Int -> MemArg -> Checker ()
checkMemoryInstr :: Int -> MemArg -> Checker ()
checkMemoryInstr Int
size MemArg
memarg = do
    Int -> MemArg -> Checker ()
isMemArgValid Int
size MemArg
memarg
    Ctx { [Limit]
mems :: [Limit]
$sel:mems:Ctx :: Ctx -> [Limit]
mems } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask 
    if [Limit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Limit]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 then ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> ValidationError
MemoryIndexOutOfRange Natural
0) else () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getBlockType :: BlockType -> Checker Arrow
getBlockType :: BlockType -> Checker Arrow
getBlockType (Inline Maybe ValueType
Nothing) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getBlockType (Inline (Just ValueType
valType)) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
valType
getBlockType (TypeIndex Natural
typeIdx) = do
    Ctx { [FuncType]
types :: [FuncType]
$sel:types:Ctx :: Ctx -> [FuncType]
types } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValidationError -> Maybe Arrow -> Checker Arrow
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither ValidationError
TypeIndexOutOfRange (Maybe Arrow -> Checker Arrow) -> Maybe Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ FuncType -> Arrow
asArrow (FuncType -> Arrow) -> Maybe FuncType -> Maybe Arrow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FuncType]
types [FuncType] -> Natural -> Maybe FuncType
forall a. [a] -> Natural -> Maybe a
!? Natural
typeIdx

getResultType :: BlockType -> Checker [ValueType]
getResultType :: BlockType -> Checker [ValueType]
getResultType (Inline Maybe ValueType
Nothing) = [ValueType] -> Checker [ValueType]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getResultType (Inline (Just ValueType
valType)) = [ValueType] -> Checker [ValueType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ValueType
valType]
getResultType (TypeIndex Natural
typeIdx) = do
    Ctx { [FuncType]
types :: [FuncType]
$sel:types:Ctx :: Ctx -> [FuncType]
types } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValidationError -> Maybe [ValueType] -> Checker [ValueType]
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither ValidationError
TypeIndexOutOfRange (Maybe [ValueType] -> Checker [ValueType])
-> Maybe [ValueType] -> Checker [ValueType]
forall a b. (a -> b) -> a -> b
$ FuncType -> [ValueType]
results (FuncType -> [ValueType]) -> Maybe FuncType -> Maybe [ValueType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FuncType]
types [FuncType] -> Natural -> Maybe FuncType
forall a. [a] -> Natural -> Maybe a
!? Natural
typeIdx

getInstrType :: Instruction Natural -> Checker Arrow
getInstrType :: Instruction Natural -> Checker Arrow
getInstrType Instruction Natural
Unreachable = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ VType
Any VType -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
Any
getInstrType Instruction Natural
Nop = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType Block { BlockType
$sel:blockType:Unreachable :: forall index. Instruction index -> BlockType
blockType :: BlockType
blockType, Expression
$sel:body:Unreachable :: forall index. Instruction index -> Expression
body :: Expression
body } = do
    bt :: Arrow
bt@(Arrow [VType]
from [VType]
_) <- BlockType -> Checker Arrow
getBlockType BlockType
blockType
    [ValueType]
resultType <- BlockType -> Checker [ValueType]
getResultType BlockType
blockType
    Arrow
t <- [ValueType] -> Checker Arrow -> Checker Arrow
forall a. [ValueType] -> Checker a -> Checker a
withLabel [ValueType]
resultType (Checker Arrow -> Checker Arrow) -> Checker Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput [VType]
from Expression
body
    if Arrow -> Arrow -> Bool
isArrowMatch Arrow
t Arrow
bt
    then Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return Arrow
bt
    else ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker Arrow)
-> ValidationError -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
t Arrow
bt
getInstrType Loop { BlockType
blockType :: BlockType
$sel:blockType:Unreachable :: forall index. Instruction index -> BlockType
blockType, Expression
body :: Expression
$sel:body:Unreachable :: forall index. Instruction index -> Expression
body } = do
    bt :: Arrow
bt@(Arrow [VType]
from [VType]
_) <- BlockType -> Checker Arrow
getBlockType BlockType
blockType
    [ValueType]
resultType <- BlockType -> Checker [ValueType]
getResultType BlockType
blockType
    Arrow
t <- [ValueType] -> Checker Arrow -> Checker Arrow
forall a. [ValueType] -> Checker a -> Checker a
withLabel ((VType -> ValueType) -> [VType] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Val ValueType
v) -> ValueType
v) [VType]
from) (Checker Arrow -> Checker Arrow) -> Checker Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput [VType]
from Expression
body
    if Arrow -> Arrow -> Bool
isArrowMatch Arrow
t Arrow
bt
    then Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return Arrow
bt
    else ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker Arrow)
-> ValidationError -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
t Arrow
bt
getInstrType If { BlockType
blockType :: BlockType
$sel:blockType:Unreachable :: forall index. Instruction index -> BlockType
blockType, Expression
$sel:true:Unreachable :: forall index. Instruction index -> Expression
true :: Expression
true, Expression
$sel:false:Unreachable :: forall index. Instruction index -> Expression
false :: Expression
false } = do
    bt :: Arrow
bt@(Arrow [VType]
from [VType]
_) <- BlockType -> Checker Arrow
getBlockType BlockType
blockType
    [ValueType]
resultType <- BlockType -> Checker [ValueType]
getResultType BlockType
blockType
    Arrow
l <- [ValueType] -> Checker Arrow -> Checker Arrow
forall a. [ValueType] -> Checker a -> Checker a
withLabel [ValueType]
resultType (Checker Arrow -> Checker Arrow) -> Checker Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput [VType]
from Expression
true
    Arrow
r <- [ValueType] -> Checker Arrow -> Checker Arrow
forall a. [ValueType] -> Checker a -> Checker a
withLabel [ValueType]
resultType (Checker Arrow -> Checker Arrow) -> Checker Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput [VType]
from Expression
false
    if Arrow -> Arrow -> Bool
isArrowMatch Arrow
l Arrow
bt
    then (
            if Arrow -> Arrow -> Bool
isArrowMatch Arrow
r Arrow
bt
            then let Arrow [VType]
from [VType]
to = Arrow
bt in
                (Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ([VType]
from [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [ValueType -> VType
Val ValueType
I32]) [VType] -> [VType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [VType]
to)
            else (ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker Arrow)
-> ValidationError -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
r Arrow
bt)
        )
    else ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker Arrow)
-> ValidationError -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
l Arrow
bt
getInstrType (Br Natural
lbl) = do
    [VType]
r <- (ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val ([ValueType] -> [VType])
-> Checker [ValueType]
-> ReaderT Ctx (Except ValidationError) [VType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Checker [ValueType]
getLabel Natural
lbl
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ (VType
Any VType -> [VType] -> [VType]
forall a. a -> [a] -> [a]
: [VType]
r) [VType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
Any
getInstrType (BrIf Natural
lbl) = do
    [VType]
r <- (ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val ([ValueType] -> [VType])
-> Checker [ValueType]
-> ReaderT Ctx (Except ValidationError) [VType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Checker [ValueType]
getLabel Natural
lbl
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ([VType]
r [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [ValueType -> VType
Val ValueType
I32]) [VType] -> [VType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [VType]
r
getInstrType (BrTable [Natural]
lbls Natural
lbl) = do
    [ValueType]
r <- Natural -> Checker [ValueType]
getLabel Natural
lbl
    [[ValueType]]
rs <- (Natural -> Checker [ValueType])
-> [Natural] -> ReaderT Ctx (Except ValidationError) [[ValueType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Natural -> Checker [ValueType]
getLabel [Natural]
lbls
    if ([ValueType] -> Bool) -> [[ValueType]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([ValueType] -> [ValueType] -> Bool
forall a. Eq a => a -> a -> Bool
== [ValueType]
r) [[ValueType]]
rs
    then Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ([VType
Any] [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ ((ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val [ValueType]
r) [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [ValueType -> VType
Val ValueType
I32]) [VType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
Any
    else ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
ResultTypeDoesntMatch
getInstrType Instruction Natural
Return = do
    Ctx { [ValueType]
returns :: [ValueType]
$sel:returns:Ctx :: Ctx -> [ValueType]
returns } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ (VType
Any VType -> [VType] -> [VType]
forall a. a -> [a] -> [a]
: ((ValueType -> VType) -> [ValueType] -> [VType]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> VType
Val [ValueType]
returns)) [VType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
Any
getInstrType (Call Natural
fun) = do
    Ctx { [FuncType]
funcs :: [FuncType]
$sel:funcs:Ctx :: Ctx -> [FuncType]
funcs } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValidationError -> Maybe Arrow -> Checker Arrow
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither ValidationError
FunctionIndexOutOfRange (Maybe Arrow -> Checker Arrow) -> Maybe Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ FuncType -> Arrow
asArrow (FuncType -> Arrow) -> Maybe FuncType -> Maybe Arrow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FuncType]
funcs [FuncType] -> Natural -> Maybe FuncType
forall a. [a] -> Natural -> Maybe a
!? Natural
fun
getInstrType (CallIndirect Natural
sign) = do
    Ctx { [FuncType]
types :: [FuncType]
$sel:types:Ctx :: Ctx -> [FuncType]
types, [TableType]
tables :: [TableType]
$sel:tables:Ctx :: Ctx -> [TableType]
tables } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    if [TableType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TableType]
tables Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
    then ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> ValidationError
TableIndexOutOfRange Natural
0)
    else do
        Arrow [VType]
from [VType]
to <- ValidationError -> Maybe Arrow -> Checker Arrow
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither ValidationError
TypeIndexOutOfRange (Maybe Arrow -> Checker Arrow) -> Maybe Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ FuncType -> Arrow
asArrow (FuncType -> Arrow) -> Maybe FuncType -> Maybe Arrow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FuncType]
types [FuncType] -> Natural -> Maybe FuncType
forall a. [a] -> Natural -> Maybe a
!? Natural
sign
        Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ([VType]
from [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [ValueType -> VType
Val ValueType
I32]) [VType] -> [VType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [VType]
to
getInstrType Instruction Natural
Drop = do
    VType
var <- Checker VType
freshVar
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ VType
var VType -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType Instruction Natural
Select = do
    VType
var <- Checker VType
freshVar
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [VType
var, VType
var, ValueType -> VType
Val ValueType
I32] [VType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
var
getInstrType (GetLocal Natural
local) = do
    Ctx { [ValueType]
locals :: [ValueType]
$sel:locals:Ctx :: Ctx -> [ValueType]
locals }  <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValueType
t <- ValidationError -> Maybe ValueType -> Checker ValueType
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither (Natural -> ValidationError
LocalIndexOutOfRange Natural
local) (Maybe ValueType -> Checker ValueType)
-> Maybe ValueType -> Checker ValueType
forall a b. (a -> b) -> a -> b
$ [ValueType]
locals [ValueType] -> Natural -> Maybe ValueType
forall a. [a] -> Natural -> Maybe a
!? Natural
local
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType -> VType
Val ValueType
t
getInstrType (SetLocal Natural
local) = do
    Ctx { [ValueType]
locals :: [ValueType]
$sel:locals:Ctx :: Ctx -> [ValueType]
locals } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValueType
t <- ValidationError -> Maybe ValueType -> Checker ValueType
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither (Natural -> ValidationError
LocalIndexOutOfRange Natural
local) (Maybe ValueType -> Checker ValueType)
-> Maybe ValueType -> Checker ValueType
forall a b. (a -> b) -> a -> b
$ [ValueType]
locals [ValueType] -> Natural -> Maybe ValueType
forall a. [a] -> Natural -> Maybe a
!? Natural
local
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType -> VType
Val ValueType
t VType -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (TeeLocal Natural
local) = do
    Ctx { [ValueType]
locals :: [ValueType]
$sel:locals:Ctx :: Ctx -> [ValueType]
locals } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    ValueType
t <- ValidationError -> Maybe ValueType -> Checker ValueType
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither (Natural -> ValidationError
LocalIndexOutOfRange Natural
local) (Maybe ValueType -> Checker ValueType)
-> Maybe ValueType -> Checker ValueType
forall a b. (a -> b) -> a -> b
$ [ValueType]
locals [ValueType] -> Natural -> Maybe ValueType
forall a. [a] -> Natural -> Maybe a
!? Natural
local
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType -> VType
Val ValueType
t VType -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType -> VType
Val ValueType
t
getInstrType (GetGlobal Natural
global) = do
    Ctx { [GlobalType]
globals :: [GlobalType]
$sel:globals:Ctx :: Ctx -> [GlobalType]
globals } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    VType
t <- ValidationError -> Maybe VType -> Checker VType
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither (Natural -> ValidationError
GlobalIndexOutOfRange Natural
global) (Maybe VType -> Checker VType) -> Maybe VType -> Checker VType
forall a b. (a -> b) -> a -> b
$ GlobalType -> VType
asType (GlobalType -> VType) -> Maybe GlobalType -> Maybe VType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GlobalType]
globals [GlobalType] -> Natural -> Maybe GlobalType
forall a. [a] -> Natural -> Maybe a
!? Natural
global
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> VType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> VType
t
getInstrType (SetGlobal Natural
global) = do
    Ctx { [GlobalType]
globals :: [GlobalType]
$sel:globals:Ctx :: Ctx -> [GlobalType]
globals } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    VType
t <- ValidationError -> Maybe VType -> Checker VType
forall a. ValidationError -> Maybe a -> Checker a
maybeToEither (Natural -> ValidationError
GlobalIndexOutOfRange Natural
global) (Maybe VType -> Checker VType) -> Maybe VType -> Checker VType
forall a b. (a -> b) -> a -> b
$ GlobalType -> VType
asType (GlobalType -> VType) -> Maybe GlobalType -> Maybe VType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GlobalType]
globals [GlobalType] -> Natural -> Maybe GlobalType
forall a. [a] -> Natural -> Maybe a
!? Natural
global
    GlobalType -> Checker ()
shouldBeMut (GlobalType -> Checker ()) -> GlobalType -> Checker ()
forall a b. (a -> b) -> a -> b
$ [GlobalType]
globals [GlobalType] -> Int -> GlobalType
forall a. [a] -> Int -> a
!! Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
global
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ VType
t VType -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I32Load MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I64Load MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
8 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (F32Load MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (F64Load MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
8 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (I32Load8S MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I32Load8U MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I32Load16S MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I32Load16U MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I64Load8S MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I64Load8U MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I64Load16S MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I64Load16U MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I64Load32S MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I64Load32U MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (I32Store MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I32] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I64Store MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
8 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I64] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (F32Store MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
F32] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (F64Store MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
8 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
F64] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I32Store8 MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I32] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I32Store16 MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I32] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I64Store8 MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
1 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I64] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I64Store16 MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
2 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I64] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType (I64Store32 MemArg
memarg) = do
    Int -> MemArg -> Checker ()
checkMemoryInstr Int
4 MemArg
memarg
    Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I64] [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> [ValueType]
empty
getInstrType Instruction Natural
CurrentMemory = do
    Ctx { [Limit]
mems :: [Limit]
$sel:mems:Ctx :: Ctx -> [Limit]
mems } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask 
    if [Limit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Limit]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 then ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> ValidationError
MemoryIndexOutOfRange Natural
0) else Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType Instruction Natural
GrowMemory = do
    Ctx { [Limit]
mems :: [Limit]
$sel:mems:Ctx :: Ctx -> [Limit]
mems } <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask 
    if [Limit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Limit]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 then ValidationError -> Checker Arrow
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> ValidationError
MemoryIndexOutOfRange Natural
0) else Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I32Const Word32
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (I64Const Word64
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (F32Const Float
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (F64Const Double
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (IUnOp BitSize
BS32 IUnOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (IUnOp BitSize
BS64 IUnOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (IBinOp BitSize
BS32 IBinOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I32] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (IBinOp BitSize
BS64 IBinOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I64, ValueType
I64] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType Instruction Natural
I32Eqz = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType Instruction Natural
I64Eqz = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (IRelOp BitSize
BS32 IRelOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I32, ValueType
I32] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (IRelOp BitSize
BS64 IRelOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
I64, ValueType
I64] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (FUnOp BitSize
BS32 FUnOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FUnOp BitSize
BS64 FUnOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (FBinOp BitSize
BS32 FBinOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
F32, ValueType
F32] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FBinOp BitSize
BS64 FBinOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
F64, ValueType
F64] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (FRelOp BitSize
BS32 FRelOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
F32, ValueType
F32] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (FRelOp BitSize
BS64 FRelOp
_) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ [ValueType
F64, ValueType
F64] [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType Instruction Natural
I32WrapI64 = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncFU BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncFU BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncFU BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncFU BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncFS BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncFS BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncFS BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncFS BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncSatFU BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncSatFU BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncSatFU BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncSatFU BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncSatFS BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncSatFS BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (ITruncSatFS BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (ITruncSatFS BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType Instruction Natural
I64ExtendSI32 = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType Instruction Natural
I64ExtendUI32 = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (FConvertIU BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FConvertIU BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FConvertIU BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (FConvertIU BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (FConvertIS BitSize
BS32 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FConvertIS BitSize
BS32 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FConvertIS BitSize
BS64 BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (FConvertIS BitSize
BS64 BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType Instruction Natural
F32DemoteF64 = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType Instruction Natural
F64PromoteF32 = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64
getInstrType (IReinterpretF BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32
getInstrType (IReinterpretF BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
F64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I64
getInstrType (FReinterpretI BitSize
BS32) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I32 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F32
getInstrType (FReinterpretI BitSize
BS64) = Arrow -> Checker Arrow
forall (m :: * -> *) a. Monad m => a -> m a
return (Arrow -> Checker Arrow) -> Arrow -> Checker Arrow
forall a b. (a -> b) -> a -> b
$ ValueType
I64 ValueType -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
F64


replace :: (Eq a) => a -> a -> [a] -> [a]
replace :: a -> a -> [a] -> [a]
replace a
_ a
_ [] = []
replace a
x a
y (a
v:[a]
r) = (if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v then a
y else a
v) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> a -> [a] -> [a]
forall a. Eq a => a -> a -> [a] -> [a]
replace a
x a
y [a]
r

getExpressionTypeWithInput :: [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput :: [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput [VType]
inp = ([VType] -> Arrow)
-> ReaderT Ctx (Except ValidationError) [VType] -> Checker Arrow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([VType]
inp [VType] -> [VType] -> Arrow
`Arrow`) (ReaderT Ctx (Except ValidationError) [VType] -> Checker Arrow)
-> (Expression -> ReaderT Ctx (Except ValidationError) [VType])
-> Expression
-> Checker Arrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([VType]
 -> Instruction Natural
 -> ReaderT Ctx (Except ValidationError) [VType])
-> [VType]
-> Expression
-> ReaderT Ctx (Except ValidationError) [VType]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [VType]
-> Instruction Natural
-> ReaderT Ctx (Except ValidationError) [VType]
go [VType]
inp
    where
        go :: [VType] -> Instruction Natural -> Checker [VType]
        go :: [VType]
-> Instruction Natural
-> ReaderT Ctx (Except ValidationError) [VType]
go [VType]
stack Instruction Natural
instr = do
            ([VType]
f `Arrow` [VType]
t) <- Instruction Natural -> Checker Arrow
getInstrType Instruction Natural
instr
            [VType]
-> [VType]
-> [VType]
-> ReaderT Ctx (Except ValidationError) [VType]
matchStack [VType]
stack ([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
f) [VType]
t
        
        matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType]
        matchStack :: [VType]
-> [VType]
-> [VType]
-> ReaderT Ctx (Except ValidationError) [VType]
matchStack stack :: [VType]
stack@(VType
Any:[VType]
_) [VType]
_arg [VType]
res = [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([VType] -> ReaderT Ctx (Except ValidationError) [VType])
-> [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall a b. (a -> b) -> a -> b
$ [VType]
res [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [VType]
stack
        matchStack (Val ValueType
v:[VType]
stack) (Val ValueType
v':[VType]
args) [VType]
res =
            if ValueType
v ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
v'
            then [VType]
-> [VType]
-> [VType]
-> ReaderT Ctx (Except ValidationError) [VType]
matchStack [VType]
stack [VType]
args [VType]
res
            else ValidationError -> ReaderT Ctx (Except ValidationError) [VType]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> ReaderT Ctx (Except ValidationError) [VType])
-> ValidationError -> ReaderT Ctx (Except ValidationError) [VType]
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch (([VType] -> [VType]
forall a. [a] -> [a]
reverse ([VType] -> [VType]) -> [VType] -> [VType]
forall a b. (a -> b) -> a -> b
$ ValueType -> VType
Val ValueType
v'VType -> [VType] -> [VType]
forall a. a -> [a] -> [a]
:[VType]
args) [VType] -> [VType] -> Arrow
`Arrow` [VType]
res) ([] [VType] -> [VType] -> Arrow
`Arrow` (ValueType -> VType
Val ValueType
vVType -> [VType] -> [VType]
forall a. a -> [a] -> [a]
:[VType]
stack))
        matchStack [VType]
_ (VType
Any:[VType]
_) [VType]
res = [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([VType] -> ReaderT Ctx (Except ValidationError) [VType])
-> [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall a b. (a -> b) -> a -> b
$ [VType]
res
        matchStack (Val ValueType
v:[VType]
stack) (VType
Var:[VType]
args) [VType]
res =
            let subst :: [VType] -> [VType]
subst = VType -> VType -> [VType] -> [VType]
forall a. Eq a => a -> a -> [a] -> [a]
replace VType
Var (ValueType -> VType
Val ValueType
v) in
            [VType]
-> [VType]
-> [VType]
-> ReaderT Ctx (Except ValidationError) [VType]
matchStack [VType]
stack ([VType] -> [VType]
subst [VType]
args) ([VType] -> [VType]
subst [VType]
res)
        matchStack (VType
Var:[VType]
stack) (Val ValueType
v:[VType]
args) [VType]
res =
            let subst :: [VType] -> [VType]
subst = VType -> VType -> [VType] -> [VType]
forall a. Eq a => a -> a -> [a] -> [a]
replace VType
Var (ValueType -> VType
Val ValueType
v) in
            [VType]
-> [VType]
-> [VType]
-> ReaderT Ctx (Except ValidationError) [VType]
matchStack [VType]
stack ([VType] -> [VType]
subst [VType]
args) ([VType] -> [VType]
subst [VType]
res)
        matchStack [VType]
stack [] [VType]
res = [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([VType] -> ReaderT Ctx (Except ValidationError) [VType])
-> [VType] -> ReaderT Ctx (Except ValidationError) [VType]
forall a b. (a -> b) -> a -> b
$ [VType]
res [VType] -> [VType] -> [VType]
forall a. [a] -> [a] -> [a]
++ [VType]
stack
        matchStack [] [VType]
args [VType]
res = ValidationError -> ReaderT Ctx (Except ValidationError) [VType]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> ReaderT Ctx (Except ValidationError) [VType])
-> ValidationError -> ReaderT Ctx (Except ValidationError) [VType]
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch (([VType] -> [VType]
forall a. [a] -> [a]
reverse [VType]
args) [VType] -> [VType] -> Arrow
`Arrow` [VType]
res) ([] [VType] -> [VType] -> Arrow
`Arrow` [])
        matchStack [VType]
_ [VType]
_ [VType]
_ = String -> ReaderT Ctx (Except ValidationError) [VType]
forall a. HasCallStack => String -> a
error String
"inconsistent checker state"

getExpressionType :: Expression -> Checker Arrow
getExpressionType :: Expression -> Checker Arrow
getExpressionType = [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput []

isConstExpression :: Expression -> Checker ()
isConstExpression :: Expression -> Checker ()
isConstExpression [] = () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isConstExpression ((I32Const Word32
_):Expression
rest) = Expression -> Checker ()
isConstExpression Expression
rest
isConstExpression ((I64Const Word64
_):Expression
rest) = Expression -> Checker ()
isConstExpression Expression
rest
isConstExpression ((F32Const Float
_):Expression
rest) = Expression -> Checker ()
isConstExpression Expression
rest
isConstExpression ((F64Const Double
_):Expression
rest) = Expression -> Checker ()
isConstExpression Expression
rest
isConstExpression ((GetGlobal Natural
idx):Expression
rest) = do
    Ctx {[GlobalType]
globals :: [GlobalType]
$sel:globals:Ctx :: Ctx -> [GlobalType]
globals, Natural
importedGlobals :: Natural
$sel:importedGlobals:Ctx :: Ctx -> Natural
importedGlobals} <- ReaderT Ctx (Except ValidationError) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    if Natural
importedGlobals Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
idx
        then ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> ValidationError
GlobalIndexOutOfRange Natural
idx)
        else () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case [GlobalType]
globals [GlobalType] -> Int -> GlobalType
forall a. [a] -> Int -> a
!! Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
idx of
        Const ValueType
_ -> Expression -> Checker ()
isConstExpression Expression
rest
        Mut ValueType
_ -> ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
InvalidConstantExpr
isConstExpression Expression
_ = ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
InvalidConstantExpr

getFuncTypes :: Module -> [FuncType]
getFuncTypes :: Module -> [FuncType]
getFuncTypes Module {[FuncType]
$sel:types:Module :: Module -> [FuncType]
types :: [FuncType]
types, [Function]
$sel:functions:Module :: Module -> [Function]
functions :: [Function]
functions, [Import]
$sel:imports:Module :: Module -> [Import]
imports :: [Import]
imports} =
    let funImports :: [FuncType]
funImports = [Maybe FuncType] -> [FuncType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FuncType] -> [FuncType]) -> [Maybe FuncType] -> [FuncType]
forall a b. (a -> b) -> a -> b
$ (Import -> Maybe FuncType) -> [Import] -> [Maybe FuncType]
forall a b. (a -> b) -> [a] -> [b]
map Import -> Maybe FuncType
getFuncType [Import]
imports in
    [FuncType]
funImports [FuncType] -> [FuncType] -> [FuncType]
forall a. [a] -> [a] -> [a]
++ (Function -> FuncType) -> [Function] -> [FuncType]
forall a b. (a -> b) -> [a] -> [b]
map (([FuncType]
types [FuncType] -> Int -> FuncType
forall a. [a] -> Int -> a
!!) (Int -> FuncType) -> (Function -> Int) -> Function -> FuncType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> (Function -> Natural) -> Function -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Natural
funcType) [Function]
functions
    where
        getFuncType :: Import -> Maybe FuncType
getFuncType (Import Text
_ Text
_ (ImportFunc Natural
typeIdx)) = FuncType -> Maybe FuncType
forall a. a -> Maybe a
Just (FuncType -> Maybe FuncType) -> FuncType -> Maybe FuncType
forall a b. (a -> b) -> a -> b
$ [FuncType]
types [FuncType] -> Int -> FuncType
forall a. [a] -> Int -> a
!! (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
typeIdx)
        getFuncType Import
_ = Maybe FuncType
forall a. Maybe a
Nothing

ctxFromModule :: [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule :: [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule [ValueType]
locals [[ValueType]]
labels [ValueType]
returns m :: Module
m@Module {[FuncType]
types :: [FuncType]
$sel:types:Module :: Module -> [FuncType]
types, [Table]
$sel:tables:Module :: Module -> [Table]
tables :: [Table]
tables, [Memory]
$sel:mems:Module :: Module -> [Memory]
mems :: [Memory]
mems, [Global]
$sel:globals:Module :: Module -> [Global]
globals :: [Global]
globals, [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports} =
    let tableImports :: [TableType]
tableImports = [Maybe TableType] -> [TableType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TableType] -> [TableType])
-> [Maybe TableType] -> [TableType]
forall a b. (a -> b) -> a -> b
$ (Import -> Maybe TableType) -> [Import] -> [Maybe TableType]
forall a b. (a -> b) -> [a] -> [b]
map Import -> Maybe TableType
getTableType [Import]
imports in
    let memsImports :: [Limit]
memsImports = [Maybe Limit] -> [Limit]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Limit] -> [Limit]) -> [Maybe Limit] -> [Limit]
forall a b. (a -> b) -> a -> b
$ (Import -> Maybe Limit) -> [Import] -> [Maybe Limit]
forall a b. (a -> b) -> [a] -> [b]
map Import -> Maybe Limit
getMemType [Import]
imports in
    let globalImports :: [GlobalType]
globalImports = [Maybe GlobalType] -> [GlobalType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe GlobalType] -> [GlobalType])
-> [Maybe GlobalType] -> [GlobalType]
forall a b. (a -> b) -> a -> b
$ (Import -> Maybe GlobalType) -> [Import] -> [Maybe GlobalType]
forall a b. (a -> b) -> [a] -> [b]
map Import -> Maybe GlobalType
getGlobalType [Import]
imports in
    Ctx :: [FuncType]
-> [FuncType]
-> [TableType]
-> [Limit]
-> [GlobalType]
-> [ValueType]
-> [[ValueType]]
-> [ValueType]
-> Natural
-> Ctx
Ctx {
        [FuncType]
types :: [FuncType]
$sel:types:Ctx :: [FuncType]
types,
        $sel:funcs:Ctx :: [FuncType]
funcs = Module -> [FuncType]
getFuncTypes Module
m,
        $sel:tables:Ctx :: [TableType]
tables = [TableType]
tableImports [TableType] -> [TableType] -> [TableType]
forall a. [a] -> [a] -> [a]
++ (Table -> TableType) -> [Table] -> [TableType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Table TableType
t) -> TableType
t) [Table]
tables,
        $sel:mems:Ctx :: [Limit]
mems = [Limit]
memsImports [Limit] -> [Limit] -> [Limit]
forall a. [a] -> [a] -> [a]
++ (Memory -> Limit) -> [Memory] -> [Limit]
forall a b. (a -> b) -> [a] -> [b]
map (\(Memory Limit
l) -> Limit
l) [Memory]
mems,
        $sel:globals:Ctx :: [GlobalType]
globals = [GlobalType]
globalImports [GlobalType] -> [GlobalType] -> [GlobalType]
forall a. [a] -> [a] -> [a]
++ (Global -> GlobalType) -> [Global] -> [GlobalType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Global GlobalType
g Expression
_) -> GlobalType
g) [Global]
globals,
        [ValueType]
locals :: [ValueType]
$sel:locals:Ctx :: [ValueType]
locals,
        [[ValueType]]
labels :: [[ValueType]]
$sel:labels:Ctx :: [[ValueType]]
labels,
        [ValueType]
returns :: [ValueType]
$sel:returns:Ctx :: [ValueType]
returns,
        $sel:importedGlobals:Ctx :: Natural
importedGlobals = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [GlobalType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalType]
globalImports
    }
    where
        getTableType :: Import -> Maybe TableType
getTableType (Import Text
_ Text
_ (ImportTable TableType
tableType)) = TableType -> Maybe TableType
forall a. a -> Maybe a
Just TableType
tableType
        getTableType Import
_ = Maybe TableType
forall a. Maybe a
Nothing

        getMemType :: Import -> Maybe Limit
getMemType (Import Text
_ Text
_ (ImportMemory Limit
lim)) = Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
lim
        getMemType Import
_ = Maybe Limit
forall a. Maybe a
Nothing

        getGlobalType :: Import -> Maybe GlobalType
getGlobalType (Import Text
_ Text
_ (ImportGlobal GlobalType
gl)) = GlobalType -> Maybe GlobalType
forall a. a -> Maybe a
Just GlobalType
gl
        getGlobalType Import
_ = Maybe GlobalType
forall a. Maybe a
Nothing

isFunctionValid :: Function -> Validator
isFunctionValid :: Function -> Validator
isFunctionValid Function {Natural
funcType :: Natural
$sel:funcType:Function :: Function -> Natural
funcType, $sel:localTypes:Function :: Function -> [ValueType]
localTypes = [ValueType]
locals, Expression
$sel:body:Function :: Function -> Expression
body :: Expression
body} mod :: Module
mod@Module {[FuncType]
types :: [FuncType]
$sel:types:Module :: Module -> [FuncType]
types} =
    if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
funcType Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [FuncType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FuncType]
types
    then do
        let FuncType [ValueType]
params [ValueType]
results = [FuncType]
types [FuncType] -> Int -> FuncType
forall a. [a] -> Int -> a
!! Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
funcType
        let ctx :: Ctx
ctx = [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule ([ValueType]
params [ValueType] -> [ValueType] -> [ValueType]
forall a. [a] -> [a] -> [a]
++ [ValueType]
locals) [[ValueType]
results] [ValueType]
results Module
mod
        Arrow
arr <- Ctx -> Checker Arrow -> Either ValidationError Arrow
forall a. Ctx -> Checker a -> Either ValidationError a
runChecker Ctx
ctx (Checker Arrow -> Either ValidationError Arrow)
-> Checker Arrow -> Either ValidationError Arrow
forall a b. (a -> b) -> a -> b
$ Expression -> Checker Arrow
getExpressionType Expression
body
        if Arrow -> Arrow -> Bool
isArrowMatch Arrow
arr ([ValueType]
empty [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ([ValueType] -> [ValueType]
forall a. [a] -> [a]
reverse [ValueType]
results))
        then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (ValidationError -> ValidationResult)
-> ValidationError -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
arr ([ValueType]
empty [ValueType] -> [ValueType] -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ([ValueType] -> [ValueType]
forall a. [a] -> [a]
reverse [ValueType]
results))
    else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
TypeIndexOutOfRange

functionsShouldBeValid :: Validator
functionsShouldBeValid :: Validator
functionsShouldBeValid mod :: Module
mod@Module {[Function]
functions :: [Function]
$sel:functions:Module :: Module -> [Function]
functions} =
    (Function -> ValidationResult) -> [Function] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Function -> Validator) -> Module -> Function -> ValidationResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Function -> Validator
isFunctionValid Module
mod) [Function]
functions

tablesShouldBeValid :: Validator
tablesShouldBeValid :: Validator
tablesShouldBeValid Module { [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports, [Table]
tables :: [Table]
$sel:tables:Module :: Module -> [Table]
tables } =
    let tableImports :: [Import]
tableImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isTableImport [Import]
imports in
    let res :: ValidationResult
res = (Import -> ValidationResult) -> [Import] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Import { $sel:desc:Import :: Import -> ImportDesc
desc = ImportTable TableType
t } -> TableType -> ValidationResult
isValidTableType TableType
t) [Import]
tableImports in
    let res' :: ValidationResult
res' = (ValidationResult -> Table -> ValidationResult)
-> ValidationResult -> [Table] -> ValidationResult
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ValidationResult
r (Table TableType
t) -> ValidationResult
r ValidationResult -> ValidationResult -> ValidationResult
<> TableType -> ValidationResult
isValidTableType TableType
t) ValidationResult
res [Table]
tables in
    if [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
tableImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Table] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Table]
tables Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
        then ValidationResult
res'
        else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
MoreThanOneTable
    where
        isValidTableType :: TableType -> ValidationResult
        isValidTableType :: TableType -> ValidationResult
isValidTableType (TableType (Limit Natural
min Maybe Natural
max) ElemType
_) =
            if Natural
min Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
min Maybe Natural
max
            then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
InvalidTableType

memoryShouldBeValid :: Validator
memoryShouldBeValid :: Validator
memoryShouldBeValid Module { [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports, [Memory]
mems :: [Memory]
$sel:mems:Module :: Module -> [Memory]
mems } =
    let memImports :: [Import]
memImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isMemImport [Import]
imports in
    let res :: ValidationResult
res = (Import -> ValidationResult) -> [Import] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Import { $sel:desc:Import :: Import -> ImportDesc
desc = ImportMemory Limit
l } -> Limit -> ValidationResult
isValidLimit Limit
l) [Import]
memImports in
    let res' :: ValidationResult
res' = (ValidationResult -> Memory -> ValidationResult)
-> ValidationResult -> [Memory] -> ValidationResult
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ValidationResult
r (Memory Limit
l) -> ValidationResult
r ValidationResult -> ValidationResult -> ValidationResult
<> Limit -> ValidationResult
isValidLimit Limit
l) ValidationResult
res [Memory]
mems in
    if [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
memImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Memory] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Memory]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
        then ValidationResult
res'
        else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
MoreThanOneMemory
    where
        isValidLimit :: Limit -> ValidationResult
        isValidLimit :: Limit -> ValidationResult
isValidLimit (Limit Natural
min Maybe Natural
max) =
            let minMax :: ValidationResult
minMax = if Natural
min Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
min Maybe Natural
max then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
MinMoreThanMaxInMemoryLimit in
            let maxLim :: ValidationResult
maxLim = if Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
min Maybe Natural
max Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
65536 then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
MemoryLimitExceeded in
            ValidationResult
minMax ValidationResult -> ValidationResult -> ValidationResult
<> ValidationResult
maxLim

globalsShouldBeValid :: Validator
globalsShouldBeValid :: Validator
globalsShouldBeValid m :: Module
m@Module { [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports, [Global]
globals :: [Global]
$sel:globals:Module :: Module -> [Global]
globals } =
    let ctx :: Ctx
ctx = [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule [] [] [] Module
m in
    (Global -> ValidationResult) -> [Global] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Ctx -> Global -> ValidationResult
isGlobalValid Ctx
ctx) [Global]
globals
    where
        getGlobalType :: GlobalType -> ValueType
        getGlobalType :: GlobalType -> ValueType
getGlobalType (Const ValueType
vt) = ValueType
vt
        getGlobalType (Mut ValueType
vt) = ValueType
vt

        isGlobalValid :: Ctx -> Global -> ValidationResult
        isGlobalValid :: Ctx -> Global -> ValidationResult
isGlobalValid Ctx
ctx (Global GlobalType
gt Expression
init) = Ctx -> Checker () -> ValidationResult
forall a. Ctx -> Checker a -> Either ValidationError a
runChecker Ctx
ctx (Checker () -> ValidationResult) -> Checker () -> ValidationResult
forall a b. (a -> b) -> a -> b
$ do
            Expression -> Checker ()
isConstExpression Expression
init
            Arrow
t <- Expression -> Checker Arrow
getExpressionType Expression
init
            let expected :: Arrow
expected = [ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> GlobalType -> ValueType
getGlobalType GlobalType
gt
            if Arrow -> Arrow -> Bool
isArrowMatch Arrow
expected Arrow
t then () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker ()) -> ValidationError -> Checker ()
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
t Arrow
expected

elemsShouldBeValid :: Validator
elemsShouldBeValid :: Validator
elemsShouldBeValid m :: Module
m@Module { [ElemSegment]
$sel:elems:Module :: Module -> [ElemSegment]
elems :: [ElemSegment]
elems, [Function]
functions :: [Function]
$sel:functions:Module :: Module -> [Function]
functions, [Table]
tables :: [Table]
$sel:tables:Module :: Module -> [Table]
tables, [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports } =
    let ctx :: Ctx
ctx = [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule [] [] [] Module
m in
    (ElemSegment -> ValidationResult)
-> [ElemSegment] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Ctx -> ElemSegment -> ValidationResult
isElemValid Ctx
ctx) [ElemSegment]
elems
    where
        isElemValid :: Ctx -> ElemSegment -> ValidationResult
        isElemValid :: Ctx -> ElemSegment -> ValidationResult
isElemValid Ctx
ctx (ElemSegment Natural
tableIdx Expression
offset [Natural]
funs) =
            let check :: ValidationResult
check = Ctx -> Checker () -> ValidationResult
forall a. Ctx -> Checker a -> Either ValidationError a
runChecker Ctx
ctx (Checker () -> ValidationResult) -> Checker () -> ValidationResult
forall a b. (a -> b) -> a -> b
$ do
                    Expression -> Checker ()
isConstExpression Expression
offset
                    Arrow
t <- Expression -> Checker Arrow
getExpressionType Expression
offset
                    if Arrow -> Arrow -> Bool
isArrowMatch ([ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32) Arrow
t
                    then () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker ()) -> ValidationError -> Checker ()
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
t ([ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32) 
            in
            let tableImports :: [Import]
tableImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isTableImport [Import]
imports in
            let isTableIndexValid :: ValidationResult
isTableIndexValid =
                    if Natural
tableIdx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
tableImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Table] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Table]
tables)
                    then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (Natural -> ValidationError
TableIndexOutOfRange Natural
tableIdx)
            in
            let funImports :: [Import]
funImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isFuncImport [Import]
imports in
            let funsLength :: Natural
funsLength = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [Function] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Function]
functions Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
funImports in
            let isFunsValid :: ValidationResult
isFunsValid = (Natural -> ValidationResult) -> [Natural] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Natural
i -> if Natural
i Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
funsLength then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
FunctionIndexOutOfRange) [Natural]
funs in
            ValidationResult
check ValidationResult -> ValidationResult -> ValidationResult
<> ValidationResult
isFunsValid ValidationResult -> ValidationResult -> ValidationResult
<> ValidationResult
isTableIndexValid

datasShouldBeValid :: Validator
datasShouldBeValid :: Validator
datasShouldBeValid m :: Module
m@Module { [DataSegment]
$sel:datas:Module :: Module -> [DataSegment]
datas :: [DataSegment]
datas, [Memory]
mems :: [Memory]
$sel:mems:Module :: Module -> [Memory]
mems, [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports } =
    let ctx :: Ctx
ctx = [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
ctxFromModule [] [] [] Module
m in
    (DataSegment -> ValidationResult)
-> [DataSegment] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Ctx -> DataSegment -> ValidationResult
isDataValid Ctx
ctx) [DataSegment]
datas
    where
        isDataValid :: Ctx -> DataSegment -> ValidationResult
        isDataValid :: Ctx -> DataSegment -> ValidationResult
isDataValid Ctx
ctx (DataSegment Natural
memIdx Expression
offset ByteString
_) =
            let check :: ValidationResult
check = Ctx -> Checker () -> ValidationResult
forall a. Ctx -> Checker a -> Either ValidationError a
runChecker Ctx
ctx (Checker () -> ValidationResult) -> Checker () -> ValidationResult
forall a b. (a -> b) -> a -> b
$ do
                    Expression -> Checker ()
isConstExpression Expression
offset
                    Arrow
t <- Expression -> Checker Arrow
getExpressionType Expression
offset
                    if Arrow -> Arrow -> Bool
isArrowMatch ([ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32) Arrow
t
                    then () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else ValidationError -> Checker ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> Checker ()) -> ValidationError -> Checker ()
forall a b. (a -> b) -> a -> b
$ Arrow -> Arrow -> ValidationError
TypeMismatch Arrow
t ([ValueType]
empty [ValueType] -> ValueType -> Arrow
forall a b. (ToEnd a, ToEnd b) => a -> b -> Arrow
==> ValueType
I32) 
            in
            let memImports :: [Import]
memImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isMemImport [Import]
imports in
            if Natural
memIdx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
memImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Memory] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Memory]
mems)
            then ValidationResult
check
            else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (Natural -> ValidationError
MemoryIndexOutOfRange Natural
memIdx)

startShouldBeValid :: Validator
startShouldBeValid :: Validator
startShouldBeValid Module { $sel:start:Module :: Module -> Maybe StartFunction
start = Maybe StartFunction
Nothing } = () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
startShouldBeValid m :: Module
m@Module { $sel:start:Module :: Module -> Maybe StartFunction
start = Just (StartFunction Natural
idx) } =
    let types :: [FuncType]
types = Module -> [FuncType]
getFuncTypes Module
m in
    let i :: Int
i = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
idx in
    if [FuncType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FuncType]
types Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i
    then if [ValueType] -> [ValueType] -> FuncType
FuncType [] [] FuncType -> FuncType -> Bool
forall a. Eq a => a -> a -> Bool
== [FuncType]
types [FuncType] -> Int -> FuncType
forall a. [a] -> Int -> a
!! Int
i then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
InvalidStartFunctionType
    else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
FunctionIndexOutOfRange

exportsShouldBeValid :: Validator
exportsShouldBeValid :: Validator
exportsShouldBeValid Module { [Export]
$sel:exports:Module :: Module -> [Export]
exports :: [Export]
exports, [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports, [Function]
functions :: [Function]
$sel:functions:Module :: Module -> [Function]
functions, [Memory]
mems :: [Memory]
$sel:mems:Module :: Module -> [Memory]
mems, [Table]
tables :: [Table]
$sel:tables:Module :: Module -> [Table]
tables, [Global]
globals :: [Global]
$sel:globals:Module :: Module -> [Global]
globals } =
    ValidationResult
areExportNamesUnique ValidationResult -> ValidationResult -> ValidationResult
<> (Export -> ValidationResult) -> [Export] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Export -> ValidationResult
isExportValid [Export]
exports
    where
        funcImports :: [Import]
funcImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isFuncImport [Import]
imports
        tableImports :: [Import]
tableImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isTableImport [Import]
imports
        memImports :: [Import]
memImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isMemImport [Import]
imports
        globalImports :: [Import]
globalImports = (Import -> Bool) -> [Import] -> [Import]
forall a. (a -> Bool) -> [a] -> [a]
filter Import -> Bool
isGlobalImport [Import]
imports

        isExportValid :: Export -> ValidationResult
        isExportValid :: Export -> ValidationResult
isExportValid (Export Text
_ (ExportFunc Natural
funIdx)) =
            if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
funIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
funcImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Function] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Function]
functions then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
FunctionIndexOutOfRange
        isExportValid (Export Text
_ (ExportTable Natural
tableIdx)) =
            if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
tableIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
tableImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Table] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Table]
tables then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (Natural -> ValidationError
TableIndexOutOfRange Natural
tableIdx)
        isExportValid (Export Text
_ (ExportMemory Natural
memIdx)) =
            if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
memIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
memImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Memory] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Memory]
mems then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (Natural -> ValidationError
MemoryIndexOutOfRange Natural
memIdx)
        isExportValid (Export Text
_ (ExportGlobal Natural
globalIdx)) =
            if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
globalIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Import] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
globalImports Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Global] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Global]
globals
            then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (Natural -> ValidationError
GlobalIndexOutOfRange Natural
globalIdx)

        areExportNamesUnique :: ValidationResult
        areExportNamesUnique :: ValidationResult
areExportNamesUnique =
            case ((Set Text, [String]) -> Export -> (Set Text, [String]))
-> (Set Text, [String]) -> [Export] -> (Set Text, [String])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set Text, [String]) -> Export -> (Set Text, [String])
go (Set Text
forall a. Set a
Set.empty, []) [Export]
exports of
                (Set Text
_, []) -> () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Set Text
_, [String]
dup) -> ValidationError -> ValidationResult
forall a b. a -> Either a b
Left (ValidationError -> ValidationResult)
-> ValidationError -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [String] -> ValidationError
DuplicatedExportNames [String]
dup
            where
                go :: (Set.Set TL.Text, [String]) -> Export -> (Set.Set TL.Text, [String])
                go :: (Set Text, [String]) -> Export -> (Set Text, [String])
go (Set Text
set, [String]
dup) (Export Text
name ExportDesc
_) =
                    if Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
name Set Text
set
                    then (Set Text
set, Text -> String
forall a. Show a => a -> String
show Text
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
dup)
                    else (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
name Set Text
set, [String]
dup)

importsShouldBeValid :: Validator
importsShouldBeValid :: Validator
importsShouldBeValid Module { [Import]
imports :: [Import]
$sel:imports:Module :: Module -> [Import]
imports, [FuncType]
types :: [FuncType]
$sel:types:Module :: Module -> [FuncType]
types } =
    (Import -> ValidationResult) -> [Import] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Import -> ValidationResult
isImportValid [Import]
imports
    where
        isImportValid :: Import -> ValidationResult
        isImportValid :: Import -> ValidationResult
isImportValid (Import Text
_ Text
_ (ImportFunc Natural
typeIdx)) =
            if Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
typeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [FuncType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FuncType]
types
            then () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else ValidationError -> ValidationResult
forall a b. a -> Either a b
Left ValidationError
TypeIndexOutOfRange
        isImportValid (Import Text
_ Text
_ (ImportTable TableType
_)) = () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () -- checked in tables section
        isImportValid (Import Text
_ Text
_ (ImportMemory Limit
_)) = () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return () -- checked in mems section
        isImportValid (Import Text
_ Text
_ (ImportGlobal GlobalType
_)) = () -> ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()

newtype ValidModule = ValidModule { ValidModule -> Module
getModule :: Module } deriving (Int -> ValidModule -> ShowS
[ValidModule] -> ShowS
ValidModule -> String
(Int -> ValidModule -> ShowS)
-> (ValidModule -> String)
-> ([ValidModule] -> ShowS)
-> Show ValidModule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidModule] -> ShowS
$cshowList :: [ValidModule] -> ShowS
show :: ValidModule -> String
$cshow :: ValidModule -> String
showsPrec :: Int -> ValidModule -> ShowS
$cshowsPrec :: Int -> ValidModule -> ShowS
Show, ValidModule -> ValidModule -> Bool
(ValidModule -> ValidModule -> Bool)
-> (ValidModule -> ValidModule -> Bool) -> Eq ValidModule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidModule -> ValidModule -> Bool
$c/= :: ValidModule -> ValidModule -> Bool
== :: ValidModule -> ValidModule -> Bool
$c== :: ValidModule -> ValidModule -> Bool
Eq)

validate :: Module -> Either ValidationError ValidModule
validate :: Module -> Either ValidationError ValidModule
validate Module
mod = ValidModule -> () -> ValidModule
forall a b. a -> b -> a
const (Module -> ValidModule
ValidModule Module
mod) (() -> ValidModule)
-> ValidationResult -> Either ValidationError ValidModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Validator -> ValidationResult) -> [Validator] -> ValidationResult
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Validator -> Validator
forall a b. (a -> b) -> a -> b
$ Module
mod) [Validator]
validators
    where
        validators :: [Validator]
        validators :: [Validator]
validators = [
                Validator
functionsShouldBeValid,
                Validator
tablesShouldBeValid,
                Validator
memoryShouldBeValid,
                Validator
globalsShouldBeValid,
                Validator
elemsShouldBeValid,
                Validator
datasShouldBeValid,
                Validator
startShouldBeValid,
                Validator
exportsShouldBeValid,
                Validator
importsShouldBeValid
            ]