clean up the parser a little bit and relax arity checks on validation phase

src/Language/Wasm/Parser.y

@@ -579,7 +579,11 @@ typeuse_cont(next)
     | {- empty -} { (emptyTypeUse, Nothing) }
 
 typeuse1_cont(next)
-    : 'type' index ')' typesign(next) { let (ft, next) = $4 in (IndexedTypeUse $2 (Just ft), next) }
+    : 'type' index ')' typesign(next) {
+        case $4 of
+            (FuncType [] [], next) -> (IndexedTypeUse $2 Nothing, next)
+            (ft, next) -> (IndexedTypeUse $2 (Just ft), next)
+    }
     | typesign1(next) {
         let (ft, next) = $1 in
         (AnonimousTypeUse ft, next)
@@ -611,48 +615,16 @@ typesign_result1(next)
     }
     | next { (emptyFuncType, Just $1) }
 
+never : EOF { () }
+
 typeuse :: { TypeUse }
-    : '(' typeuse1 { $2 }
+    : typeuse_cont(never) { fst $1 }
-    | {- empty -} { emptyTypeUse }
-
-typeuse1 :: { TypeUse }
-    : 'type' index ')' typedtypeuse { IndexedTypeUse $2 $4 }
-    | paramsresultstypeuse { AnonimousTypeUse $1 }
-
-typedtypeuse :: { Maybe FuncType }
-    : '(' paramsresultstypeuse { Just $2 }
-    | {- empty -} { Nothing }
 
 typedef :: { TypeDef }
     : 'type' opt(ident) functype ')' { TypeDef $2 $3 }
 
 functype :: { FuncType }
-    : '(' 'func' params_results { $3 }
+    : '(' 'func' typesign(never) ')' { fst $3 }
-
-params_results :: { FuncType }
-    : ')' { emptyFuncType }
-    | '(' params_results1 { $2 }
-
-params_results1 :: { FuncType }
-    : 'param' list(valtype) ')' params_results { mergeFuncType (FuncType (map (ParamType Nothing) $2) []) $4 }
-    | 'param' ident valtype ')' params_results { mergeFuncType (FuncType [ParamType (Just $2) $3] []) $5 }
-    | results1 { $1 }
-
-results :: { FuncType }
-    : ')' { emptyFuncType }
-    | '(' results1 { $2 }
-
-results1 :: { FuncType }
-    : 'result' list(valtype) ')' results { mergeFuncType (FuncType [] $2) $4 }
-
-paramsresultstypeuse :: { FuncType }
-    : paramsresultstypeuse '(' paramsresulttypeuse { mergeFuncType $1 $3 }
-    | paramsresulttypeuse { $1 }
-
-paramsresulttypeuse :: { FuncType }
-    : 'param' list(valtype) ')' { FuncType (map (ParamType Nothing) $2) [] }
-    | 'param' ident valtype ')' { FuncType [ParamType (Just $2) $3] [] }
-    | 'result' list(valtype) ')' { FuncType [] $2 }
 
 memarg1 :: { MemArg }
     : opt(offset) opt(align) {% parseMemArg 1 $1 $2 }
@@ -672,7 +644,10 @@ instruction :: { [Instruction] }
 
 raw_instr :: { [Instruction] }
     : plaininstr { [PlainInstr $1] }
-    | 'call_indirect' raw_call_indirect { $2 }
+    | 'call_indirect' typeuse_cont(folded_instr1) {
+        let (tu, instr) = $2 in
+        [PlainInstr $ CallIndirect tu] ++ fromMaybe [] instr
+    }
     | 'block' opt(ident) raw_block {% (: []) `fmap` $3 $2 }
     | 'loop' opt(ident) raw_loop {% (: []) `fmap` $3 $2 }
     | 'if' opt(ident) raw_if_result {% $3 $2 }
@@ -753,12 +728,6 @@ raw_else :: { ([Instruction], Maybe Ident) }
         else Left "If labels have to match"
     }
 
-raw_call_indirect :: { [Instruction] }
-    : typeuse_cont(folded_instr1) {
-        let (tu, instr) = $1 in
-        [PlainInstr $ CallIndirect tu] ++ fromMaybe [] instr
-    }
-
 folded_instr :: { [Instruction] }
     : '(' folded_instr1 { $2 }
 
@@ -766,7 +735,7 @@ folded_instr1 :: { [Instruction] }
     : plaininstr list(folded_instr) ')' { concat $2 ++ [PlainInstr $1] }
     | 'call_indirect' typeuse_cont(folded_instr1) list(instruction) ')' {
         let (tu, instr) = $2 in
-        [PlainInstr $ CallIndirect tu] ++ fromMaybe [] instr ++ concat $3
+        fromMaybe [] instr ++ concat $3 ++ [PlainInstr $ CallIndirect tu]
     }
     | 'block' opt(ident) typeuse_cont(folded_instr1) list(instruction) ')' {
         let (typeUse, instr) = $3 in

src/Language/Wasm/Validate.hs

@@ -471,17 +471,14 @@ ctxFromModule locals labels returns m@Module {types, tables, mems, globals, impo
 isFunctionValid :: Function -> Validator
 isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types} =
     if fromIntegral funcType < length types
-    then
+    then do
-        let FuncType params results = types !! fromIntegral funcType in
+        let FuncType params results = types !! fromIntegral funcType
-        if length results > 1
+        let r = safeHead results
-        then Left InvalidResultArity
+        let ctx = ctxFromModule (params ++ locals) [r] r mod
-        else do
+        arr <- runChecker ctx $ getExpressionType body
-            let r = safeHead results
+        if isArrowMatch arr (empty ==> results)
-            let ctx = ctxFromModule (params ++ locals) [r] r mod
+        then return ()
-            arr <- runChecker ctx $ getExpressionType body
+        else Left $ TypeMismatch arr (empty ==> results)
-            if isArrowMatch arr (empty ==> results)
-            then return ()
-            else Left $ TypeMismatch arr (empty ==> results)
     else Left TypeIndexOutOfRange
 
 functionsShouldBeValid :: Validator
@@ -633,12 +630,6 @@ importsShouldBeValid Module { imports, types } =
         isImportValid (Import _ _ (ImportMemory _)) = return () -- checked in mems section
         isImportValid (Import _ _ (ImportGlobal _)) = return ()
 
-typesShouldBeValid :: Validator
-typesShouldBeValid Module { types } = foldMap isTypeValid types
-    where
-        isTypeValid :: FuncType -> ValidationResult
-        isTypeValid FuncType { results } = if length results <= 1 then return () else Left InvalidResultArity
-
 newtype ValidModule = ValidModule { getModule :: Module } deriving (Show, Eq)
 
 validate :: Module -> Either ValidationError ValidModule
@@ -646,7 +637,6 @@ validate mod = const (ValidModule mod) <$> foldMap ($ mod) validators
     where
         validators :: [Validator]
         validators = [
-                typesShouldBeValid,
                 functionsShouldBeValid,
                 tablesShouldBeValid,
                 memoryShouldBeValid,