add input and output commands parsing and call compilation

.gitignore

@@ -1,2 +1,3 @@
 .stack-work
-tests/runnable/*
+tests/runnable/*
+.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
 
-{-
-wasm compile INPUT -o output -f js -f binary
-wasm exec --script INPUT
-wasm validate INPUT -f binary -f text
-wasm link 
--}
+import Data.Maybe (fromMaybe)
 
-data CompileOutFormat = OutJS | OutBinary | OutHTML deriving (Eq)
-data ExecMod = Plain | Script deriving (Show, Eq)
-data Input = InpText | InpBinary deriving (Eq)
+data OutputMode = WasmBinary | JSWrapper deriving (Show, Eq)
 
-instance Read CompileOutFormat where
-  readsPrec _ "js" = [(OutJS, "")]
-  readsPrec _ "binary" = [(OutBinary, "")]
-  readsPrec _ "html" = [(OutHTML, "")]
-  readsPrec _ _ = error "Unknown compilation output foramt"
+data WasmConfig = WasmConfig {
+    inputFile :: String,
+    outputFile :: String,
+    outputMode :: OutputMode
+} deriving (Show, Eq)
 
-instance Show CompileOutFormat where
-  show OutJS = "js"
-  show OutBinary = "binary"
-  show OutHTML = "html"
-
-instance Read Input where
-  readsPrec _ "text" = [(InpText, "")]
-  readsPrec _ "binary" = [(InpBinary, "")]
-  readsPrec _ _ = error "Unknown validation input foramt"
-
-instance Show Input where
-  show InpText = "text"
-  show InpBinary = "binary"
-
-data WasmCommand
-  = Compile {
-    input :: String,
-    output :: String,
-    outFormat :: CompileOutFormat
-  }
-  | Exec {
-    input :: String,
-    mode :: ExecMod,
-    inpFormat :: Input
-  }
-  | Validate {
-    input :: String,
-    inpFormat :: Input
-  }
-  deriving (Show, Eq)
-
-compileArgs = Compile
-  <$> argument str (metavar "FILE")
-  <*> strOption (
-      long "out"
-      <> short 'o'
-      <> metavar "FILE"
-      <> help "Distination for compilation"
-    )
-  <*> option auto (
-      long "format"
-      <> short 'f'
-      <> help "Output file format"
-      <> showDefault
-      <> value OutBinary
-    )
-
-execArgs = Exec
-  <$> argument str (metavar "FILE")
-  <*> flag Plain Script (long "script" <> help "Execute file in script mode")
-  <*> option auto (
-    long "format"
-    <> short 'f'
-    <> help "Input file format"
-    <> showDefault
-    <> value InpText
-  )
-
-validateArgs = Validate
-  <$> argument str (metavar "FILE")
-  <*> option auto (
-      long "format"
-      <> short 'f'
-      <> help "Input file format"
-      <> showDefault
-      <> value InpText
-    )
-
-config :: Parser WasmCommand
-config = subparser (
-    command "compile" (info compileArgs (progDesc "Compile WebAssembly file from text representation"))
-    <> command "exec" (info execArgs (progDesc "Compile WebAssembly file if needed and execute"))
-    <> command "validate" (info validateArgs (progDesc "Validate WebAssembly file"))
-  )
-
-toBinary :: LBS.ByteString -> Either String LBS.ByteString
-toBinary content = do
-    lexemes <- Lexer.scanner content
-    mod <- Parser.parseModule lexemes
-    return $ Binary.dumpModuleLazy mod
-
-compileAs :: (LBS.ByteString -> LBS.ByteString) -> String -> String -> IO ()
-compileAs transform input output = do
+compile :: String -> String -> IO ()
+compile input output = do
   content <- LBS.readFile input
-  case toBinary content of
-    Right binary ->
-      LBS.writeFile output $ transform binary
+  case Lexer.scanner content >>= Parser.parseModule of
+    Right mod ->
+      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
-  where
-    opts = info (config <**> helper)
-      (fullDesc
-        <> progDesc "WebAssembly Toolkit"
-        <> header "This tool can compile text representation to binary format, validate module in text or binary representation and so on.")
+main = do
+     config <- execParser opts
+     process config
+   where
+     opts = info (sample <**> helper)
+       ( fullDesc
+      <> progDesc "Haskell WebAssembly Toolkit"
+      <> 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/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

@@ -12,26 +12,14 @@ import Language.Wasm.Structure
 
 import Numeric.Natural (Natural)
 import Data.Bits
-import Data.Word (Word8, Word32, Word64)
-import Data.Int (Int8, Int32, Int64)
+import Data.Word (Word8)
+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"
@@ -360,8 +348,8 @@ instance Serialize Instruction where
     put CurrentMemory = putWord8 0x3F >> putWord8 0x00
     put GrowMemory = putWord8 0x40 >> putWord8 0x00
     -- Numeric instructions
-    put (I32Const val) = putWord8 0x41 >> putSLEB128 (asInt32 val)
-    put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val)
+    put (I32Const val) = putWord8 0x41 >> putSLEB128 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

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,6 @@ library
       Language.Wasm.Interpreter
       Language.Wasm.Script
       Language.Wasm.FloatUtils
-      Language.Wasm.AST
       Language.Wasm
   other-modules:
       Paths_wasm
@@ -60,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