add fundeps to infer monad instance from producer

.gitignore

@@ -1,2 +1,3 @@
 .stack-work
-tests/runnable/*
+tests/runnable/*
+dist/

exec/Main.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+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.Parser as Parser
+import qualified Language.Wasm.Binary as Binary
+
+import Options.Applicative
+import Data.Semigroup ((<>))
+
+{-
+wasm compile INPUT -o output -f js -f binary
+wasm exec --script INPUT
+wasm validate INPUT -f binary -f text
+wasm link 
+-}
+
+data CompileOutFormat = OutJS | OutBinary | OutHTML deriving (Eq)
+data ExecMod = Plain | Script deriving (Show, Eq)
+data Input = InpText | InpBinary deriving (Eq)
+
+instance Read CompileOutFormat where
+  readsPrec _ "js" = [(OutJS, "")]
+  readsPrec _ "binary" = [(OutBinary, "")]
+  readsPrec _ "html" = [(OutHTML, "")]
+  readsPrec _ _ = error "Unknown compilation output foramt"
+
+instance Show CompileOutFormat where
+  show OutJS = "js"
+  show OutBinary = "binary"
+  show OutHTML = "html"
+
+instance Read Input where
+  readsPrec _ "text" = [(InpText, "")]
+  readsPrec _ "binary" = [(InpBinary, "")]
+  readsPrec _ _ = error "Unknown validation input foramt"
+
+instance Show Input where
+  show InpText = "text"
+  show InpBinary = "binary"
+
+data WasmCommand
+  = Compile {
+    input :: String,
+    output :: String,
+    outFormat :: CompileOutFormat
+  }
+  | Exec {
+    input :: String,
+    mode :: ExecMod,
+    inpFormat :: Input
+  }
+  | Validate {
+    input :: String,
+    inpFormat :: Input
+  }
+  deriving (Show, Eq)
+
+compileArgs = Compile
+  <$> argument str (metavar "FILE")
+  <*> strOption (
+      long "out"
+      <> short 'o'
+      <> metavar "FILE"
+      <> help "Distination for compilation"
+    )
+  <*> option auto (
+      long "format"
+      <> short 'f'
+      <> help "Output file format"
+      <> showDefault
+      <> value OutBinary
+    )
+
+execArgs = Exec
+  <$> argument str (metavar "FILE")
+  <*> flag Plain Script (long "script" <> help "Execute file in script mode")
+  <*> option auto (
+    long "format"
+    <> short 'f'
+    <> help "Input file format"
+    <> showDefault
+    <> value InpText
+  )
+
+validateArgs = Validate
+  <$> argument str (metavar "FILE")
+  <*> option auto (
+      long "format"
+      <> short 'f'
+      <> help "Input file format"
+      <> showDefault
+      <> value InpText
+    )
+
+config :: Parser WasmCommand
+config = subparser (
+    command "compile" (info compileArgs (progDesc "Compile WebAssembly file from text representation"))
+    <> command "exec" (info execArgs (progDesc "Compile WebAssembly file if needed and execute"))
+    <> command "validate" (info validateArgs (progDesc "Validate WebAssembly file"))
+  )
+
+toBinary :: LBS.ByteString -> Either String LBS.ByteString
+toBinary content = do
+    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
+  content <- LBS.readFile input
+  case toBinary content of
+    Right binary ->
+      LBS.writeFile output $ transform binary
+    Left reason ->
+      putStrLn $ "Cannot complie module: " ++ reason
+
+binary :: LBS.ByteString -> LBS.ByteString
+binary = id
+
+js :: LBS.ByteString -> LBS.ByteString
+js binary =
+    let asBase64 = Base64.encode binary in
+    LBS.concat [
+      "const bytes = Uint8Array.from(atob('" <> asBase64 <> "'), c => c.charCodeAt(0));\n",
+      "WebAssembly.instantiate(bytes, {}).then(res => console.log(res.instance))\n"
+    ]
+
+html :: LBS.ByteString -> LBS.ByteString
+html binary =
+    LBS.concat [
+      "<script>\n",
+      js binary,
+      "</script>\n"
+    ]
+
+exec :: WasmCommand -> IO ()
+exec (Compile inp out OutBinary) = compileAs binary inp out
+exec (Compile inp out OutJS) = compileAs js inp out
+exec (Compile inp out OutHTML) = compileAs html inp out
+exec command = putStrLn $ "command is not implemented yet: " ++ show command
+
+main :: IO ()
+main = execParser opts >>= exec
+  where
+    opts = info (config <**> helper)
+      (fullDesc
+        <> progDesc "WebAssembly Toolkit"
+        <> header "This tool can compile text representation to binary format, validate module in text or binary representation and so on.")

src/Language/Wasm/Binary.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Language.Wasm.Binary (
     dumpModule,
@@ -12,14 +13,26 @@ import Language.Wasm.Structure
 
 import Numeric.Natural (Natural)
 import Data.Bits
-import Data.Word (Word8)
-import Data.Int (Int8)
+import Data.Word (Word8, Word32, Word64)
+import Data.Int (Int8, Int32, Int64)
 import Data.Serialize
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLEncoding
 
+asInt32 :: Word32 -> Int32
+asInt32 w =
+    if w < 0x80000000
+    then fromIntegral w
+    else -1 * fromIntegral (0xFFFFFFFF - w + 1)
+
+asInt64 :: Word64 -> Int64
+asInt64 w =
+    if w < 0x8000000000000000
+    then fromIntegral w
+    else -1 * fromIntegral (0xFFFFFFFFFFFFFFFF - w + 1)
+
 getULEB128 :: (Integral a, Bits a) => Int -> Get a
 getULEB128 bitsBudget = do
     if bitsBudget > 0 then return () else fail "integer representation too long"
@@ -282,10 +295,13 @@ instance Serialize Index where
     get = Index <$> getULEB128 32
 
 instance Serialize MemArg where
-    put (MemArg align offset) = putULEB128 align >> putULEB128 offset
-    get = MemArg <$> getULEB128 32 <*> getULEB128 32
+    put MemArg { align, offset } = putULEB128 align >> putULEB128 offset
+    get = do
+        align <- getULEB128 32
+        offset <- getULEB128 32
+        return $ MemArg { align, offset }
 
-instance Serialize Instruction where
+instance Serialize (Instruction Natural) where
     put Unreachable = putWord8 0x00
     put Nop = putWord8 0x01
     put (Block result body) = do
@@ -296,13 +312,13 @@ instance Serialize Instruction where
         putWord8 0x03
         putResultType result
         putExpression body
-    put If {result, true, false = []} = do
+    put If {resultType, true, false = []} = do
         putWord8 0x04
-        putResultType result
+        putResultType resultType
         putExpression true
-    put If {result, true, false} = do
+    put If {resultType, true, false} = do
         putWord8 0x04
-        putResultType result
+        putResultType resultType
         mapM_ put true
         putWord8 0x05 -- ELSE
         putExpression false
@@ -348,8 +364,8 @@ instance Serialize Instruction where
     put CurrentMemory = putWord8 0x3F >> putWord8 0x00
     put GrowMemory = putWord8 0x40 >> putWord8 0x00
     -- Numeric instructions
-    put (I32Const val) = putWord8 0x41 >> putSLEB128 val
-    put (I64Const val) = putWord8 0x42 >> putSLEB128 val
+    put (I32Const val) = putWord8 0x41 >> putSLEB128 (asInt32 val)
+    put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val)
     put (F32Const val) = putWord8 0x43 >> putFloat32le val
     put (F64Const val) = putWord8 0x44 >> putFloat64le val
     put I32Eqz = putWord8 0x45
@@ -670,7 +686,7 @@ putExpression expr = do
 getExpression :: Get Expression
 getExpression = go []
     where
-        go :: [Instruction] -> Get Expression
+        go :: Expression -> Get Expression
         go acc = do
             nextByte <- lookAhead getWord8
             if nextByte == 0x0B -- END OF EXPR
@@ -680,7 +696,7 @@ getExpression = go []
 getTrueBranch :: Get (Expression, Bool)
 getTrueBranch = go []
     where
-        go :: [Instruction] -> Get (Expression, Bool)
+        go :: Expression -> Get (Expression, Bool)
         go acc = do
             nextByte <- lookAhead getWord8
             case nextByte of

src/Language/Wasm/Builder.hs

@@ -0,0 +1,859 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Language.Wasm.Builder (
+    GenMod,
+    genMod,
+    global, typedef, fun, funRec, table, memory, dataSegment,
+    importFunction, importGlobal, importMemory, importTable,
+    export,
+    nextFuncIndex, setGlobalInitializer,
+    GenFun,
+    Glob, Loc, Fn(..), Mem, Tbl,
+    param, local, label,
+    ret,
+    arg,
+    i32, i64, f32, f64,
+    i32c, i64c, f32c, f64c,
+    add, {-inc,-} sub, {-dec,-} mul, div_u, div_s, rem_u, rem_s, and, or, xor, shl, shr_u, shr_s, rotl, rotr,
+    eq, ne, lt_s, lt_u, gt_s, gt_u, le_s, le_u, ge_s, ge_u,
+    eqz,
+    extend_s, extend_u, wrap,
+    load, load8_u, load8_s, load16_u, load16_s, load32_u, load32_s,
+    store, store8, store16, store32,
+    nop,
+    call, finish,
+    if', loop, block, when, for, while,
+    trap, unreachable,
+    appendExpr, after,
+    Producer, OutType, produce, Consumer, (.=)
+) where
+
+import Prelude hiding (and, or)
+import qualified Data.List as List
+import qualified Data.Maybe as Maybe
+import Control.Monad.State (State, execState, get, gets, put, modify)
+import Control.Monad.Reader (ReaderT, ask, runReaderT, withReaderT)
+import Numeric.Natural
+import Data.Word (Word32, Word64)
+import Data.Int (Int32, Int64)
+import Data.Proxy
+
+import qualified Data.Text.Lazy as TL
+import qualified Data.ByteString.Lazy as LBS
+
+import Language.Wasm.Structure
+
+data FuncDef = FuncDef {
+    args :: [ValueType],
+    returns :: [ValueType],
+    locals :: [ValueType],
+    instrs :: Expression
+} deriving (Show, Eq)
+
+newtype GenFun a = GenFun { unGenFun :: ReaderT Natural (State FuncDef) a } deriving (Functor, Applicative, Monad)
+
+newtype Loc m (t :: ValueType) = Loc Natural deriving (Show, Eq)
+
+class (Monad m) => GenFunMonad m where
+    appendExpr :: Expression -> m ()
+    inner :: m a -> m Expression
+    param :: (ValueTypeable t) => Proxy t -> m (Loc m t)
+    local :: (ValueTypeable t) => Proxy t -> m (Loc m t)
+    deep :: m Natural
+
+instance GenFunMonad GenFun where
+    appendExpr expr = do
+        GenFun $ modify $ \def -> def { instrs = instrs def ++ expr }
+        return ()
+
+    inner (GenFun subExpr) = GenFun $ do
+        stateBefore <- get
+        res <- withReaderT (+1) $ do
+            subExpr
+            gets instrs
+        put stateBefore
+        return res
+
+    param t = GenFun $ do
+        f@FuncDef { args } <- get
+        put $ f { args = args ++ [getValueType t] }
+        return $ Loc $ fromIntegral $ length args
+
+    local t = GenFun $ do
+        f@FuncDef { args, locals } <- get
+        put $ f { locals = locals ++ [getValueType t]}
+        return $ Loc $ fromIntegral $ length args + length locals
+    
+    deep = GenFun ask
+
+after :: (GenFunMonad m) => Expression -> m a -> m a
+after instr expr = do
+    res <- expr
+    appendExpr instr
+    return res
+
+data TypedExpr m
+    = ExprI32 (m (Proxy I32))
+    | ExprI64 (m (Proxy I64))
+    | ExprF32 (m (Proxy F32))
+    | ExprF64 (m (Proxy F64))
+
+class (GenFunMonad m) => Producer m expr | expr -> m where
+    type OutType expr
+    asTypedExpr :: expr -> TypedExpr m
+    produce :: expr -> m (OutType expr)
+
+instance (GenFunMonad m, ValueTypeable t) => Producer m (Loc m t) where
+    type OutType (Loc m t) = Proxy t
+    asTypedExpr e = case getValueType (t e) of
+        I32 -> ExprI32 (produce e >> return Proxy)
+        I64 -> ExprI64 (produce e >> return Proxy)
+        F32 -> ExprF32 (produce e >> return Proxy)
+        F64 -> ExprF64 (produce e >> return Proxy)
+        where
+            t :: Loc m t -> Proxy t
+            t _ = Proxy
+    produce (Loc i) = appendExpr [GetLocal i] >> return Proxy
+
+instance (GenFunMonad m, ValueTypeable t) => Producer m (Glob m mut t) where
+    type OutType (Glob m mut t) = Proxy t
+    asTypedExpr e = case getValueType (t e) of
+        I32 -> ExprI32 (produce e >> return Proxy)
+        I64 -> ExprI64 (produce e >> return Proxy)
+        F32 -> ExprF32 (produce e >> return Proxy)
+        F64 -> ExprF64 (produce e >> return Proxy)
+        where
+            t :: Glob m mut t -> Proxy t
+            t _ = Proxy
+    produce (Glob i) = appendExpr [GetGlobal i] >> return Proxy
+
+instance (GenFunMonad m, ValueTypeable t) => Producer m (m (Proxy t)) where
+    type OutType (m (Proxy t)) = Proxy t
+    asTypedExpr e = case getValueType (t e) of
+        I32 -> ExprI32 (produce e >> return Proxy)
+        I64 -> ExprI64 (produce e >> return Proxy)
+        F32 -> ExprF32 (produce e >> return Proxy)
+        F64 -> ExprF64 (produce e >> return Proxy)
+        where
+            t :: (GenFunMonad m) => m (Proxy t) -> Proxy t
+            t _ = Proxy
+    produce = id
+
+ret :: (Producer m expr) => expr -> m (OutType expr)
+ret = produce
+
+arg :: (Producer m expr) => expr -> m ()
+arg e = produce e >> return ()
+
+getSize :: ValueType -> BitSize
+getSize I32 = BS32
+getSize I64 = BS64
+getSize F32 = BS32
+getSize F64 = BS64
+
+type family IsInt i :: Bool where
+    IsInt (Proxy I32) = True
+    IsInt (Proxy I64) = True
+    IsInt any         = False
+
+nop :: (GenFunMonad m) => m ()
+nop = appendExpr [Nop]
+
+asValueType :: forall m a . (GenFunMonad m, Producer m a) => a -> ValueType
+asValueType a = case asTypedExpr @m a of
+    ExprI32 e -> I32
+    ExprI64 e -> I64
+    ExprF32 e -> F32
+    ExprF64 e -> F64
+
+iBinOp :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => IBinOp -> a -> b -> m (OutType a)
+iBinOp op a b = produce a >> after [IBinOp (getSize $ asValueType @m a) op] (produce b)
+
+add :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
+add a b = do
+    produce a
+    case asValueType @m a of
+        I32 -> after [IBinOp BS32 IAdd] (produce b)
+        I64 -> after [IBinOp BS64 IAdd] (produce b)
+        F32 -> after [FBinOp BS32 FAdd] (produce b)
+        F64 -> after [FBinOp BS64 FAdd] (produce b)
+
+-- inc :: (GenFunMonad m, Consumer m a, Producer m a, Integral i) => i -> a -> m ()
+-- inc i a = case asTypedExpr a of
+--     ExprI32 e -> a .= (e `add` i32c i)
+--     ExprI64 e -> a .= (e `add` i64c i)
+--     ExprF32 e -> a .= (e `add` f32c (fromIntegral i))
+--     ExprF64 e -> a .= (e `add` f64c (fromIntegral i))
+
+sub :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
+sub a b = do
+    produce a
+    case asValueType @m a of
+        I32 -> after [IBinOp BS32 ISub] (produce b)
+        I64 -> after [IBinOp BS64 ISub] (produce b)
+        F32 -> after [FBinOp BS32 FSub] (produce b)
+        F64 -> after [FBinOp BS64 FSub] (produce b)
+
+
+-- dec :: (GenFunMonad m, Consumer m a, Producer m a, Integral i) => i -> a -> m ()
+-- dec i a = case asTypedExpr a of
+--     ExprI32 e -> a .= (e `sub` i32c i)
+--     ExprI64 e -> a .= (e `sub` i64c i)
+--     ExprF32 e -> a .= (e `sub` f32c (fromIntegral i))
+--     ExprF64 e -> a .= (e `sub` f64c (fromIntegral i))
+
+mul :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
+mul a b = do
+    produce a
+    case asValueType @m a of
+        I32 -> after [IBinOp BS32 IMul] (produce b)
+        I64 -> after [IBinOp BS64 IMul] (produce b)
+        F32 -> after [FBinOp BS32 FMul] (produce b)
+        F64 -> after [FBinOp BS64 FMul] (produce b)
+
+div_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+div_u = iBinOp IDivU
+
+div_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+div_s = iBinOp IDivS
+
+rem_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+rem_u = iBinOp IRemU
+
+rem_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+rem_s = iBinOp IRemS
+
+and :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+and = iBinOp IAnd
+
+or :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+or = iBinOp IOr
+
+xor :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+xor = iBinOp IXor
+
+shl :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+shl = iBinOp IShl
+
+shr_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+shr_u = iBinOp IShrU
+
+shr_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+shr_s = iBinOp IShrS
+
+rotl :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+rotl = iBinOp IRotl
+
+rotr :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
+rotr = iBinOp IRotr 
+
+relOp :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => IRelOp -> a -> b -> m (Proxy I32)
+relOp op a b = do
+    produce a
+    produce b
+    appendExpr [IRelOp (getSize $ asValueType @m a) op]
+    return Proxy
+
+eq :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (Proxy I32)
+eq a b = do
+    produce a
+    produce b
+    case asValueType @m a of
+        I32 -> appendExpr [IRelOp BS32 IEq]
+        I64 -> appendExpr [IRelOp BS64 IEq]
+        F32 -> appendExpr [FRelOp BS32 FEq]
+        F64 -> appendExpr [FRelOp BS64 FEq]
+    return Proxy
+
+ne :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (Proxy I32)
+ne a b = do
+    produce a
+    produce b
+    case asValueType @m a of
+        I32 -> appendExpr [IRelOp BS32 INe]
+        I64 -> appendExpr [IRelOp BS64 INe]
+        F32 -> appendExpr [FRelOp BS32 FNe]
+        F64 -> appendExpr [FRelOp BS64 FNe]
+    return Proxy
+
+lt_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+lt_s = relOp ILtS
+
+lt_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+lt_u = relOp ILtS
+
+gt_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+gt_s = relOp IGtS
+
+gt_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+gt_u = relOp IGtU
+
+le_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+le_s = relOp ILeS
+
+le_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+le_u = relOp ILeS
+
+ge_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+ge_s = relOp IGeS
+
+ge_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
+ge_u = relOp IGeU
+
+eqz :: forall m a . (GenFunMonad m, Producer m a, IsInt (OutType a) ~ True) => a -> m (Proxy I32)
+eqz a = do
+    produce a
+    case asValueType @m a of
+        I32 -> appendExpr [I32Eqz]
+        I64 -> appendExpr [I64Eqz]
+        _ -> error "Impossible by type constraint"
+    return Proxy
+
+i32c :: (GenFunMonad m, Integral i) => i -> m (Proxy I32)
+i32c i = appendExpr [I32Const $ asWord32 $ fromIntegral i] >> return Proxy
+
+i64c :: (GenFunMonad m, Integral i) => i -> m (Proxy I64)
+i64c i = appendExpr [I64Const $ asWord64 $ fromIntegral i] >> return Proxy
+
+f32c :: (GenFunMonad m) => Float -> m (Proxy F32)
+f32c f = appendExpr [F32Const f] >> return Proxy
+
+f64c :: (GenFunMonad m) => Double -> m (Proxy F64)
+f64c d = appendExpr [F64Const d] >> return Proxy
+
+extend_u :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I32) => i -> m (Proxy I64)
+extend_u small = do
+    produce small
+    appendExpr [I64ExtendUI32]
+    return Proxy
+
+extend_s :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I32) => i -> m (Proxy I64)
+extend_s small = do
+    produce small
+    appendExpr [I64ExtendUI32]
+    return Proxy
+
+wrap :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I64) => i -> m (Proxy I32)
+wrap big = do
+    produce big
+    appendExpr [I32WrapI64]
+    return Proxy
+
+load :: (GenFunMonad m, ValueTypeable t, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load t addr offset align = do
+    produce addr
+    case getValueType t of
+        I32 -> appendExpr [I32Load $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Load $ MemArg (fromIntegral offset) (fromIntegral align)]
+        F32 -> appendExpr [F32Load $ MemArg (fromIntegral offset) (fromIntegral align)]
+        F64 -> appendExpr [F64Load $ MemArg (fromIntegral offset) (fromIntegral align)]
+    return Proxy
+
+load8_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load8_u t addr offset align = do
+    produce addr
+    case getValueType t of
+        I32 -> appendExpr [I32Load8U $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Load8U $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+    return Proxy
+
+load8_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load8_s t addr offset align = do
+    produce addr
+    case getValueType t of
+        I32 -> appendExpr [I32Load8S $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Load8S $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+    return Proxy
+
+load16_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load16_u t addr offset align = do
+    produce addr
+    case getValueType t of
+        I32 -> appendExpr [I32Load16U $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Load16U $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+    return Proxy
+
+load16_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load16_s t addr offset align = do
+    produce addr
+    case getValueType t of
+        I32 -> appendExpr [I32Load16S $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Load16S $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+    return Proxy
+
+load32_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load32_u t addr offset align = do
+    produce addr
+    appendExpr [I64Load32U $ MemArg (fromIntegral offset) (fromIntegral align)]
+    return Proxy
+
+load32_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
+    => Proxy t
+    -> addr
+    -> offset
+    -> align
+    -> m (Proxy t)
+load32_s t addr offset align = do
+    produce addr
+    appendExpr [I64Load32S $ MemArg (fromIntegral offset) (fromIntegral align)]
+    return Proxy
+
+store :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, Integral offset, Integral align)
+    => addr
+    -> val
+    -> offset
+    -> align
+    -> m ()
+store addr val offset align = do
+    produce addr
+    produce val
+    case asValueType @m val of
+        I32 -> appendExpr [I32Store $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Store $ MemArg (fromIntegral offset) (fromIntegral align)]
+        F32 -> appendExpr [F32Store $ MemArg (fromIntegral offset) (fromIntegral align)]
+        F64 -> appendExpr [F64Store $ MemArg (fromIntegral offset) (fromIntegral align)]
+
+store8 :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, IsInt (OutType val) ~ True, Integral offset, Integral align)
+    => addr
+    -> val
+    -> offset
+    -> align
+    -> m ()
+store8 addr val offset align = do
+    produce addr
+    produce val
+    case asValueType @m val of
+        I32 -> appendExpr [I32Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+
+store16 :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, IsInt (OutType val) ~ True, Integral offset, Integral align)
+    => addr
+    -> val
+    -> offset
+    -> align
+    -> m ()
+store16 addr val offset align = do
+    produce addr
+    produce val
+    case asValueType @m val of
+        I32 -> appendExpr [I32Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
+        I64 -> appendExpr [I64Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
+        _ -> error "Impossible by type constraint"
+
+store32 :: (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, OutType val ~ Proxy I64, Integral offset, Integral align)
+    => addr
+    -> val
+    -> offset
+    -> align
+    -> m ()
+store32 addr val offset align = do
+    produce addr
+    produce val
+    appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)]
+
+call :: (GenFunMonad m, Returnable res) => Fn res -> [m a] -> m res
+call (Fn idx) args = sequence_ args >> appendExpr [Call idx] >> return returnableValue
+
+br :: (GenFunMonad m) => Label t -> m ()
+br (Label labelDeep) = do
+    d <- deep
+    appendExpr [Br $ d - labelDeep]
+
+finish :: (GenFunMonad m, Producer m val) => val -> m ()
+finish val = do
+    produce val
+    appendExpr [Return]
+
+newtype Label i = Label Natural deriving (Show, Eq)
+
+when :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32)
+    => pred
+    -> m ()
+    -> m ()
+when pred body = if' () pred body (return ())
+
+for :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32) => m () -> pred -> m () -> m () -> m ()
+for initer pred after body = do
+    initer
+    let loopBody = do
+            body
+            after
+            loopLabel <- label
+            if' () pred (br loopLabel) (return ())
+    if' () pred (loop () loopBody) (return ())
+
+while :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32) => pred -> m () -> m ()
+while pred body = do
+    let loopBody = do
+            body
+            loopLabel <- label
+            if' () pred (br loopLabel) (return ())
+    if' () pred (loop () loopBody) (return ())
+
+label :: (GenFunMonad m) => m (Label t)
+label = Label <$> deep
+
+if' :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32, Returnable res)
+    => res
+    -> pred
+    -> m res
+    -> m res
+    -> m res
+if' res pred true false = do
+    produce pred
+    t <- inner true
+    f <- inner false
+    appendExpr [If (asResultValue res) t f]
+    return returnableValue
+
+loop :: (GenFunMonad m, Returnable res) => res -> m res -> m res
+loop res body = do
+    b <- inner body
+    appendExpr [Loop (asResultValue res) b]
+    return returnableValue
+
+block :: (GenFunMonad m, Returnable res) => res -> m res -> m res
+block res body = do
+    b <- inner body
+    appendExpr [Block (asResultValue res) b]
+    return returnableValue
+
+trap :: (GenFunMonad m) => Proxy t -> m (Proxy t)
+trap t = do
+    appendExpr [Unreachable]
+    return t
+
+unreachable :: (GenFunMonad m) => m ()
+unreachable = appendExpr [Unreachable]
+
+class Consumer loc where
+    type InputType loc
+    infixr 2 .=
+    (.=) :: (GenFunMonad m, Producer m expr, InputType loc ~ OutType expr) => loc -> expr -> m ()
+
+instance (GenFunMonad m) => Consumer (Loc m t) where
+    type InputType (Loc m t) = Proxy t
+    (.=) (Loc i) expr = produce expr >> appendExpr [SetLocal i]
+
+instance (GenFunMonad m) => Consumer (Glob m M t) where
+    type InputType (Glob m M t) = Proxy t
+    (.=) (Glob i) expr = produce expr >> appendExpr [SetGlobal i]
+
+typedef :: FuncType -> GenMod Natural
+typedef t = do
+    st@GenModState { target = m@Module { types } } <- get
+    let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types
+    put $ st { target = m { types = inserted } }
+    return $ fromIntegral idx
+
+newtype Fn a = Fn Natural deriving (Show, Eq)
+
+class Returnable a where
+    asResultValue :: a -> [ValueType]
+    returnableValue :: a
+
+instance (ValueTypeable t) => Returnable (Proxy t) where
+    asResultValue t = [getValueType t]
+    returnableValue = Proxy
+
+instance Returnable () where
+    asResultValue _ = []
+    returnableValue = ()
+
+funRec :: (Returnable res) => res -> (Fn res -> GenFun res) -> GenMod (Fn res)
+funRec res generator = do
+    st@GenModState { target = m@Module { types, functions }, funcIdx } <- get
+    let GenFun gen = generator (Fn funcIdx)
+    let FuncDef { args, locals, instrs } = execState (runReaderT gen 0) $ FuncDef [] [] [] []
+    let t = FuncType args (asResultValue res)
+    let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types
+    put $ st {
+        target = m { functions = functions ++ [Function (fromIntegral idx) locals instrs], types = inserted },
+        funcIdx = funcIdx + 1
+    }
+    return $ Fn funcIdx
+
+fun :: (Returnable res) => res -> GenFun res -> GenMod (Fn res)
+fun res = funRec res . const
+
+nextFuncIndex :: GenMod Natural
+nextFuncIndex = gets funcIdx
+
+data GenModState = GenModState {
+    funcIdx :: Natural,
+    globIdx :: Natural,
+    target :: Module
+} deriving (Show, Eq)
+
+type GenMod = State GenModState
+
+genMod :: GenMod a -> Module
+genMod = target . flip execState (GenModState 0 0 emptyModule)
+
+importFunction :: (Returnable res) => TL.Text -> TL.Text -> res -> [ValueType] -> GenMod (Fn res)
+importFunction mod name res params = do
+    st@GenModState { target = m@Module { types, imports }, funcIdx } <- get
+    let t = FuncType params (asResultValue res)
+    let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types
+    put $ st {
+        target = m { imports = imports ++ [Import mod name $ ImportFunc $ fromIntegral idx], types = inserted },
+        funcIdx = funcIdx + 1
+    }
+    return (Fn funcIdx)
+
+importGlobal :: (ValueTypeable t) => TL.Text -> TL.Text -> Proxy t -> (forall m . GenFunMonad m => GenMod (Glob m C t))
+importGlobal mod name t = do
+    st@GenModState { target = m@Module { imports }, globIdx } <- get
+    put $ st {
+        target = m { imports = imports ++ [Import mod name $ ImportGlobal $ Const $ getValueType t] },
+        globIdx = globIdx + 1
+    }
+    return $ Glob globIdx
+
+importMemory :: TL.Text -> TL.Text -> Natural -> Maybe Natural -> GenMod Mem
+importMemory mod name min max = do
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { imports = imports m ++ [Import mod name $ ImportMemory $ Limit min max] }
+    }
+    return $ Mem 0
+
+importTable :: TL.Text -> TL.Text -> Natural -> Maybe Natural -> GenMod Tbl
+importTable mod name min max = do
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { imports = imports m ++ [Import mod name $ ImportTable $ TableType (Limit min max) AnyFunc] }
+    }
+    return $ Tbl 0
+
+class Exportable e where
+    type AfterExport e
+    export :: TL.Text -> e -> GenMod (AfterExport e)
+
+instance (Exportable e) => Exportable (GenMod e) where
+    type AfterExport (GenMod e) = AfterExport e
+    export name def = do
+        ent <- def
+        export name ent
+
+instance Exportable (Fn t) where
+    type AfterExport (Fn t) = Fn t
+    export name (Fn funIdx) = do
+        modify $ \(st@GenModState { target = m }) -> st {
+            target = m { exports = exports m ++ [Export name $ ExportFunc funIdx] }
+        }
+        return (Fn funIdx)
+
+instance Exportable (Glob m C t) where
+    type AfterExport (Glob m C t) = Glob m C t
+    export name g@(Glob idx) = do
+        modify $ \(st@GenModState { target = m }) -> st {
+            target = m { exports = exports m ++ [Export name $ ExportGlobal idx] }
+        }
+        return g
+
+instance Exportable Mem where
+    type AfterExport Mem = Mem
+    export name (Mem memIdx) = do
+        modify $ \(st@GenModState { target = m }) -> st {
+            target = m { exports = exports m ++ [Export name $ ExportMemory memIdx] }
+        }
+        return (Mem memIdx)
+
+instance Exportable Tbl where
+    type AfterExport Tbl = Tbl
+    export name (Tbl tableIdx) = do
+        modify $ \(st@GenModState { target = m }) -> st {
+            target = m { exports = exports m ++ [Export name $ ExportTable tableIdx] }
+        }
+        return (Tbl tableIdx)
+
+class ValueTypeable a where
+    type ValType a
+    getValueType :: (Proxy a) -> ValueType
+    initWith :: (Proxy a) -> (ValType a) -> Expression
+
+instance ValueTypeable I32 where
+    type ValType I32 = Word32
+    getValueType _ = I32
+    initWith _ w = [I32Const w]
+
+instance ValueTypeable I64 where
+    type ValType I64 = Word64
+    getValueType _ = I64
+    initWith _ w = [I64Const w]
+
+instance ValueTypeable F32 where
+    type ValType F32 = Float
+    getValueType _ = F32
+    initWith _ f = [F32Const f]
+
+instance ValueTypeable F64 where
+    type ValType F64 = Double
+    getValueType _ = F64
+    initWith _ d = [F64Const d]
+
+i32 = Proxy @I32
+i64 = Proxy @I64
+f32 = Proxy @F32
+f64 = Proxy @F64
+
+data GlobMut = M | C
+
+globMut :: Proxy M
+globMut = Proxy
+
+globConst :: Proxy C
+globConst = Proxy
+
+class GlobalMutability mut where
+    globalTypeCtor :: Proxy mut -> ValueType -> GlobalType
+
+instance GlobalMutability M where
+    globalTypeCtor _ = Mut
+
+instance GlobalMutability C where
+    globalTypeCtor _ = Const
+
+newtype Glob m (mut :: GlobMut) (t :: ValueType) = Glob Natural deriving (Show, Eq)
+
+global :: (ValueTypeable t, GlobalMutability mut) => Proxy mut -> Proxy t -> (ValType t) -> (forall m . GenFunMonad m => GenMod (Glob m mut t))
+global globMut t val = do
+    idx <- gets globIdx
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { globals = globals m ++ [Global (globalTypeCtor globMut $ getValueType t) (initWith t val)] },
+        globIdx = idx + 1
+    }
+    return $ Glob idx
+
+setGlobalInitializer :: forall m t mut . (ValueTypeable t) => Glob m mut t -> (ValType t) -> GenMod ()
+setGlobalInitializer (Glob idx) val = do
+    modify $ \(st@GenModState { target = m }) ->
+        let globImpsLen = length $ filter isGlobalImport $ imports m in
+        let (h, glob:t) = splitAt (fromIntegral idx - globImpsLen) $ globals m in
+        st {
+            target = m { globals = h ++ [glob { initializer = initWith (Proxy @t) val }] ++ t }
+        }
+
+newtype Mem = Mem Natural deriving (Show, Eq)
+
+memory :: Natural -> Maybe Natural -> GenMod Mem
+memory min max = do
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { mems = mems m ++ [Memory $ Limit min max] }
+    }
+    return $ Mem 0
+
+newtype Tbl = Tbl Natural deriving (Show, Eq)
+
+table :: Natural -> Maybe Natural -> GenMod Tbl
+table min max = do
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { tables = tables m ++ [Table $ TableType (Limit min max) AnyFunc] }
+    }
+    return $ Tbl 0
+
+dataSegment :: (Integral offset) => offset -> LBS.ByteString -> GenMod ()
+dataSegment offset bytes =
+    modify $ \(st@GenModState { target = m }) -> st {
+        target = m { datas = datas m ++ [DataSegment 0 [I32Const $ fromIntegral offset] bytes] }
+    }
+
+asWord32 :: Int32 -> Word32
+asWord32 i
+    | i >= 0 = fromIntegral i
+    | otherwise = 0xFFFFFFFF - (fromIntegral (abs i)) + 1
+
+asWord64 :: Int64 -> Word64
+asWord64 i
+    | i >= 0 = fromIntegral i
+    | otherwise = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1
+
+rts :: Module
+rts = genMod $ do
+    gc <- importFunction "rts" "gc" () [I32]
+    memory 10 Nothing
+
+    stackStart <- global globConst i32 0 @GenFun
+    stackEnd <- global globConst i32 0 @GenFun
+    stackBase <- global globMut i32 0 @GenFun
+    stackTop <- global globMut i32 0 @GenFun
+
+    retReg <- global globMut i32 0 @GenFun
+    tmpReg <- global globMut i32 0 @GenFun
+
+    heapStart <- global globMut i32 0 @GenFun
+    heapNext <- global globMut i32 0 @GenFun
+    heapEnd <- global globMut i32 0 @GenFun
+
+    aligned <- fun i32 $ do
+        size <- param i32
+        (size `add` i32c 3) `and` i32c @GenFun 0xFFFFFFFC
+    alloc <- funRec i32 $ \self -> do
+        size <- param i32
+        alignedSize <- local i32
+        addr <- local i32
+        alignedSize .= call aligned [arg size]
+        if' i32 ((heapNext `add` alignedSize) `lt_u` heapEnd)
+            (do
+                addr .= heapNext
+                heapNext .= heapNext `add` alignedSize
+                ret addr
+            )
+            (do
+                call gc []
+                call self [arg size]
+            )
+    return ()

src/Language/Wasm/Interpreter.hs

@@ -431,7 +431,7 @@ getGlobalValue inst store idx =
         GIMut _ ref -> readIORef ref
 
 -- due the validation there can be only these instructions
-evalConstExpr :: ModuleInstance -> Store -> [Instruction] -> IO Value
+evalConstExpr :: ModuleInstance -> Store -> Expression -> IO Value
 evalConstExpr _ _ [I32Const v] = return $ VI32 v
 evalConstExpr _ _ [I64Const v] = return $ VI64 v
 evalConstExpr _ _ [F32Const v] = return $ VF32 v
@@ -442,7 +442,7 @@ evalConstExpr _ _ instrs = error $ "Global initializer contains unsupported inst
 allocAndInitGlobals :: ModuleInstance -> Store -> [Global] -> IO (Vector GlobalInstance)
 allocAndInitGlobals inst store globs = Vector.fromList <$> mapM allocGlob globs
     where
-        runIniter :: [Instruction] -> IO Value
+        runIniter :: Expression -> IO Value
         -- the spec says get global can ref only imported globals
         -- only they are in store for this moment
         runIniter = evalConstExpr inst store
@@ -594,7 +594,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
         initLocal F32 = VF32 0
         initLocal F64 = VF64 0
 
-        go :: EvalCtx -> [Instruction] -> IO EvalResult
+        go :: EvalCtx -> Expression -> IO EvalResult
         go ctx [] = return $ Done ctx
         go ctx (instr:rest) = do
             res <- step ctx instr
@@ -630,7 +630,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
                 return $ Done ctx { stack = rest }
         makeStoreInstr _ _ _ _ = error "Incorrect value on top of stack for memory instruction"
 
-        step :: EvalCtx -> Instruction -> IO EvalResult
+        step :: EvalCtx -> Instruction Natural -> IO EvalResult
         step _ Unreachable = return Trap
         step ctx Nop = return $ Done ctx
         step ctx (Block resType expr) = do

src/Language/Wasm/Parser.y

@@ -1440,8 +1440,6 @@ data Module = Module {
 
 type Script = [Command]
 
-type Expression = [Instruction]
-
 data ModuleDef
     = RawModDef (Maybe Ident) S.Module
     | TextModDef (Maybe Ident) TL.Text
@@ -1457,14 +1455,14 @@ data Command
     deriving (Show, Eq)
 
 data Action
-    = Invoke (Maybe Ident) TL.Text [[S.Instruction]]
+    = Invoke (Maybe Ident) TL.Text [S.Expression]
     | Get (Maybe Ident) TL.Text
     deriving (Show, Eq)
 
 type FailureString = TL.Text
 
 data Assertion
-    = AssertReturn Action [[S.Instruction]]
+    = AssertReturn Action [S.Expression]
     | AssertReturnCanonicalNaN Action
     | AssertReturnArithmeticNaN Action
     | AssertTrap (Either Action ModuleDef) FailureString
@@ -1489,7 +1487,7 @@ data FunCtx = FunCtx {
     ctxParams :: [ParamType]
 } deriving (Eq, Show)
 
-constInstructionToValue :: Instruction -> S.Instruction
+constInstructionToValue :: Instruction -> S.Instruction Natural
 constInstructionToValue (PlainInstr (I32Const v)) = S.I32Const $ integerToWord32 v
 constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v
 constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v
@@ -1639,7 +1637,7 @@ desugarize fields = do
                 Nothing -> Left "unknown label"
 
         -- functions
-        synInstrToStruct :: FunCtx -> Instruction -> Either String S.Instruction
+        synInstrToStruct :: FunCtx -> Instruction -> Either String (S.Instruction Natural)
         synInstrToStruct _ (PlainInstr Unreachable) = return S.Unreachable
         synInstrToStruct _ (PlainInstr Nop) = return S.Nop
         synInstrToStruct ctx (PlainInstr (Br labelIdx)) =

src/Language/Wasm/Script.hs

@@ -106,7 +106,7 @@ runScript onAssertFail script = do
         getModule st (Just (Ident i)) = Map.lookup i (modules st)
         getModule st Nothing = lastModule st
 
-        asArg :: [Struct.Instruction] -> Interpreter.Value
+        asArg :: Struct.Expression -> Interpreter.Value
         asArg [Struct.I32Const v] = Interpreter.VI32 v
         asArg [Struct.F32Const v] = Interpreter.VF32 v
         asArg [Struct.I64Const v] = Interpreter.VI64 v

src/Language/Wasm/Structure.hs

@@ -102,28 +102,28 @@ type LocalsType = [ValueType]
 
 data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq, Generic, NFData)
 
-data Instruction =
+data Instruction index =
     -- Control instructions
     Unreachable
     | Nop
-    | Block { result :: ResultType, body :: Expression }
-    | Loop { result :: ResultType, body :: Expression }
-    | If { result :: ResultType, true :: Expression, false :: Expression }
-    | Br LabelIndex
-    | BrIf LabelIndex
-    | BrTable [LabelIndex] LabelIndex
+    | Block { resultType :: ResultType, body :: Expression }
+    | Loop { resultType :: ResultType, body :: Expression }
+    | If { resultType :: ResultType, true :: Expression, false :: Expression }
+    | Br index
+    | BrIf index
+    | BrTable [index] index
     | Return
-    | Call FuncIndex
-    | CallIndirect TypeIndex
+    | Call index
+    | CallIndirect index
     -- Parametric instructions
     | Drop
     | Select
     -- Variable instructions
-    | GetLocal LocalIndex
-    | SetLocal LocalIndex
-    | TeeLocal LocalIndex
-    | GetGlobal GlobalIndex
-    | SetGlobal GlobalIndex
+    | GetLocal index
+    | SetLocal index
+    | TeeLocal index
+    | GetGlobal index
+    | SetGlobal index
     -- Memory instructions
     | I32Load MemArg
     | I64Load MemArg
@@ -176,7 +176,7 @@ data Instruction =
     | FReinterpretI BitSize
     deriving (Show, Eq, Generic, NFData)
 
-type Expression = [Instruction]
+type Expression = [Instruction Natural]
 
 data Function = Function {
     funcType :: TypeIndex,
@@ -203,7 +203,7 @@ data Global = Global {
 
 data ElemSegment = ElemSegment {
     tableIndex :: TableIndex,
-    offset :: [Instruction],
+    offset :: Expression,
     funcIndexes :: [FuncIndex]
 } deriving (Show, Eq, Generic, NFData)
 

src/Language/Wasm/Validate.hs

@@ -177,27 +177,27 @@ checkMemoryInstr size memarg = do
     Ctx { mems } <- ask 
     if length mems < 1 then throwError MemoryIndexOutOfRange else return ()
 
-getInstrType :: Instruction -> Checker Arrow
+getInstrType :: Instruction Natural -> Checker Arrow
 getInstrType Unreachable = return $ Any ==> Any
 getInstrType Nop = return $ empty ==> empty
-getInstrType Block { result, body } = do
-    let blockType = empty ==> result
-    t <- withLabel result $ getExpressionType body
+getInstrType Block { resultType, body } = do
+    let blockType = empty ==> resultType
+    t <- withLabel resultType $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> result
+    then return $ empty ==> resultType
     else throwError $ TypeMismatch t blockType
-getInstrType Loop { result, body } = do
-    let blockType = empty ==> result
+getInstrType Loop { resultType, body } = do
+    let blockType = empty ==> resultType
     t <- withLabel [] $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> result
+    then return $ empty ==> resultType
     else throwError $ TypeMismatch t blockType
-getInstrType If { result, true, false } = do
-    let blockType = empty ==> result
-    l <- withLabel result $ getExpressionType true
-    r <- withLabel result $ getExpressionType false
+getInstrType If { resultType, true, false } = do
+    let blockType = empty ==> resultType
+    l <- withLabel resultType $ getExpressionType true
+    r <- withLabel resultType $ getExpressionType false
     if isArrowMatch l blockType
-    then (if isArrowMatch r blockType then (return $ I32 ==> result) else (throwError $ TypeMismatch r blockType))
+    then (if isArrowMatch r blockType then (return $ I32 ==> resultType) else (throwError $ TypeMismatch r blockType))
     else throwError $ TypeMismatch l blockType
 getInstrType (Br lbl) = do
     r <- map Val . maybeToList <$> getLabel lbl
@@ -375,10 +375,10 @@ replace :: (Eq a) => a -> a -> [a] -> [a]
 replace _ _ [] = []
 replace x y (v:r) = (if x == v then y else v) : replace x y r
 
-getExpressionType :: [Instruction] -> Checker Arrow
+getExpressionType :: Expression -> Checker Arrow
 getExpressionType = fmap ([] `Arrow`) . foldM go []
     where
-        go :: [VType] -> Instruction -> Checker [VType]
+        go :: [VType] -> Instruction Natural -> Checker [VType]
         go stack instr = do
             (f `Arrow` t) <- getInstrType instr
             matchStack stack (reverse f) t
@@ -397,7 +397,7 @@ getExpressionType = fmap ([] `Arrow`) . foldM go []
         matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` [])
         matchStack _ _ _ = error "inconsistent checker state"
 
-isConstExpression :: [Instruction] -> Checker ()
+isConstExpression :: Expression -> Checker ()
 isConstExpression [] = return ()
 isConstExpression ((I32Const _):rest) = isConstExpression rest
 isConstExpression ((I64Const _):rest) = isConstExpression rest

wasm.cabal

@@ -45,11 +45,22 @@ library
       Language.Wasm.Interpreter
       Language.Wasm.Script
       Language.Wasm.FloatUtils
+      Language.Wasm.Builder
       Language.Wasm
   other-modules:
       Paths_wasm
   default-language: Haskell2010
 
+executable wasm
+  main-is: Main.hs
+  hs-source-dirs: exec
+  build-depends:
+      base >=4.6 && <5.0
+    , wasm ==0.1.0
+    , optparse-applicative >= 0.14
+    , bytestring >=0.10 && <0.11
+    , base64-bytestring >= 1.0
+
 test-suite test
   type: exitcode-stdio-1.0
   main-is: Test.hs