implement assert_invalid assertion

src/Language/Wasm/Parser.y

@@ -614,16 +614,16 @@ paramsresulttypeuse :: { FuncType }
     | 'result' list(valtype) ')' { FuncType [] $2 }
 
 memarg1 :: { MemArg }
-    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 1 $2) }
+    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 1 $2) }
 
 memarg2 :: { MemArg }
-    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 2 $2) }
+    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 2 $2) }
 
 memarg4 :: { MemArg }
-    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 4 $2) }
+    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 4 $2) }
 
 memarg8 :: { MemArg }
-    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 8 $2) }
+    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 8 $2) }
 
 instruction :: { [Instruction] }
     : raw_instr { $1 }
@@ -1116,6 +1116,9 @@ asAlign str = do
     num <- TL.stripPrefix "align=" $ TLEncoding.decodeUtf8 str
     fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)
 
+unpackAlign :: Natural -> (Maybe Natural) -> Natural
+unpackAlign def = fromIntegral . round . logBase 2 . fromIntegral . fromMaybe def
+
 -- TODO: check name conditions.
 -- Presuming the source text is itself encoded correctly,
 -- strings that do not contain any uses of hexadecimal byte escapes are always valid names.
@@ -1673,10 +1676,7 @@ desugarize fields =
                 Nothing ->
                     let isIdent (LocalType ident _) = ident == Just id in
                     fromIntegral . (+ length ctxParams) <$> findIndex isIdent ctxLocals
-        getLocalIndex FunCtx {ctxParams, ctxLocals} (Index idx) =
+        getLocalIndex FunCtx {ctxParams, ctxLocals} (Index idx) = Just idx
-            if (length ctxParams + length ctxLocals > fromIntegral idx)
-            then Just idx
-            else Nothing
         
         isFuncImport :: Import -> Bool
         isFuncImport Import { desc = ImportFunc _ _ } = True
@@ -1690,11 +1690,7 @@ desugarize fields =
                 Nothing ->
                     let isIdent (Function { ident }) = ident == Just id in
                     fromIntegral . (+ length funImports) <$> findIndex isIdent functions
-        getFuncIndex Module { imports, functions } (Index idx) =
+        getFuncIndex Module { imports, functions } (Index idx) = Just idx
-            let funImports = filter isFuncImport imports in
-            if length funImports + length functions > fromIntegral idx
-            then Just idx
-            else Nothing
 
         -- tables
         synTableToStruct :: Table -> S.Table
@@ -1716,11 +1712,7 @@ desugarize fields =
                 Nothing ->
                     let isIdent (Table (Just id) _) = True in
                     fromIntegral . (+ length tableImports) <$> findIndex isIdent tables
-        getTableIndex Module { imports, tables } (Index idx) =
+        getTableIndex Module { imports, tables } (Index idx) = Just idx
-            let tableImports = filter isTableImport imports in
-            if length tableImports + length tables > fromIntegral idx
-            then Just idx
-            else Nothing
 
         -- memory
         synMemoryToStruct :: Memory -> S.Memory
@@ -1742,11 +1734,7 @@ desugarize fields =
                 Nothing ->
                     let isIdent (Memory (Just id) _) = True in
                     fromIntegral . (+ length memImports) <$> findIndex isIdent mems
-        getMemIndex Module { imports, mems } (Index idx) =
+        getMemIndex Module { imports, mems } (Index idx) = Just idx
-            let memImports = filter isMemImport imports in
-            if length memImports + length mems > fromIntegral idx
-            then Just idx
-            else Nothing
 
         -- global
         synGlobalToStruct :: Module -> Global -> S.Global
@@ -1770,11 +1758,7 @@ desugarize fields =
                 Nothing ->
                     let isIdent (Global { ident }) = ident == Just id in
                     fromIntegral . (+ length globalImports) <$> findIndex isIdent globals
-        getGlobalIndex Module { imports, globals } (Index idx) =
+        getGlobalIndex Module { imports, globals } (Index idx) = Just idx
-            let globalImports = filter isGlobalImport imports in
-            if length globalImports + length globals > fromIntegral idx
-            then Just idx
-            else Nothing
 
         -- elem segment
         synElemToStruct :: Module -> ElemSegment -> S.ElemSegment

src/Language/Wasm/Script.hs

@@ -139,6 +139,36 @@ runScript onAssertFail script = do
                     then return ()
                     else onAssertFail ("Expected NaN, but action returned " ++ show v) assert
                 _ -> onAssertFail ("Expected NaN, but action returned " ++ show result) assert
+        
+        buildModule :: ModuleDef -> (Maybe Ident, Struct.Module)
+        buildModule (RawModDef ident m) = (ident, m)
+        buildModule (TextModDef ident textRep) =
+            let Right m = Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) in
+            (ident, m)
+        buildModule (BinaryModDef ident binaryRep) =
+            let Right m = Binary.decodeModuleLazy binaryRep in
+            (ident, m)
+
+        checkModuleInvalid :: Struct.Module -> IO ()
+        checkModuleInvalid _ = return ()
+
+        getFailureString :: Validate.ValidationResult -> TL.Text
+        getFailureString (Validate.TypeMismatch _ _) = "type mismatch"
+        getFailureString Validate.MoreThanOneMemory = "multiple memories"
+        getFailureString Validate.MoreThanOneTable = "multiple tables"
+        getFailureString Validate.LocalIndexOutOfRange = "unknown local"
+        getFailureString Validate.MemoryIndexOutOfRange = "unknown memory"
+        getFailureString Validate.TableIndexOutOfRange = "unknown table"
+        getFailureString Validate.FunctionIndexOutOfRange = "unknown function"
+        getFailureString Validate.GlobalIndexOutOfRange = "unknown global"
+        getFailureString Validate.LabelIndexOutOfRange = "unknown label"
+        getFailureString Validate.MinMoreThanMaxInMemoryLimit = "size minimum must not be greater than maximum"
+        getFailureString Validate.MemoryLimitExceeded = "memory size must be at most 65536 pages (4GiB)"
+        getFailureString Validate.AlignmentOverflow = "alignment must not be larger than natural"
+        getFailureString (Validate.DuplicatedExportNames _) = "duplicate export name"
+        getFailureString Validate.InvalidConstantExpr = "constant expression required"
+        -- getFailureString Validate.ImportedGlobalIsNotConst = "global is immutable"
+        getFailureString _ = "not implemented"
 
         runAssert :: ScriptState -> Assertion -> IO ()
         runAssert st assert@(AssertReturn action expected) = do
@@ -148,15 +178,24 @@ runScript onAssertFail script = do
             else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
         runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert
         runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert
+        runAssert st assert@(AssertInvalid moduleDef failureString) =
+            let (_, m) = buildModule moduleDef in
+            case Validate.validate m of
+                Validate.Valid -> onAssertFail "Invalid module pass validation" assert
+                reason ->
+                    if getFailureString reason == failureString
+                    then return ()
+                    else
+                        let msg = "Module invalid for other reason. Expected "
+                                ++ show failureString
+                                ++ ", but actual is "
+                                ++ show (getFailureString reason)
+                        in onAssertFail msg assert
         runAssert _ _ = return ()
 
         runCommand :: ScriptState -> Command -> IO ScriptState
-        runCommand st (ModuleDef (RawModDef ident m)) = addModule ident m st
+        runCommand st (ModuleDef moduleDef) =
-        runCommand st (ModuleDef (TextModDef ident textRep)) =
+            let (ident, m) = buildModule moduleDef in
-            let Right m = Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) in
-            addModule ident m st
-        runCommand st (ModuleDef (BinaryModDef ident binaryRep)) =
-            let Right m = Binary.decodeModuleLazy binaryRep in
             addModule ident m st
         runCommand st (Register name i) = return $ addToRegistery name i st
         runCommand st (Action action) = runAction st action >> return st

src/Language/Wasm/Validate.hs

@@ -25,13 +25,19 @@ import Debug.Trace as Debug
 data ValidationResult =
     DuplicatedExportNames [String]
     | InvalidTableType
-    | InvalidMemoryLimit
+    | MinMoreThanMaxInMemoryLimit
+    | MemoryLimitExceeded
+    | AlignmentOverflow
     | MoreThanOneMemory
     | MoreThanOneTable
-    | IndexOutOfRange
+    | FunctionIndexOutOfRange
+    | TableIndexOutOfRange
+    | MemoryIndexOutOfRange
+    | LocalIndexOutOfRange
+    | GlobalIndexOutOfRange
+    | LabelIndexOutOfRange
+    | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
-    | NoTableInModule
-    | NoMemoryInModule
     | TypeMismatch { actual :: Arrow, expected :: Arrow }
     | InvalidConstantExpr
     | InvalidStartFunctionType
@@ -144,9 +150,6 @@ maybeToEither :: ValidationResult -> Maybe a -> Checker a
 maybeToEither _ (Just a) = return a
 maybeToEither l Nothing = throwError l
 
-isIndexValid :: (Integral idx, Integral len) => idx -> len -> ValidationResult
-isIndexValid idx len = if fromIntegral idx < fromIntegral len then Valid else IndexOutOfRange
-
 asType :: GlobalType -> VType
 asType (Const v) = Val v
 asType (Mut v) = Val v
@@ -155,12 +158,21 @@ getLabel :: LabelIndex -> Checker (Maybe ValueType)
 getLabel lbl = do
     Ctx { labels } <- ask
     case labels !? lbl of
-        Nothing -> throwError IndexOutOfRange
+        Nothing -> throwError LabelIndexOutOfRange
         Just v -> return v
 
 withLabel :: [ValueType] -> Checker a -> Checker a
 withLabel result = withReaderT (\ctx -> ctx { labels = safeHead result : labels ctx })
 
+isMemArgValid :: Int -> MemArg -> Checker ()
+isMemArgValid sizeInBytes MemArg { align } = if 2 ^ align <= sizeInBytes then return () else throwError AlignmentOverflow
+
+checkMemoryInstr :: Int -> MemArg -> Checker ()
+checkMemoryInstr size memarg = do
+    isMemArgValid size memarg
+    Ctx { mems } <- ask 
+    if length mems < 1 then throwError MemoryIndexOutOfRange else return ()
+
 getInstrType :: Instruction -> Checker Arrow
 getInstrType Unreachable = return $ Any ==> Any
 getInstrType Nop = return $ empty ==> empty
@@ -202,13 +214,13 @@ getInstrType Return = do
     return $ (Any : (map Val $ maybeToList returns)) ==> Any
 getInstrType (Call fun) = do
     Ctx { funcs } <- ask
-    maybeToEither IndexOutOfRange $ asArrow <$> funcs !? fun
+    maybeToEither FunctionIndexOutOfRange $ asArrow <$> funcs !? fun
 getInstrType (CallIndirect sign) = do
     Ctx { types, tables } <- ask
     if length tables < 1
-    then throwError NoTableInModule
+    then throwError TableIndexOutOfRange
     else do
-        Arrow from to <- maybeToEither IndexOutOfRange $ asArrow <$> types !? sign
+        Arrow from to <- maybeToEither FunctionIndexOutOfRange $ asArrow <$> types !? sign
         return $ (from ++ [Val I32]) ==> to
 getInstrType Drop = do
     var <- freshVar
@@ -218,100 +230,99 @@ getInstrType Select = do
     return $ [var, var, Val I32] ==> var
 getInstrType (GetLocal local) = do
     Ctx { locals }  <- ask
-    t <- maybeToEither IndexOutOfRange $ locals !? local
+    t <- maybeToEither LocalIndexOutOfRange $ locals !? local
     return $ empty ==> Val t
 getInstrType (SetLocal local) = do
     Ctx { locals } <- ask
-    t <- maybeToEither IndexOutOfRange $ locals !? local
+    t <- maybeToEither LocalIndexOutOfRange $ locals !? local
     return $ Val t ==> empty
 getInstrType (TeeLocal local) = do
     Ctx { locals } <- ask
-    t <- maybeToEither IndexOutOfRange $ locals !? local
+    t <- maybeToEither LocalIndexOutOfRange $ locals !? local
     return $ Val t ==> Val t
 getInstrType (GetGlobal global) = do
     Ctx { globals } <- ask
-    t <- maybeToEither IndexOutOfRange $ asType <$> globals !? global
+    t <- maybeToEither LocalIndexOutOfRange $ asType <$> globals !? global
     return $ empty ==> t
 getInstrType (SetGlobal global) = do
     Ctx { globals } <- ask
-    t <- maybeToEither IndexOutOfRange $ asType <$> globals !? global
+    t <- maybeToEither LocalIndexOutOfRange $ asType <$> globals !? global
     return $ t ==> empty
--- TODO: check memory alignment
+getInstrType (I32Load memarg) = do
-getInstrType (I32Load _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask
+    return $ I32 ==> I32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+getInstrType (I64Load memarg) = do
-getInstrType (I64Load _) = do
+    checkMemoryInstr 8 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (F32Load memarg) = do
-getInstrType (F32Load _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> F32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> F32
+getInstrType (F64Load memarg) = do
-getInstrType (F64Load _) = do
+    checkMemoryInstr 8 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> F64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> F64
+getInstrType (I32Load8S memarg) = do
-getInstrType (I32Load8S _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+getInstrType (I32Load8U memarg) = do
-getInstrType (I32Load8U _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+getInstrType (I32Load16S memarg) = do
-getInstrType (I32Load16S _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+getInstrType (I32Load16U memarg) = do
-getInstrType (I32Load16U _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I32
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+getInstrType (I64Load8S memarg) = do
-getInstrType (I64Load8S _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I64Load8U memarg) = do
-getInstrType (I64Load8U _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I64Load16S memarg) = do
-getInstrType (I64Load16S _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I64Load16U memarg) = do
-getInstrType (I64Load16U _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I64Load32S memarg) = do
-getInstrType (I64Load32S _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I64Load32U memarg) = do
-getInstrType (I64Load32U _) = do
+    checkMemoryInstr 8 memarg
-    Ctx { mems } <- ask 
+    return $ I32 ==> I64
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64
+getInstrType (I32Store memarg) = do
-getInstrType (I32Store _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I32] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty
+getInstrType (I64Store memarg) = do
-getInstrType (I64Store _) = do
+    checkMemoryInstr 8 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I64] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty
+getInstrType (F32Store memarg) = do
-getInstrType (F32Store _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, F32] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, F32] ==> empty
+getInstrType (F64Store memarg) = do
-getInstrType (F64Store _) = do
+    checkMemoryInstr 8 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, F64] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, F64] ==> empty
+getInstrType (I32Store8 memarg) = do
-getInstrType (I32Store8 _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I32] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty
+getInstrType (I32Store16 memarg) = do
-getInstrType (I32Store16 _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I32] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty
+getInstrType (I64Store8 memarg) = do
-getInstrType (I64Store8 _) = do
+    checkMemoryInstr 1 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I64] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty
+getInstrType (I64Store16 memarg) = do
-getInstrType (I64Store16 _) = do
+    checkMemoryInstr 2 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I64] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty
+getInstrType (I64Store32 memarg) = do
-getInstrType (I64Store32 _) = do
+    checkMemoryInstr 4 memarg
-    Ctx { mems } <- ask 
+    return $ [I32, I64] ==> empty
-    if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty
 getInstrType CurrentMemory = do
     Ctx { mems } <- ask 
-    if length mems < 1 then throwError NoMemoryInModule else return $ empty ==> I32
+    if length mems < 1 then throwError MemoryIndexOutOfRange else return $ empty ==> I32
 getInstrType GrowMemory = do
     Ctx { mems } <- ask 
-    if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32
+    if length mems < 1 then throwError MemoryIndexOutOfRange else return $ I32 ==> I32
 getInstrType (I32Const _) = return $ empty ==> I32
 getInstrType (I64Const _) = return $ empty ==> I64
 getInstrType (F32Const _) = return $ empty ==> F32
@@ -494,7 +505,10 @@ memoryShouldBeValid Module { imports, mems } =
         else MoreThanOneMemory
     where
         isValidLimit :: Limit -> ValidationResult
-        isValidLimit (Limit min max) = if min <= fromMaybe min max then Valid else InvalidMemoryLimit
+        isValidLimit (Limit min max) =
+            let minMax = if min <= fromMaybe min max then Valid else MinMoreThanMaxInMemoryLimit in
+            let maxLim = if fromMaybe min max <= 65536 then Valid else MemoryLimitExceeded in
+            minMax <> maxLim
 
 globalsShouldBeValid :: Validator
 globalsShouldBeValid m@Module { imports, globals } =
@@ -537,11 +551,11 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
             let isTableIndexValid =
                     if tableIdx < (fromIntegral $ length tableImports + length tables)
                     then Valid
-                    else IndexOutOfRange
+                    else TableIndexOutOfRange
             in
             let funImports = filter isFuncImport imports in
             let funsLength = fromIntegral $ length functions + length funImports in
-            let isFunsValid = foldMap (\i -> if i < funsLength then Valid else IndexOutOfRange) funs in
+            let isFunsValid = foldMap (\i -> if i < funsLength then Valid else FunctionIndexOutOfRange) funs in
             isIniterValid <> isFunsValid <> isTableIndexValid
 
 datasShouldBeValid :: Validator
@@ -563,7 +577,7 @@ datasShouldBeValid m@Module { datas, mems, imports } =
             let memImports = filter isMemImport imports in
             if memIdx < (fromIntegral $ length memImports + length mems)
             then isOffsetValid
-            else IndexOutOfRange
+            else MemoryIndexOutOfRange
 
 startShouldBeValid :: Validator
 startShouldBeValid Module { start = Nothing } = Valid
@@ -572,7 +586,7 @@ startShouldBeValid m@Module { start = Just (StartFunction idx) } =
     let i = fromIntegral idx in
     if length types > i
     then if FuncType [] [] == types !! i then Valid else InvalidStartFunctionType
-    else IndexOutOfRange
+    else TableIndexOutOfRange
 
 exportsShouldBeValid :: Validator
 exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals } =
@@ -585,13 +599,13 @@ exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals
 
         isExportValid :: Export -> ValidationResult
         isExportValid (Export _ (ExportFunc funIdx)) =
-            isIndexValid funIdx $ length funcImports + length functions
+            if fromIntegral funIdx < length funcImports + length functions then Valid else FunctionIndexOutOfRange
         isExportValid (Export _ (ExportTable tableIdx)) =
-            isIndexValid tableIdx $ length tableImports + length tables
+            if fromIntegral tableIdx < length tableImports + length tables then Valid else TableIndexOutOfRange
         isExportValid (Export _ (ExportMemory memIdx)) =
-            isIndexValid memIdx $ length memImports + length mems
+            if fromIntegral memIdx < length memImports + length mems then Valid else MemoryIndexOutOfRange
         isExportValid (Export _ (ExportGlobal globalIdx)) =
-            isIndexValid globalIdx $ length globalImports + length globals
+            if fromIntegral globalIdx < length globalImports + length globals then Valid else GlobalIndexOutOfRange
 
         areExportNamesUnique :: ValidationResult
         areExportNamesUnique =
@@ -610,7 +624,7 @@ importsShouldBeValid Module { imports, types } =
     foldMap isImportValid imports
     where
         isImportValid :: Import -> ValidationResult
-        isImportValid (Import _ _ (ImportFunc typeIdx)) = isIndexValid typeIdx $ length types
+        isImportValid (Import _ _ (ImportFunc typeIdx)) = if fromIntegral typeIdx < length types then Valid else TypeIndexOutOfRange
         isImportValid (Import _ _ (ImportTable _)) = Valid -- checked in tables section
         isImportValid (Import _ _ (ImportMemory _)) = Valid -- checked in mems section
         isImportValid (Import _ _ (ImportGlobal (Const _))) = Valid

tests/Test.hs

@@ -34,7 +34,7 @@ compile file = do
 main :: IO ()
 main = do
   files <- Directory.listDirectory "tests/samples"
-  -- let files = ["float_literals.wast"]
+  -- let files = ["memory.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     content <- LBS.readFile $ "tests/samples/" ++ file
     let Right script = Parser.parseScript <$> Lexer.scanner content