bump version to 1.0 tag

exec/Main.hs

@@ -5,9 +5,7 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.Base64.Lazy as Base64
 import Data.Maybe (fromMaybe)
 
-import qualified Language.Wasm.Lexer as Lexer
+import qualified Language.Wasm as Wasm
-import qualified Language.Wasm.Parser as Parser
-import qualified Language.Wasm.Binary as Binary
 
 import Options.Applicative
 import Data.Semigroup ((<>))
@@ -105,10 +103,7 @@ config = subparser (
   )
 
 toBinary :: LBS.ByteString -> Either String LBS.ByteString
-toBinary content = do
+toBinary = fmap Wasm.encodeLazy . Wasm.parse
-    lexemes <- Lexer.scanner content
-    mod <- Parser.parseModule lexemes
-    return $ Binary.dumpModuleLazy mod
 
 compileAs :: (LBS.ByteString -> LBS.ByteString) -> String -> String -> IO ()
 compileAs transform input output = do

src/Language/Wasm.hs

@@ -1,6 +1,48 @@
 module Language.Wasm (
-    something
+    Module,
+    ValidModule,
+    ValidationError(..),
+    parse,
+    validate,
+    Language.Wasm.parseScript,
+    encode,
+    encodeLazy,
+    decode,
+    decodeLazy,
+    Script,
+    runScript
 ) where
 
-something :: Int
+import qualified Data.ByteString as BS
-something = 42
+import qualified Data.ByteString.Lazy as LBS
+
+import Language.Wasm.Structure as Struct
+import Language.Wasm.Script as Script
+import Language.Wasm.Lexer as Lexer
+import Language.Wasm.Parser as Parser
+import Language.Wasm.Validate as Valid
+import Language.Wasm.Binary as Binary
+
+-- | Parse WebAssembly text representation to `Module`
+parse :: LBS.ByteString -> Either String Module
+parse content = Lexer.scanner content >>= Parser.parseModule
+
+-- | Parse WebAssembly extended scipt grammar
+parseScript :: LBS.ByteString -> Either String Script
+parseScript content = Lexer.scanner content >>= Parser.parseScript
+
+-- | Dump `Module` to binary representation
+encode :: Module -> BS.ByteString
+encode = dumpModule
+
+-- | Dump `Module` to binary representation lazily
+encodeLazy :: Module -> LBS.ByteString
+encodeLazy = dumpModuleLazy
+
+-- | Decode `Module` from binary representation
+decode :: BS.ByteString -> Either String Module
+decode = decodeModule
+
+-- | Decode `Module` from binary representation lazily
+decodeLazy :: LBS.ByteString -> Either String Module
+decodeLazy = decodeModuleLazy

src/Language/Wasm/Interpreter.hs

@@ -53,9 +53,8 @@ import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE)
 import Control.Monad.Except (ExceptT, runExceptT, throwError)
 import Control.Monad.IO.Class (liftIO)
 
-import Debug.Trace as Debug
-
 import Language.Wasm.Structure as Struct
+import Language.Wasm.Validate as Valid
 import Language.Wasm.FloatUtils (
         wordToFloat,
         floatToWord,
@@ -532,8 +531,9 @@ initialize inst Module {elems, datas, start} store = do
         initData (from, mem, chunk) =
             mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk
 
-instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store))
+instantiate :: Store -> Imports -> Valid.ValidModule -> IO (Either String (ModuleInstance, Store))
-instantiate st imps m = runExceptT $ do
+instantiate st imps mod = runExceptT $ do
+    let m = Valid.getModule mod
     inst <- calcInstance st imps m
     let functions = funcInstances st <> (allocFunctions inst $ Struct.functions m)
     globals <- liftIO $ (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m)

src/Language/Wasm/Lexer.x

@@ -21,8 +21,6 @@ import Data.Word (Word8)
 import Data.List (isPrefixOf)
 import Text.Read (readEither)
 
-import qualified Debug.Trace as Debug
-
 }
 
 %wrapper "monadUserState-bytestring"

src/Language/Wasm/Parser.y

@@ -96,8 +96,6 @@ import Language.Wasm.Lexer (
         asDouble
     )
 
-import Debug.Trace as Debug
-
 }
 
 %name parseModule mod

src/Language/Wasm/Script.hs

@@ -95,12 +95,12 @@ runScript onAssertFail script = do
         addModule :: Maybe Ident -> Struct.Module -> ScriptState -> IO ScriptState
         addModule ident m st =
             case Validate.validate m of
-                Validate.Valid -> do
+                Right m -> do
                     res <- Interpreter.instantiate (store st) (buildImports st) m
                     case res of
                         Right (modInst, store') -> return $ addToStore ident modInst $ st { lastModule = Just modInst, store = store' }
                         Left reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason
-                reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason
+                Left reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason
         
         getModule :: ScriptState -> Maybe Ident -> Maybe Interpreter.ModuleInstance
         getModule st (Just (Ident i)) = Map.lookup i (modules st)
@@ -156,7 +156,7 @@ runScript onAssertFail script = do
         checkModuleInvalid :: Struct.Module -> IO ()
         checkModuleInvalid _ = return ()
 
-        getFailureString :: Validate.ValidationResult -> [TL.Text]
+        getFailureString :: Validate.ValidationError -> [TL.Text]
         getFailureString (Validate.TypeMismatch _ _) = ["type mismatch"]
         getFailureString Validate.ResultTypeDoesntMatch = ["type mismatch"]
         getFailureString Validate.MoreThanOneMemory = ["multiple memories"]
@@ -194,8 +194,8 @@ runScript onAssertFail script = do
         runAssert st assert@(AssertInvalid moduleDef failureString) =
             let (_, m) = buildModule moduleDef in
             case Validate.validate m of
-                Validate.Valid -> onAssertFail "Invalid module pass validation" assert
+                Right _ -> onAssertFail "Invalid module pass validation" assert
-                reason ->
+                Left reason ->
                     if failureString `elem` getFailureString reason
                     then return ()
                     else
@@ -216,12 +216,12 @@ runScript onAssertFail script = do
         runAssert st assert@(AssertUnlinkable moduleDef failureString) =
             let (_, m) = buildModule moduleDef in
             case Validate.validate m of
-                Validate.Valid -> do
+                Right m -> do
                     res <- Interpreter.instantiate (store st) (buildImports st) m
                     case res of
                         Left err -> return ()
                         Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert
-                reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason
+                Left reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason
         runAssert st assert@(AssertTrap (Left action) failureString) = do
             result <- runAction st action
             if isNothing result
@@ -230,12 +230,12 @@ runScript onAssertFail script = do
         runAssert st assert@(AssertTrap (Right moduleDef) failureString) =
             let (_, m) = buildModule moduleDef in
             case Validate.validate m of
-                Validate.Valid -> do
+                Right m -> do
                     res <- Interpreter.instantiate (store st) (buildImports st) m
                     case res of
                         Left "Start function terminated with trap" -> return ()
                         _ -> onAssertFail ("Module linking should fail with trap during execution of a start function") assert
-                reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason
+                Left reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason
         runAssert st assert@(AssertExhaustion action failureString) = do
             result <- runAction st action
             if isNothing result

src/Language/Wasm/Validate.hs

@@ -3,9 +3,12 @@
 {-# LANGUAGE FlexibleInstances #-}
 
 module Language.Wasm.Validate (
+    ValidationError(..),
     ValidationResult(..),
     validate,
-    isValid
+    isValid,
+    ValidModule,
+    getModule
 ) where
 
 import Language.Wasm.Structure
@@ -22,7 +25,7 @@ import Control.Monad.Except (Except, runExcept, throwError)
 
 import Debug.Trace as Debug
 
-data ValidationResult =
+data ValidationError =
     DuplicatedExportNames [String]
     | InvalidTableType
     | MinMoreThanMaxInMemoryLimit
@@ -45,18 +48,19 @@ data ValidationResult =
     | ImportedGlobalIsNotConst
     | ExportedGlobalIsNotConst
     | GlobalIsImmutable
-    | Valid
     deriving (Show, Eq)
 
+type ValidationResult = Either ValidationError ()
+
 instance Monoid ValidationResult where
-    mempty = Valid
+    mempty = Right ()
-    mappend Valid vr = vr
+    mappend (Right ()) vr = vr
-    mappend vr Valid = vr
+    mappend vr (Right ()) = vr
     mappend vr _ = vr
 
 isValid :: ValidationResult -> Bool
-isValid Valid = True
+isValid (Right ()) = True
-isValid reason = Debug.trace ("Module mismatched with reason " ++ show reason) $ False
+isValid (Left reason) = Debug.trace ("Module mismatched with reason " ++ show reason) $ False
 
 type Validator = Module -> ValidationResult
 
@@ -129,12 +133,12 @@ data Ctx = Ctx {
     importedGlobals :: Natural
 } deriving (Show, Eq)
 
-type Checker = ReaderT Ctx (Except ValidationResult)
+type Checker = ReaderT Ctx (Except ValidationError)
 
 freshVar :: Checker VType
 freshVar = return Var
 
-runChecker :: Ctx -> Checker a -> Either ValidationResult a
+runChecker :: Ctx -> Checker a -> Either ValidationError a
 runChecker ctx = runExcept . flip runReaderT ctx
 
 (!?) :: [a] -> Natural -> Maybe a
@@ -146,7 +150,7 @@ safeHead :: [a] -> Maybe a
 safeHead (x: _) = Just x
 safeHead [] = Nothing
 
-maybeToEither :: ValidationResult -> Maybe a -> Checker a
+maybeToEither :: ValidationError -> Maybe a -> Checker a
 maybeToEither _ (Just a) = return a
 maybeToEither l Nothing = throwError l
 
@@ -453,17 +457,15 @@ isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types
     then
         let FuncType params results = types !! fromIntegral funcType in
         if length results > 1
-        then InvalidResultArity
+        then Left InvalidResultArity
-        else
+        else do
-            let r = safeHead results in
+            let r = safeHead results
-            let ctx = ctxFromModule (params ++ locals) [r] r mod in
+            let ctx = ctxFromModule (params ++ locals) [r] r mod
-            case runChecker ctx $ getExpressionType body of
+            arr <- runChecker ctx $ getExpressionType body
-                Left err -> err
+            if isArrowMatch arr (empty ==> results)
-                Right arr ->
+            then return ()
-                    if isArrowMatch arr (empty ==> results)
+            else Left $ TypeMismatch arr (empty ==> results)
-                    then Valid
+    else Left TypeIndexOutOfRange
-                    else TypeMismatch arr (empty ==> results)
-    else TypeIndexOutOfRange
 
 functionsShouldBeValid :: Validator
 functionsShouldBeValid mod@Module {functions} =
@@ -476,13 +478,13 @@ tablesShouldBeValid Module { imports, tables } =
     let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in
     if length tableImports + length tables <= 1
         then res'
-        else MoreThanOneTable
+        else Left MoreThanOneTable
     where
         isValidTableType :: TableType -> ValidationResult
         isValidTableType (TableType (Limit min max) _) =
             if min <= fromMaybe min max
-            then Valid
+            then return ()
-            else InvalidTableType
+            else Left InvalidTableType
 
 memoryShouldBeValid :: Validator
 memoryShouldBeValid Module { imports, mems } =
@@ -491,12 +493,12 @@ memoryShouldBeValid Module { imports, mems } =
     let res' = foldl' (\r (Memory l) -> r <> isValidLimit l) res mems in
     if length memImports + length mems <= 1
         then res'
-        else MoreThanOneMemory
+        else Left MoreThanOneMemory
     where
         isValidLimit :: Limit -> ValidationResult
         isValidLimit (Limit min max) =
-            let minMax = if min <= fromMaybe min max then Valid else MinMoreThanMaxInMemoryLimit in
+            let minMax = if min <= fromMaybe min max then return () else Left MinMoreThanMaxInMemoryLimit in
-            let maxLim = if fromMaybe min max <= 65536 then Valid else MemoryLimitExceeded in
+            let maxLim = if fromMaybe min max <= 65536 then return () else Left MemoryLimitExceeded in
             minMax <> maxLim
 
 globalsShouldBeValid :: Validator
@@ -509,16 +511,11 @@ globalsShouldBeValid m@Module { imports, globals } =
         getGlobalType (Mut vt) = vt
 
         isGlobalValid :: Ctx -> Global -> ValidationResult
-        isGlobalValid ctx (Global gt init) =
+        isGlobalValid ctx (Global gt init) = runChecker ctx $ do
-            let check = runChecker ctx $ do
+            isConstExpression init
-                    isConstExpression init
+            t <- getExpressionType init
-                    t <- getExpressionType init
+            let expected = empty ==> getGlobalType gt
-                    let expected = empty ==> getGlobalType gt
+            if isArrowMatch expected t then return () else throwError $ TypeMismatch t expected
-                    return $ if isArrowMatch expected t then Valid else TypeMismatch t expected
-            in
-            case check of
-                Left err -> err
-                Right res -> res
 
 elemsShouldBeValid :: Validator
 elemsShouldBeValid m@Module { elems, functions, tables, imports } =
@@ -530,22 +527,20 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
             let check = runChecker ctx $ do
                     isConstExpression offset
                     t <- getExpressionType offset
-                    return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) 
+                    if isArrowMatch (empty ==> I32) t
-            in
+                    then return ()
-            let isIniterValid = case check of
+                    else throwError $ TypeMismatch t (empty ==> I32) 
-                    Left err -> err
-                    Right res -> res
             in
             let tableImports = filter isTableImport imports in
             let isTableIndexValid =
                     if tableIdx < (fromIntegral $ length tableImports + length tables)
-                    then Valid
+                    then return ()
-                    else TableIndexOutOfRange
+                    else Left 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 FunctionIndexOutOfRange) funs in
+            let isFunsValid = foldMap (\i -> if i < funsLength then return () else Left FunctionIndexOutOfRange) funs in
-            isIniterValid <> isFunsValid <> isTableIndexValid
+            check <> isFunsValid <> isTableIndexValid
 
 datasShouldBeValid :: Validator
 datasShouldBeValid m@Module { datas, mems, imports } =
@@ -557,25 +552,23 @@ datasShouldBeValid m@Module { datas, mems, imports } =
             let check = runChecker ctx $ do
                     isConstExpression offset
                     t <- getExpressionType offset
-                    return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) 
+                    if isArrowMatch (empty ==> I32) t
-            in
+                    then return ()
-            let isOffsetValid = case check of
+                    else throwError $ TypeMismatch t (empty ==> I32) 
-                    Left err -> err
-                    Right res -> res
             in
             let memImports = filter isMemImport imports in
             if memIdx < (fromIntegral $ length memImports + length mems)
-            then isOffsetValid
+            then check
-            else MemoryIndexOutOfRange
+            else Left MemoryIndexOutOfRange
 
 startShouldBeValid :: Validator
-startShouldBeValid Module { start = Nothing } = Valid
+startShouldBeValid Module { start = Nothing } = return ()
 startShouldBeValid m@Module { start = Just (StartFunction idx) } =
     let types = getFuncTypes m in
     let i = fromIntegral idx in
     if length types > i
-    then if FuncType [] [] == types !! i then Valid else InvalidStartFunctionType
+    then if FuncType [] [] == types !! i then return () else Left InvalidStartFunctionType
-    else FunctionIndexOutOfRange
+    else Left FunctionIndexOutOfRange
 
 exportsShouldBeValid :: Validator
 exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals } =
@@ -588,29 +581,29 @@ exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals
 
         isExportValid :: Export -> ValidationResult
         isExportValid (Export _ (ExportFunc funIdx)) =
-            if fromIntegral funIdx < length funcImports + length functions then Valid else FunctionIndexOutOfRange
+            if fromIntegral funIdx < length funcImports + length functions then return () else Left FunctionIndexOutOfRange
         isExportValid (Export _ (ExportTable tableIdx)) =
-            if fromIntegral tableIdx < length tableImports + length tables then Valid else TableIndexOutOfRange
+            if fromIntegral tableIdx < length tableImports + length tables then return () else Left TableIndexOutOfRange
         isExportValid (Export _ (ExportMemory memIdx)) =
-            if fromIntegral memIdx < length memImports + length mems then Valid else MemoryIndexOutOfRange
+            if fromIntegral memIdx < length memImports + length mems then return () else Left MemoryIndexOutOfRange
         isExportValid (Export _ (ExportGlobal globalIdx)) =
             if fromIntegral globalIdx < length globalImports + length globals
             then (
                 if fromIntegral globalIdx >= length globalImports
                 then (
                     case globals !! (fromIntegral globalIdx - length globalImports) of
-                        (Global (Mut _) _) -> ExportedGlobalIsNotConst
+                        (Global (Mut _) _) -> Left ExportedGlobalIsNotConst
-                        _ -> Valid
+                        _ -> return ()
                 )
-                else Valid
+                else return ()
             )
-            else GlobalIndexOutOfRange
+            else Left GlobalIndexOutOfRange
 
         areExportNamesUnique :: ValidationResult
         areExportNamesUnique =
             case foldl' go (Set.empty, []) exports of
-                (_, []) -> Valid
+                (_, []) -> return ()
-                (_, dup) -> DuplicatedExportNames dup
+                (_, dup) -> Left $ DuplicatedExportNames dup
             where
                 go :: (Set.Set TL.Text, [String]) -> Export -> (Set.Set TL.Text, [String])
                 go (set, dup) (Export name _) =
@@ -623,20 +616,25 @@ importsShouldBeValid Module { imports, types } =
     foldMap isImportValid imports
     where
         isImportValid :: Import -> ValidationResult
-        isImportValid (Import _ _ (ImportFunc typeIdx)) = if fromIntegral typeIdx < length types then Valid else TypeIndexOutOfRange
+        isImportValid (Import _ _ (ImportFunc typeIdx)) =
-        isImportValid (Import _ _ (ImportTable _)) = Valid -- checked in tables section
+            if fromIntegral typeIdx < length types
-        isImportValid (Import _ _ (ImportMemory _)) = Valid -- checked in mems section
+            then return ()
-        isImportValid (Import _ _ (ImportGlobal (Const _))) = Valid
+            else Left TypeIndexOutOfRange
-        isImportValid (Import _ _ (ImportGlobal (Mut _))) = ImportedGlobalIsNotConst
+        isImportValid (Import _ _ (ImportTable _)) = return () -- checked in tables section
+        isImportValid (Import _ _ (ImportMemory _)) = return () -- checked in mems section
+        isImportValid (Import _ _ (ImportGlobal (Const _))) = return ()
+        isImportValid (Import _ _ (ImportGlobal (Mut _))) = Left ImportedGlobalIsNotConst
 
 typesShouldBeValid :: Validator
 typesShouldBeValid Module { types } = foldMap isTypeValid types
     where
         isTypeValid :: FuncType -> ValidationResult
-        isTypeValid FuncType { results } = if length results <= 1 then Valid else InvalidResultArity
+        isTypeValid FuncType { results } = if length results <= 1 then return () else Left InvalidResultArity
 
-validate :: Validator
+newtype ValidModule = ValidModule { getModule :: Module } deriving (Show, Eq)
-validate mod = foldMap ($ mod) validators
+
+validate :: Module -> Either ValidationError ValidModule
+validate mod = const (ValidModule mod) <$> foldMap ($ mod) validators
     where
         validators :: [Validator]
         validators = [

tests/Test.hs

@@ -10,34 +10,14 @@ import qualified System.Directory as Directory
 
 import qualified Data.ByteString.Lazy as LBS
 
-import qualified Language.Wasm.Lexer as Lexer
+import qualified Language.Wasm as Wasm
-import qualified Language.Wasm.Parser as Parser
-import qualified Language.Wasm.Structure as Structure
-import qualified Language.Wasm.Binary as Binary
-import qualified Language.Wasm.Validate as Validate
-import qualified Language.Wasm.Interpreter as Interpreter
 import qualified Language.Wasm.Script as Script
 
-import qualified Debug.Trace as Debug
-
-isRight :: (Show b) => Either a b -> Bool
-isRight (Right x) = x `seq` True
-isRight _         = False
-
-compile :: String -> IO ()
-compile file = do
-  content <- LBS.readFile $ "tests/samples/" ++ file
-  let Right mod = Lexer.scanner content >>= Parser.parseModule
-  LBS.writeFile ("tests/runnable/" ++ file) $ Binary.dumpModuleLazy mod
-  -- to run: python -m SimpleHTTPServer 8081 && open http://localhost:8081/tests/runnable
-
 main :: IO ()
 main = do
   files <- Directory.listDirectory "tests/samples"
-  -- let files = ["address.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
-    content <- LBS.readFile $ "tests/samples/" ++ file
+    Right script <- Wasm.parseScript <$> LBS.readFile ("tests/samples/" ++ file)
-    let Right script = Lexer.scanner content >>= Parser.parseScript
     return $ testCase file $ do
       Script.runScript (\msg assert -> assertFailure ("Failed assert: " ++ msg ++ ". Assert " ++ show assert)) script
   defaultMain $ testGroup "Wasm Core Test Suit" scriptTestCases

wasm.cabal

@@ -1,11 +1,5 @@
--- This file has been generated from package.yaml by hpack version 0.20.0.
---
--- see: https://github.com/sol/hpack
---
--- hash: 1b02a1858ead3517927e9405dabc17ffb37f0df038564d37e8321b18227389ec
-
 name:           wasm
-version:        0.1.0
+version:        1.0.0
 author:         Ilya Rezvov
 maintainer:     rezvov.ilya@gmail.com
 license:        MIT
@@ -56,7 +50,7 @@ executable wasm
   hs-source-dirs: exec
   build-depends:
       base >=4.6 && <5.0
-    , wasm ==0.1.0
+    , wasm >= 1.0.0
     , optparse-applicative >= 0.14
     , bytestring >=0.10 && <0.11
     , base64-bytestring >= 1.0
@@ -75,7 +69,7 @@ test-suite test
     , tasty >=0.7
     , tasty-hunit >=0.4.1 && <0.10
     , text >=1.1 && <1.3
-    , wasm ==0.1.0
+    , wasm >= 1.0
   build-tools:
       alex >=3.1.3
     , happy >=1.9.4