add input and output commands parsing and call compilation

.gitignore

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

exec/Main.hs

@@ -2,8 +2,6 @@
 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
@@ -11,143 +9,43 @@ import qualified Language.Wasm.Binary as Binary
 
 import Options.Applicative
 import Data.Semigroup ((<>))
+import Wasm.WasmParser
 
-{-
+import Data.Maybe (fromMaybe)
-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 OutputMode = WasmBinary | JSWrapper deriving (Show, Eq)
-data ExecMod = Plain | Script deriving (Show, Eq)
-data Input = InpText | InpBinary deriving (Eq)
 
-instance Read CompileOutFormat where
+data WasmConfig = WasmConfig {
-  readsPrec _ "js" = [(OutJS, "")]
+    inputFile :: String,
-  readsPrec _ "binary" = [(OutBinary, "")]
+    outputFile :: String,
-  readsPrec _ "html" = [(OutHTML, "")]
+    outputMode :: OutputMode
-  readsPrec _ _ = error "Unknown compilation output foramt"
+} deriving (Show, Eq)
 
-instance Show CompileOutFormat where
+compile :: String -> String -> IO ()
-  show OutJS = "js"
+compile input output = do
-  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
+  case Lexer.scanner content >>= Parser.parseModule of
-    Right binary ->
+    Right mod ->
-      LBS.writeFile output $ transform binary
+      LBS.writeFile output $ Binary.dumpModuleLazy mod
     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
+main = do
+     config <- execParser opts
+     process config
    where
-    opts = info (config <**> helper)
+     opts = info (sample <**> helper)
        ( fullDesc
-        <> progDesc "WebAssembly Toolkit"
+      <> progDesc "Haskell WebAssembly Toolkit"
-        <> header "This tool can compile text representation to binary format, validate module in text or binary representation and so on.")
+      <> header "Compile WebAssembly code into binary" )
+
+process :: WasmParser -> IO ()
+
+process (WasmParser (Just output) input) =
+  compile input output
+
+process (WasmParser Nothing input) =
+  compile input "out.wasm"
+
+process _ = return ()

exec/Wasm/WasmParser.hs

@@ -0,0 +1,25 @@
+module Wasm.WasmParser where
+
+import Options.Applicative
+import Data.Semigroup ((<>))
+
+--data WasmFileFormat = WasmText | WasmBinary | WasmScript deriving (Read, Show)
+--
+--instance Read WasmFileFormat where
+--    readsPrec _ ("WAT":xs) = [ (WasmText, xs) ]
+--    readsPrec _ ("WAST":xs) = [ (WasmScript, xs) ]
+--    readsPrec _ ("WASM":xs) = [ (WasmBinary, xs) ]
+
+data WasmParser = WasmParser
+  { output     :: Maybe String
+  , input      :: String }
+
+sample :: Parser WasmParser
+sample = WasmParser
+      <$> option (maybeReader (Just . Just))
+          ( long "output"
+         <> short 'o'
+         <> metavar "OUTPUT_FILE"
+         <> help "Output filename"
+         <> value Nothing )
+      <*> argument str (metavar "INPUT_FILE")

package.yaml

@@ -31,6 +31,15 @@ library:
   - containers           >= 0.5  && <0.6
   - utf8-string          >= 1.0
 
+executables:
+  wasm:
+    source-dirs: exec
+    main: Main.hs
+    dependencies: 
+    - wasm == 0.1.0
+    - base
+    - optparse-applicative
+
 tests:
   test:
     main: Test.hs

src/Language/Wasm/Binary.hs

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

src/Language/Wasm/Builder.hs

@@ -1,887 +0,0 @@
-{-# 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 #-}
-
-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 t = 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 t)
-    local :: (ValueTypeable t) => Proxy t -> m (Loc 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
--- type GenFun = ReaderT Natural (State FuncDef)
-
--- genExpr :: Natural -> GenFun a -> Expression
--- genExpr deep gen = instrs $ flip execState (FuncDef [] [] [] []) $ runReaderT gen deep
-
--- param :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
--- param t = do
---     f@FuncDef { args } <- get
---     put $ f { args = args ++ [getValueType t] }
---     return $ Loc $ fromIntegral $ length args
-
--- local :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
--- local t = do
---     f@FuncDef { args, locals } <- get
---     put $ f { locals = locals ++ [getValueType t]}
---     return $ Loc $ fromIntegral $ length args + length locals
-
--- appendExpr :: Expression -> GenFun ()
--- appendExpr expr = do
---     modify $ \def -> def { instrs = instrs def ++ expr }
---     return ()
-
--- after :: Expression -> GenFun a -> GenFun a
--- after instr expr = do
---     res <- expr
---     modify $ \def -> def { instrs = instrs def ++ instr }
---     return res
-
-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))
-
-data ProducerType
-    = LocProd
-    | GlobProd
-    | ExprProd
-
-type family GetProdType a :: ProducerType where
-    GetProdType (Loc t) = 'LocProd
-    GetProdType (Glob t) = 'GlobProd
-    GetProdType a = 'ExprProd
-
-class (GenFunMonad m) => ProducerHelp (prodType :: ProducerType) m expr where
-    type OutTypeHelp prodType expr
-    asTypedExprHelp :: expr -> TypedExpr m
-    produceHelp :: expr -> m (OutTypeHelp prodType expr)
-
-instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'LocProd m (Loc t) where
-    type OutTypeHelp 'LocProd (Loc t) = Proxy t
-    asTypedExprHelp e = case getValueType (t e) of
-        I32 -> ExprI32 (produceHelp @'LocProd e >> return Proxy)
-        I64 -> ExprI64 (produceHelp @'LocProd e >> return Proxy)
-        F32 -> ExprF32 (produceHelp @'LocProd e >> return Proxy)
-        F64 -> ExprF64 (produceHelp @'LocProd e >> return Proxy)
-        where
-            t :: Loc t -> Proxy t
-            t _ = Proxy
-    produceHelp (Loc i) = appendExpr [GetLocal i] >> return Proxy
-
-instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'GlobProd m (Glob t) where
-    type OutTypeHelp 'GlobProd (Glob t) = Proxy t
-    asTypedExprHelp e = case getValueType (t e) of
-        I32 -> ExprI32 (produceHelp @'GlobProd e >> return Proxy)
-        I64 -> ExprI64 (produceHelp @'GlobProd e >> return Proxy)
-        F32 -> ExprF32 (produceHelp @'GlobProd e >> return Proxy)
-        F64 -> ExprF64 (produceHelp @'GlobProd e >> return Proxy)
-        where
-            t :: Glob t -> Proxy t
-            t _ = Proxy
-    produceHelp (Glob i) = appendExpr [GetGlobal i] >> return Proxy
-
-instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'ExprProd m (m (Proxy t)) where
-    type OutTypeHelp 'ExprProd (m (Proxy t)) = Proxy t
-    asTypedExprHelp e = case getValueType (t e) of
-        I32 -> ExprI32 (produceHelp @'ExprProd e >> return Proxy)
-        I64 -> ExprI64 (produceHelp @'ExprProd e >> return Proxy)
-        F32 -> ExprF32 (produceHelp @'ExprProd e >> return Proxy)
-        F64 -> ExprF64 (produceHelp @'ExprProd e >> return Proxy)
-        where
-            t :: (GenFunMonad m) => m (Proxy t) -> Proxy t
-            t _ = Proxy
-    produceHelp = id
-
-class (GenFunMonad m) => Producer m expr where
-    type OutType expr
-    asTypedExpr :: expr -> TypedExpr m
-    produce :: expr -> m (OutType expr)
-
-instance (GenFunMonad m, ProducerHelp (GetProdType (m a)) m (m a)) => Producer m (m a) where
-    type OutType (m a) = OutTypeHelp (GetProdType (m a)) (m a)
-    asTypedExpr = asTypedExprHelp @(GetProdType (m a))
-    produce = produceHelp @(GetProdType (m a))
-
-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 :: GenFun ()
-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 (GenFunMonad m) => Consumer m loc where
-    type InputType loc
-    infixr 2 .=
-    (.=) :: (Producer m expr) => loc -> expr -> m ()
-
-instance (GenFunMonad m) => Consumer m (Loc t) where
-    type InputType (Loc t) = Proxy t
-    (.=) (Loc i) expr = produce expr >> appendExpr [SetLocal i]
-
-instance (GenFunMonad m) => Consumer m (Glob t) where
-    type InputType (Glob 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 -> GenMod (Glob 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 t) where
-    type AfterExport (Glob t) = Glob 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
-
-newtype Glob t = Glob Natural deriving (Show, Eq)
-
-global :: (ValueTypeable t) => (ValueType -> GlobalType) -> Proxy t -> (ValType t) -> GenMod (Glob t)
-global mkType t val = do
-    idx <- gets globIdx
-    modify $ \(st@GenModState { target = m }) -> st {
-        target = m { globals = globals m ++ [Global (mkType $ getValueType t) (initWith t val)] },
-        globIdx = idx + 1
-    }
-    return $ Glob idx
-
-setGlobalInitializer :: forall t . (ValueTypeable t) => Glob 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 Const i32 0
-    stackEnd <- global Const i32 0
-    stackBase <- global Mut i32 0
-    stackTop <- global Mut i32 0
-
-    retReg <- global Mut i32 0
-    tmpReg <- global Mut i32 0
-
-    heapStart <- global Mut i32 0
-    heapNext <- global Mut i32 0
-    heapEnd <- global Mut i32 0
-
-    aligned <- fun i32 $ do
-        size <- param i32
-        (size `add` i32c 3) `and` i32c 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 -> Expression -> IO Value
+evalConstExpr :: ModuleInstance -> Store -> [Instruction] -> 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 :: Expression -> IO Value
+        runIniter :: [Instruction] -> 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 -> Expression -> IO EvalResult
+        go :: EvalCtx -> [Instruction] -> 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 Natural -> IO EvalResult
+        step :: EvalCtx -> Instruction -> IO EvalResult
         step _ Unreachable = return Trap
         step ctx Nop = return $ Done ctx
         step ctx (Block resType expr) = do

src/Language/Wasm/Parser.y

@@ -1440,6 +1440,8 @@ data Module = Module {
 
 type Script = [Command]
 
+type Expression = [Instruction]
+
 data ModuleDef
     = RawModDef (Maybe Ident) S.Module
     | TextModDef (Maybe Ident) TL.Text
@@ -1455,14 +1457,14 @@ data Command
     deriving (Show, Eq)
 
 data Action
-    = Invoke (Maybe Ident) TL.Text [S.Expression]
+    = Invoke (Maybe Ident) TL.Text [[S.Instruction]]
     | Get (Maybe Ident) TL.Text
     deriving (Show, Eq)
 
 type FailureString = TL.Text
 
 data Assertion
-    = AssertReturn Action [S.Expression]
+    = AssertReturn Action [[S.Instruction]]
     | AssertReturnCanonicalNaN Action
     | AssertReturnArithmeticNaN Action
     | AssertTrap (Either Action ModuleDef) FailureString
@@ -1487,7 +1489,7 @@ data FunCtx = FunCtx {
     ctxParams :: [ParamType]
 } deriving (Eq, Show)
 
-constInstructionToValue :: Instruction -> S.Instruction Natural
+constInstructionToValue :: Instruction -> S.Instruction
 constInstructionToValue (PlainInstr (I32Const v)) = S.I32Const $ integerToWord32 v
 constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v
 constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v
@@ -1637,7 +1639,7 @@ desugarize fields = do
                 Nothing -> Left "unknown label"
 
         -- functions
-        synInstrToStruct :: FunCtx -> Instruction -> Either String (S.Instruction Natural)
+        synInstrToStruct :: FunCtx -> Instruction -> Either String S.Instruction
         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.Expression -> Interpreter.Value
+        asArg :: [Struct.Instruction] -> 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 index =
+data Instruction =
     -- Control instructions
     Unreachable
     | Nop
-    | Block { resultType :: ResultType, body :: Expression }
+    | Block { result :: ResultType, body :: Expression }
-    | Loop { resultType :: ResultType, body :: Expression }
+    | Loop { result :: ResultType, body :: Expression }
-    | If { resultType :: ResultType, true :: Expression, false :: Expression }
+    | If { result :: ResultType, true :: Expression, false :: Expression }
-    | Br index
+    | Br LabelIndex
-    | BrIf index
+    | BrIf LabelIndex
-    | BrTable [index] index
+    | BrTable [LabelIndex] LabelIndex
     | Return
-    | Call index
+    | Call FuncIndex
-    | CallIndirect index
+    | CallIndirect TypeIndex
     -- Parametric instructions
     | Drop
     | Select
     -- Variable instructions
-    | GetLocal index
+    | GetLocal LocalIndex
-    | SetLocal index
+    | SetLocal LocalIndex
-    | TeeLocal index
+    | TeeLocal LocalIndex
-    | GetGlobal index
+    | GetGlobal GlobalIndex
-    | SetGlobal index
+    | SetGlobal GlobalIndex
     -- Memory instructions
     | I32Load MemArg
     | I64Load MemArg
@@ -176,7 +176,7 @@ data Instruction index =
     | FReinterpretI BitSize
     deriving (Show, Eq, Generic, NFData)
 
-type Expression = [Instruction Natural]
+type Expression = [Instruction]
 
 data Function = Function {
     funcType :: TypeIndex,
@@ -203,7 +203,7 @@ data Global = Global {
 
 data ElemSegment = ElemSegment {
     tableIndex :: TableIndex,
-    offset :: Expression,
+    offset :: [Instruction],
     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 Natural -> Checker Arrow
+getInstrType :: Instruction -> Checker Arrow
 getInstrType Unreachable = return $ Any ==> Any
 getInstrType Nop = return $ empty ==> empty
-getInstrType Block { resultType, body } = do
+getInstrType Block { result, body } = do
-    let blockType = empty ==> resultType
+    let blockType = empty ==> result
-    t <- withLabel resultType $ getExpressionType body
+    t <- withLabel result $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> resultType
+    then return $ empty ==> result
     else throwError $ TypeMismatch t blockType
-getInstrType Loop { resultType, body } = do
+getInstrType Loop { result, body } = do
-    let blockType = empty ==> resultType
+    let blockType = empty ==> result
     t <- withLabel [] $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> resultType
+    then return $ empty ==> result
     else throwError $ TypeMismatch t blockType
-getInstrType If { resultType, true, false } = do
+getInstrType If { result, true, false } = do
-    let blockType = empty ==> resultType
+    let blockType = empty ==> result
-    l <- withLabel resultType $ getExpressionType true
+    l <- withLabel result $ getExpressionType true
-    r <- withLabel resultType $ getExpressionType false
+    r <- withLabel result $ getExpressionType false
     if isArrowMatch l blockType
-    then (if isArrowMatch r blockType then (return $ I32 ==> resultType) else (throwError $ TypeMismatch r blockType))
+    then (if isArrowMatch r blockType then (return $ I32 ==> result) 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 :: Expression -> Checker Arrow
+getExpressionType :: [Instruction] -> Checker Arrow
 getExpressionType = fmap ([] `Arrow`) . foldM go []
     where
-        go :: [VType] -> Instruction Natural -> Checker [VType]
+        go :: [VType] -> Instruction -> 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 :: Expression -> Checker ()
+isConstExpression :: [Instruction] -> Checker ()
 isConstExpression [] = return ()
 isConstExpression ((I32Const _):rest) = isConstExpression rest
 isConstExpression ((I64Const _):rest) = isConstExpression rest

wasm.cabal

@@ -45,7 +45,6 @@ library
       Language.Wasm.Interpreter
       Language.Wasm.Script
       Language.Wasm.FloatUtils
-      Language.Wasm.Builder
       Language.Wasm
   other-modules:
       Paths_wasm
@@ -59,7 +58,9 @@ executable wasm
     , wasm ==0.1.0
     , optparse-applicative >= 0.14
     , bytestring >=0.10 && <0.11
-    , base64-bytestring >= 1.0
+  other-modules:
+    Wasm.WasmParser
+
 
 test-suite test
   type: exitcode-stdio-1.0