diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 18a91e5..c30f336 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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 ] diff --git a/tests/Test.hs b/tests/Test.hs index 0ada94b..1644dfe 100644 --- a/tests/Test.hs +++ b/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,