From 75bdf0637f64024fa5f4481ebc9fcd670ae92ea3 Mon Sep 17 00:00:00 2001
From: Ilya Rezvov <ilya.rezvov@revjet.com>
Date: Sun, 18 Feb 2018 19:03:21 -0800
Subject: [PATCH] start binary format support

---
 src/Language/Wasm/Binary.hs    | 120 +++++++++++++++++++++++++++++++++
 src/Language/Wasm/Parser.y     |   2 +-
 src/Language/Wasm/Structure.hs |   1 -
 src/Language/Wasm/Validate.hs  |   8 +++
 wasm.cabal                     |   3 +
 5 files changed, 132 insertions(+), 2 deletions(-)
 create mode 100644 src/Language/Wasm/Binary.hs
 create mode 100644 src/Language/Wasm/Validate.hs

diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs
new file mode 100644
index 0000000..1a4929f
--- /dev/null
+++ b/src/Language/Wasm/Binary.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Language.Wasm.Binary (
+    
+) where
+
+import Language.Wasm.Structure
+
+import Numeric.Natural (Natural)
+import Data.Bits
+import Data.Word (Word8)
+import Data.Serialize
+import qualified Data.ByteString as BS
+
+putULEB128 :: Natural -> Put
+putULEB128 val =
+    if val < 128
+    then putWord8 $ fromIntegral val
+    else do
+        putWord8 $ 0x80 + (0x7F .&. fromIntegral val)
+        putULEB128 $ val `shiftR` 7
+
+getULEB128 :: Get Natural
+getULEB128 = do
+    val <- getWord8
+    if val < 2 ^ 7
+    then return $ fromIntegral val
+    else do
+        rest <- getULEB128
+        return $ (fromIntegral $ 0x7F .&. val) + 128 * rest
+
+putVec :: Serialize a => [a] -> Put
+putVec list = do
+    putULEB128 $ fromIntegral $ length list
+    mapM put list
+    return ()
+
+getVec :: Serialize a => Get [a]
+getVec = do
+    len <- getULEB128
+    sequence $ replicate (fromIntegral len) get
+
+byteGuard :: Word8 -> Get ()
+byteGuard expected = do
+    byte <- getWord8
+    if byte == expected
+    then return ()
+    else fail $ "Expected " ++ show expected ++ ", but encountered " ++ show byte
+
+putSection :: Serialize a => SectionType -> a -> Put
+putSection section content = do
+    put section
+    let payload = encode content
+    putULEB128 $ fromIntegral $ BS.length payload
+    putByteString payload
+
+data SectionType =
+    CustomSection
+    | TypeSection
+    | ImportSection
+    | FunctionSection
+    | TableSection
+    | MemorySection
+    | GlobalSection
+    | ExportSection
+    | StartSection
+    | ElementSection
+    | CodeSection
+    | DataSection
+    deriving (Eq, Show, Enum)
+
+instance Serialize SectionType where
+    put section = putWord8 $ fromIntegral $ fromEnum section
+    get = do
+        op <- fromIntegral `fmap` getWord8
+        if op <= fromEnum DataSection
+        then return $ toEnum op
+        else fail "Unexpected byte in section type position"
+
+instance Serialize ValueType where
+    put I32 = putWord8 0x7F
+    put I64 = putWord8 0x7E
+    put F32 = putWord8 0x7D
+    put F64 = putWord8 0x7C
+
+    get = do
+        op <- getWord8
+        case op of
+            0x7F -> return I32
+            0x7E -> return I64
+            0x7D -> return F32
+            0x7C -> return F64
+            _ -> fail "unexpected byte in value type position"
+
+instance Serialize FuncType where
+    put FuncType {params, results} = do
+        putWord8 0x60
+        putVec params
+        putVec results
+    get = do
+        byteGuard 0x60
+        params <- getVec 
+        results <- getVec
+        return $ FuncType { params, results }
+
+instance Serialize Module where
+    put mod = do
+        -- magic
+        putWord8 0x00
+        putWord8 0x61
+        putWord8 0x73
+        putWord8 0x6D
+        -- version
+        putWord8 0x01
+        putWord8 0x00
+        putWord8 0x00
+        putWord8 0x00
+
+        putSection TypeSection $ types mod
+    get = undefined
\ No newline at end of file
diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y
index a34853b..125e543 100644
--- a/src/Language/Wasm/Parser.y
+++ b/src/Language/Wasm/Parser.y
@@ -1172,7 +1172,7 @@ desugarize fields =
         start = extractStart fields,
         exports = []
     } in
-    S.emptyModule {
+    S.Module {
         S.types = map synTypeDefToStruct $ types mod,
         S.functions = map (synFunctionToStruct mod) $ functions mod,
         S.tables = map synTableToStruct $ tables mod,
diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs
index 20639e6..d31e01e 100644
--- a/src/Language/Wasm/Structure.hs
+++ b/src/Language/Wasm/Structure.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module Language.Wasm.Structure (
diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs
new file mode 100644
index 0000000..3542e57
--- /dev/null
+++ b/src/Language/Wasm/Validate.hs
@@ -0,0 +1,8 @@
+module Language.Wasm.Validate (
+    validate
+) where
+
+import Language.Wasm.Structure
+
+validate :: Module -> Either String Module
+validate mod = Right mod
\ No newline at end of file
diff --git a/wasm.cabal b/wasm.cabal
index 6073dde..c08ea56 100644
--- a/wasm.cabal
+++ b/wasm.cabal
@@ -29,6 +29,7 @@ library
     , text >=1.1
     , transformers >=0.4 && <0.6
     , utf8-string >=1.0
+    , cereal >= 0.5
   build-tools:
       alex >=3.1.3
     , happy >=1.9.4
@@ -36,6 +37,8 @@ library
       Language.Wasm.Lexer
       Language.Wasm.Parser
       Language.Wasm.Structure
+      Language.Wasm.Binary
+      Language.Wasm.Validate
       Language.Wasm
   other-modules:
       Paths_wasm