add fundeps to infer monad instance from producer

.gitignore

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

src/Language/Wasm/AST.hs

@@ -1,516 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TypeInType #-}
-
-module Language.Wasm.AST (
-
-) where
-
-import GHC.TypeLits
-import Data.Proxy
-import Data.Promotion.Prelude.List ((:++), (:!!))
-import Data.Word (Word32, Word64)
-
-import Language.Wasm.Structure (
-        ValueType(..),
-        FuncType(..),
-        MemArg(..),
-        GlobalType(..),
-        IUnOp(..),
-        IBinOp(..),
-        IRelOp(..),
-        FUnOp(..),
-        FBinOp(..),
-        FRelOp(..)
-    )
-
-data VType = Val ValueType | Var | Any
-
-type family MatchStack (args :: [VType]) (stack :: [VType]) :: Bool where
-    MatchStack (Val v : args) (Val v : stack) = MatchStack args stack
-    MatchStack (Val v : args) (Var : stack) = MatchStack args stack
-    MatchStack (Var : args) (val : stack) = MatchStack (ReplaceVar args val) (ReplaceVar stack val)
-    MatchStack (val : args) (Var : stack) = MatchStack (ReplaceVar args val) (ReplaceVar stack val)
-    MatchStack '[] stack = True
-    MatchStack args (Any : stack) = True
-    MatchStack args stack = TypeError (
-            Text "Cannot match stack with instruction arguments." :$$:
-            Text "Expected arguments: " :<>: ShowType args :$$:
-            Text "Actual stack: " :<>: ShowType stack
-        )
-
-type family Consume (args :: [VType]) (stack :: [VType]) (result :: [VType]) :: [VType] where
-    Consume (Val v : args) (Val v : stack) result = Consume args stack result
-    Consume (Var : args) (val : stack) result = Consume (ReplaceVar args val) (ReplaceVar stack val) (ReplaceVar result val)
-    Consume (val : args) (Var : stack) result = Consume (ReplaceVar args val) (ReplaceVar stack val) (ReplaceVar result val)
-    Consume '[] stack result = result :++ stack
-    Consume args (Any : stack) result = result :++ (Any : stack)
-    Consume args stack result = TypeError (
-            Text "Cannot consume stack." :$$:
-            Text "Expected arguments: " :<>: ShowType args :$$:
-            Text "Actual stack: " :<>: ShowType stack
-        )
-
-type family IsRetMatch (stack :: [VType]) (ret :: [ValueType]) :: Bool where
-    IsRetMatch stack ret = Or (Equal (Consume (AsVType ret) stack '[]) '[]) (Equal (Consume (AsVType ret) stack '[]) '[Any])
-
-type family Or (l :: Bool) (r :: Bool) :: Bool where
-    Or False r = r
-    Or True r = True
-
-type family Equal a b :: Bool where
-    Equal a a = True
-    Equal a b = False
-
-type family ReplaceVar (types :: [VType]) (val :: VType) :: [VType] where
-    ReplaceVar '[] val = '[]
-    ReplaceVar (Var : rest) val = val : ReplaceVar rest val
-    ReplaceVar (t : rest) val = t : ReplaceVar rest val
-
-type family GetGlobalType (globalType :: GlobalType) :: VType where
-    GetGlobalType (Const vt) = Val vt
-    GetGlobalType (Mut vt) = Val vt
-
-type family IsMutable (globalType :: GlobalType) :: Bool where
-    IsMutable (Const a) = False
-    IsMutable (Mut a) = True
-
-type family IsLabelMatch (label :: Maybe ValueType) (stack :: [VType]) :: Bool where
-    IsLabelMatch (Just val) '[Val val] = True
-    IsLabelMatch (Just val) '[Any] = True
-    IsLabelMatch (Just val) '[Var] = True
-    IsLabelMatch Nothing '[] = True
-    IsLabelMatch label stack = False
-
-type family LabelAsArgs (label :: Maybe ValueType) :: [VType] where
-    LabelAsArgs (Just val) = '[Val val]
-    LabelAsArgs Nothing = '[]
-
-type family AsVType (values :: [ValueType]) :: [VType] where
-    AsVType (v : vs) = Val v : AsVType vs
-    AsVType '[] = '[]
-
-class KnownNats ns where
-    natVals :: Proxy ns -> [Integer]
-
-instance KnownNats ('[] :: [Nat]) where
-    natVals _ = []
-
-instance (KnownNat n, KnownNats ns) => KnownNats (n : ns) where
-    natVals p = let (n, ns) = dup p in natVal n : natVals ns
-        where
-            dup :: Proxy (n : ns) -> (Proxy n, Proxy ns)
-            dup _ = (Proxy, Proxy)
-
-type family GetParams (ft :: FuncType) :: [ValueType] where
-    GetParams ('FuncType params results) = params
-
-type family GetResults (ft :: FuncType) :: [ValueType] where
-    GetResults ('FuncType params results) = results
-
-data Ctx = Ctx {
-    locals :: [VType],
-    globals :: [GlobalType],
-    labels :: [Maybe ValueType],
-    returns :: [ValueType],
-    functions :: [FuncType],
-    types :: [FuncType]
-}
-
-type family GetLocals (ctx :: Ctx) :: [VType] where
-    GetLocals ('Ctx locals globals labels returns functions types) = locals
-
-type family GetGlobals (ctx :: Ctx) :: [GlobalType] where
-    GetGlobals ('Ctx locals globals labels returns functions types) = globals
-
-type family GetLabels (ctx :: Ctx) :: [Maybe ValueType] where
-    GetLabels ('Ctx locals globals labels returns functions types) = labels
-
-type family WithLabel (ctx :: Ctx) (label :: Maybe ValueType) where
-    WithLabel ('Ctx locals globals labels returns functions types) label = 'Ctx locals globals (label : labels) returns functions types
-
-type family GetReturns (ctx :: Ctx) :: [ValueType] where
-    GetReturns ('Ctx locals globals labels returns functions types) = returns
-
-type family GetFunctions (ctx :: Ctx) :: [FuncType] where
-    GetFunctions ('Ctx locals globals labels returns functions types) = functions
-
-type family GetTypes (ctx :: Ctx) :: [FuncType] where
-    GetTypes ('Ctx locals globals labels returns functions types) = types
-
-type family GetFTParams (ctx :: Ctx) (function :: Nat) :: [VType] where
-    GetFTParams ctx function = AsVType (GetParams ((GetFunctions ctx) :!! function))
-
-type family GetFTResults (ctx :: Ctx) (function :: Nat) :: [VType] where
-    GetFTResults ctx function = AsVType (GetResults ((GetFunctions ctx) :!! function))
-
-type family GetTParams (ctx :: Ctx) (typeIdx :: Nat) :: [VType] where
-    GetTParams ctx typeIdx = AsVType (GetParams ((GetTypes ctx) :!! typeIdx))
-
-type family GetTResults (ctx :: Ctx) (typeIdx :: Nat) :: [VType] where
-    GetTResults ctx typeIdx = AsVType (GetResults ((GetTypes ctx) :!! typeIdx))
-
-data InstrSeq (stack :: [VType]) ctx where
-    Empty :: InstrSeq '[] ctx
-    Unreachable :: InstrSeq stack ctx -> InstrSeq '[Any] ctx
-    Nop :: InstrSeq stack ctx -> InstrSeq stack ctx
-    Block :: (IsLabelMatch label result ~ True) =>
-        Proxy (label :: Maybe ValueType) ->
-        InstrSeq result (WithLabel ctx label) ->
-        InstrSeq stack ctx ->
-        InstrSeq (result :++ stack) ctx
-    Loop :: (IsLabelMatch label result ~ True) =>
-        Proxy (label :: Maybe ValueType) ->
-        InstrSeq result (WithLabel ctx label) ->
-        InstrSeq stack ctx ->
-        InstrSeq (result :++ stack) ctx
-    If :: (IsLabelMatch label result ~ True, MatchStack '[Val I32] stack ~ True) =>
-        Proxy (label :: Maybe ValueType) ->
-        InstrSeq result (WithLabel ctx label) ->
-        InstrSeq result (WithLabel ctx label) ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack result) ctx
-    Br :: (KnownNat label, MatchStack (LabelAsArgs ((GetLabels ctx) :!! label)) stack ~ True) =>
-        Proxy label ->
-        InstrSeq stack ctx ->
-        InstrSeq '[Any] ctx
-    BrIf :: (KnownNat label, MatchStack ((LabelAsArgs ((GetLabels ctx) :!! label)) :++ '[Val I32]) stack ~ True) =>
-        Proxy label ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume ((LabelAsArgs ((GetLabels ctx) :!! label)) :++ '[Val I32]) stack (LabelAsArgs ((GetLabels ctx) :!! label))) ctx
-    BrTable :: (
-            KnownNat defaultLabel,
-            KnownNats localLabels,
-            MatchStack ((LabelAsArgs ((GetLabels ctx) :!! defaultLabel)) :++ '[Val I32]) stack ~ True
-        ) =>
-        Proxy (localLabels :: [Nat]) ->
-        Proxy defaultLabel ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume ((LabelAsArgs ((GetLabels ctx) :!! defaultLabel)) :++ '[Val I32]) stack '[Any]) ctx
-    Return :: (MatchStack (AsVType (GetReturns ctx)) stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume (AsVType (GetReturns ctx)) stack '[Any]) ctx
-    Call :: (KnownNat function, MatchStack (GetFTParams ctx function) stack ~ True) =>
-        Proxy function ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume (GetFTParams ctx function) stack (GetFTResults ctx function)) ctx
-    CallIndirect :: (KnownNat typeIdx, MatchStack (GetTParams ctx typeIdx) stack ~ True) =>
-        Proxy typeIdx ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume (GetTParams ctx typeIdx) stack (GetTResults ctx typeIdx)) ctx
-    Drop :: InstrSeq (any : stack) ctx -> InstrSeq stack ctx
-    Select :: (MatchStack '[Var, Var, Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Var, Var, Val I32] stack '[Var]) ctx
-    GetLocal :: (KnownNat local) =>
-        Proxy local ->
-        InstrSeq stack ctx ->
-        InstrSeq (((GetLocals ctx) :!! local) : stack) ctx
-    SetLocal :: (KnownNat local, MatchStack '[(GetLocals ctx) :!! local] stack ~ True) =>
-        Proxy local ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[(GetLocals ctx) :!! local] stack '[]) ctx
-    TeeLocal :: (KnownNat local, MatchStack '[(GetLocals ctx) :!! local] stack ~ True) =>
-        Proxy local ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[(GetLocals ctx) :!! local] stack '[(GetLocals ctx) :!! local]) ctx
-    GetGlobal :: (KnownNat global) =>
-        Proxy global ->
-        InstrSeq stack ctx ->
-        InstrSeq ((GetGlobalType ((GetGlobals ctx) :!! global)) : stack) ctx
-    SetGlobal :: (
-            KnownNat global,
-            MatchStack '[GetGlobalType ((GetGlobals ctx) :!! global)] stack ~ True,
-            IsMutable ((GetGlobals ctx) :!! global) ~ True
-        ) =>
-        Proxy global ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[GetGlobalType ((GetGlobals ctx) :!! global)] stack '[]) ctx
-    I32Load :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I64Load :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    F32Load :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F32]) ctx
-    F64Load :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F64]) ctx
-    I32Load8S :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I32Load8U :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I32Load16S :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I32Load16U :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I64Load8S :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64Load8U :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64Load16S :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64Load16U :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64Load32S :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64Load32U :: (MatchStack '[Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I32Store :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[]) ctx
-    I64Store :: (MatchStack '[Val I32, Val I64] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I64] stack '[]) ctx
-    F32Store  :: (MatchStack '[Val I32, Val F32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val F32] stack '[]) ctx
-    F64Store  :: (MatchStack '[Val I32, Val F64] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val F64] stack '[]) ctx
-    I32Store8  :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[]) ctx
-    I32Store16  :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[]) ctx
-    I64Store8 :: (MatchStack '[Val I32, Val I64] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I64] stack '[]) ctx
-    I64Store16 :: (MatchStack '[Val I32, Val I64] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I64] stack '[]) ctx
-    I64Store32 :: (MatchStack '[Val I32, Val I64] stack ~ True) =>
-        MemArg ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I64] stack '[]) ctx
-    CurrentMemory :: InstrSeq stack ctx -> InstrSeq (Val I32 : stack) ctx
-    GrowMemory :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I32Const :: Word32 -> InstrSeq stack ctx -> InstrSeq (Val I32 : stack) ctx
-    I32UnOp :: (MatchStack '[Val I32] stack ~ True) =>
-        IUnOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I32BinOp :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
-        IBinOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) ctx
-    I32RelOp :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
-        IRelOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) ctx
-    I32Eqz :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
-    I64Const :: Word64 -> InstrSeq stack ctx -> InstrSeq (Val I64 : stack) ctx
-    I64UnOp :: (MatchStack '[Val I64] stack ~ True) =>
-        IUnOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val I64]) ctx
-    I64BinOp :: (MatchStack '[Val I64, Val I64] stack ~ True) =>
-        IBinOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32, Val I32] stack '[Val I64]) ctx
-    I64RelOp :: (MatchStack '[Val I64, Val I64] stack ~ True) =>
-        IRelOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64, Val I64] stack '[Val I32]) ctx
-    I64Eqz :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val I32]) ctx
-    F32Const :: Float -> InstrSeq stack ctx -> InstrSeq (Val F32 : stack) ctx
-    F32UnOp :: (MatchStack '[Val F32] stack ~ True) =>
-        FUnOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val F32]) ctx
-    F32BinOp :: (MatchStack '[Val F32, Val F32] stack ~ True) =>
-        FBinOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32, Val F32] stack '[Val F32]) ctx
-    F32RelOp :: (MatchStack '[Val F32, Val F32] stack ~ True) =>
-        FRelOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32, Val F32] stack '[Val I32]) ctx
-    F64Const :: Double -> InstrSeq stack ctx -> InstrSeq (Val F64 : stack) ctx
-    F64UnOp :: (MatchStack '[Val F64] stack ~ True) =>
-        FUnOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val F64]) ctx
-    F64BinOp :: (MatchStack '[Val F32, Val F32] stack ~ True) =>
-        FBinOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64, Val F64] stack '[Val F64]) ctx
-    F64RelOp :: (MatchStack '[Val F64, Val F64] stack ~ True) =>
-        FRelOp ->
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64, Val F64] stack '[Val I32]) ctx
-    I32WrapI64 :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val I32]) ctx
-    I32TruncF32U :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val I32]) ctx
-    I32TruncF64U :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val I32]) ctx
-    I64TruncF32U :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val I64]) ctx
-    I64TruncF64U :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val I64]) ctx
-    I32TruncF32S :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val I32]) ctx
-    I32TruncF64S :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val I32]) ctx
-    I64TruncF32S :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val I64]) ctx
-    I64TruncF64S :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val I64]) ctx
-    I64ExtendI32U :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    I64ExtendI32S :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val I64]) ctx
-    F32ConvertI32U :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F32]) ctx
-    F32ConvertI64U :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val F32]) ctx
-    F64ConvertI32U :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F64]) ctx
-    F64ConvertI64U :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val F64]) ctx
-    F32ConvertI32S :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F32]) ctx
-    F32ConvertI64S :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val F32]) ctx
-    F64ConvertI32S :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F64]) ctx
-    F64ConvertI64S :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val F64]) ctx
-    F32DemoteF64 :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val F32]) ctx
-    F64PromoteF32 :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val F64]) ctx
-    I32ReinterpretF32 :: (MatchStack '[Val F32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F32] stack '[Val I32]) ctx
-    I64ReinterpretF64 :: (MatchStack '[Val F64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val F64] stack '[Val I64]) ctx
-    F32ReinterpretI32 :: (MatchStack '[Val I32] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I32] stack '[Val F32]) ctx
-    F64ReinterpretI64 :: (MatchStack '[Val I64] stack ~ True) =>
-        InstrSeq stack ctx ->
-        InstrSeq (Consume '[Val I64] stack '[Val F64]) ctx
-
-{-
-(func $alloc (param $size i32) (result i32)
-    (local $aligned-size i32)
-    (local $addr i32)
-    (set_local $aligned-size (call $alligned (get_local $size)))
-    (if (i32.lt_u (i32.add (get_global $heap-next) (get_local $aligned-size)) (get_global $heap-end))
-        (then
-            (set_local $addr (get_global $heap-next))
-            (set_global $heap-next (i32.add (get_global $heap-next) (get_local $aligned-size)))
-            (get_local $addr)
-        )
-        (else
-            (call $run-gc)
-            (call $alloc (get_local $size))
-        )
-    )
-)
--}
-
-data Function params results globals funcs types where
-    Function :: (IsRetMatch stack ret ~ True)
-        => Proxy (params :: [ValueType])
-        -> Proxy (locals :: [ValueType])
-        -> Proxy (ret :: [ValueType])
-        -> InstrSeq stack ('Ctx ((AsVType params) :++ (AsVType locals)) globals '[] ret funcs types)
-        -> Function params ret globals funcs types
-
-facRec :: Function '[I32] '[I32] '[] '[('FuncType '[I32] '[I32])] '[]
-facRec = Function (Proxy @'[I32]) (Proxy @'[]) (Proxy @'[I32]) $ body
-    & GetLocal idx0
-    & I32Const 0
-    & I32RelOp IEq
-    & (If resI32
-        (then'
-            & I32Const 1
-        )
-        (else'
-            & GetLocal idx0
-            & I32Const 1
-            & GetLocal idx0
-            & I32BinOp ISub
-            & Call idx0
-            & I32BinOp IMul
-        )
-    )
-    where
-        resI32 = Proxy @('Just I32)
-        idx0 = Proxy @0
-        body = Empty
-        else' = Empty
-        then' = Empty
-        infixl 1 &
-        x & f = f x

src/Language/Wasm/Binary.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Language.Wasm.Binary (
     dumpModule,
@@ -294,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
@@ -308,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
@@ -682,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
@@ -692,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

@@ -33,7 +33,6 @@ library
     , vector >= 0.12
     , ieee754 >= 0.8
     , deepseq >= 1.4
-    , singletons >= 2
   build-tools:
       alex >=3.1.3
     , happy >=1.9.4
@@ -46,7 +45,7 @@ library
       Language.Wasm.Interpreter
       Language.Wasm.Script
       Language.Wasm.FloatUtils
-      Language.Wasm.AST
+      Language.Wasm.Builder
       Language.Wasm
   other-modules:
       Paths_wasm