fix parsing binary modules from text representation

src/Language/Wasm/Binary.hs

@@ -23,11 +23,11 @@ import qualified Data.Text.Lazy.Encoding as TLEncoding
 getULEB128 :: (Integral a, Bits a) => Get a
 getULEB128 = do
     val <- getWord8
-    if val < 2 ^ 7
+    if not (testBit val 7)
     then return $ fromIntegral val
     else do
         rest <- getULEB128
-        return $ (fromIntegral $ 0x7F .&. val) + 128 * rest
+        return $ (fromIntegral $ val .&. 0x7F) .|. (rest `shiftL` 7)
 
 putULEB128 :: (Integral a, Bits a) => a -> Put
 putULEB128 val =
@@ -101,8 +101,12 @@ skipCustomSection = do
 
 getSection :: SectionType -> Get a -> a -> Get a
 getSection sectionType parser def = do
-    nextByte <- lookAhead getWord8
+    empty <- isEmpty
-    parseSection $ fromIntegral nextByte
+    if empty
+    then return def
+    else do
+        nextByte <- lookAhead getWord8
+        parseSection $ fromIntegral nextByte
     where
         parseSection op
             | op == 0 = skipCustomSection >> getSection sectionType parser def

src/Language/Wasm/Parser.y

@@ -63,6 +63,7 @@ import qualified Data.Text.Lazy.Encoding as TLEncoding
 import qualified Data.Text.Lazy.Read as TLRead
 
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSChar8
 import Data.Maybe (fromMaybe, fromJust)
 import Data.List (foldl', findIndex, find)
 import Control.Monad (guard)
@@ -1024,7 +1025,7 @@ command1 :: { Command }
     | meta1 { Meta $1 }
 
 module1 :: { ModuleDef }
-    : 'module' opt(ident) 'binary' list(string) ')' { BinaryModDef $2 (TLEncoding.encodeUtf8 $ TL.concat $4) }
+    : 'module' opt(ident) 'binary' list(string) ')' { BinaryModDef $2 (LBSChar8.pack $ TL.unpack $ TL.concat $4) }
     | 'module' opt(ident) 'quote' list(string) ')' { TextModDef $2 (TL.concat $4) }
     | 'module' opt(ident) list(modulefield) ')' { RawModDef $2 (desugarize $ concat $3) }
     | modulefield1 list(modulefield) { RawModDef Nothing (desugarize $ $1 ++ concat $2) }

src/Language/Wasm/Validate.hs

@@ -510,7 +510,8 @@ globalsShouldBeValid m@Module { imports, globals } =
             let check = runChecker ctx $ do
                     isConstExpression init
                     t <- getExpressionType init
-                    return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch (empty ==> I32) t
+                    let expected = empty ==> getGlobalType gt
+                    return $ if isArrowMatch expected t then Valid else TypeMismatch t expected
             in
             case check of
                 Left err -> err
@@ -526,7 +527,7 @@ 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 (empty ==> I32) t
+                    return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) 
             in
             let isIniterValid = case check of
                     Left err -> err
@@ -552,7 +553,7 @@ 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 (empty ==> I32) t
+                    return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) 
             in
             let isOffsetValid = case check of
                     Left err -> err

tests/Test.hs

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