make validation result monoid instance

src/Language/Wasm/Validate.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module Language.Wasm.Validate (
+    ValidationResult(..),
     validate,
     isValid
 ) where
@@ -10,27 +11,41 @@ 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)
+import Data.Monoid ((<>))
 
 data ValidationResult =
     DuplicatedExportNames [String]
+    | InvalidTableType
     | MoreThanOneMemory
     | MoreThanOneTable
     | Valid
     deriving (Show, Eq)
 
+instance Monoid ValidationResult where
+    mempty = Valid
+    mappend Valid vr = vr
+    mappend vr Valid = vr
+    mappend vr _ = vr
+
 isValid :: ValidationResult -> Bool
 isValid Valid = True
 isValid _ = False
 
 type Validator = Module -> ValidationResult
 
-shouldBeAtMostOneTable :: Validator
-shouldBeAtMostOneTable Module { imports, tables } =
-    let memImports = filter isTableImport imports in
-    if length memImports + length tables <= 1
-    then Valid
-    else MoreThanOneTable
+tablesShouldBeValid :: Validator
+tablesShouldBeValid Module { imports, tables } =
+    let tableImports = filter isTableImport imports in
+    let res = foldMap (\Import { desc = ImportTable t } -> isValidTableType t) tableImports in
+    let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in
+    if length tableImports + length tables <= 1
+        then res'
+        else MoreThanOneTable
     where
+        isValidTableType :: TableType -> ValidationResult
+        isValidTableType (TableType (Limit min max) _) = if min <= fromMaybe min max then Valid else InvalidTableType
+
         isTableImport Import { desc = ImportTable _ } = True
         isTableImport _ = False
 
@@ -57,15 +72,11 @@ exportNamesShouldBeDifferent Module { exports } =
             else (Set.insert name set, dup)
 
 validate :: Validator
-validate mod = foldl' go Valid validators
+validate mod = foldMap ($ mod) validators
     where
-        go :: ValidationResult -> Validator -> ValidationResult
-        go Valid validator = validator mod
-        go res _ = res
-
         validators :: [Validator]
         validators = [
-                shouldBeAtMostOneTable,
+                tablesShouldBeValid,
                 shouldBeAtMostOneMemory,
                 exportNamesShouldBeDifferent
             ]

tests/Test.hs

@@ -43,11 +43,15 @@ main = do
     let Right mod' = Binary.decodeModuleLazy $ Binary.dumpModuleLazy mod
     return $ testCase ("Dump module to binary and parse back: " ++ file) $
       assertEqual "Module matched" mod mod'
-  validationTestCases <- (`mapM` (filter (/= "import.wast") files)) $ \file -> do
+  validationTestCases <- (`mapM` files) $ \file -> do
     content <- LBS.readFile $ "tests/samples/" ++ file
     let Right mod = Parser.parseModule <$> Lexer.scanner content
     return $ testCase ("Validate module: " ++ file) $
-      assertBool "Module matched" $ Validate.isValid $ Validate.validate mod
+      case file of
+        "import.wast" ->
+          assertEqual "Too many tables" Validate.MoreThanOneTable $ Validate.validate mod
+        _ ->
+          assertBool "Module matched" $ Validate.isValid $ Validate.validate mod
   defaultMain $ testGroup "tests" [
       testGroup "Syntax parsing" syntaxTestCases,
       testGroup "Binary format" binaryTestCases,