define types for wasm internal structure and share some parts with text representation types

src/Language/Wasm/Parser.y

@@ -5,7 +5,6 @@
 
 module Language.Wasm.Parser (
     parseModule,
-    Module(..),
     ModuleField(..),
     DataSegment(..),
     ElemSegment(..),
@@ -20,28 +19,31 @@ module Language.Wasm.Parser (
     Import(..),
     ImportDesc(..),
     Instruction(..),
-    MemArg(..),
     TypeUse(..),
     TypeDef(..),
     PlainInstr(..),
-    IUnOp(..),
-    IBinOp(..),
-    IRelOp(..),
-    FUnOp(..),
-    FBinOp(..),
-    FRelOp(..),
-    BitSize(..),
     Index(..),
-    TableType(..),
-    ElemType(..),
-    Limit(..),
-    GlobalType(..),
     Ident(..),
     ParamType(..),
-    FuncType(..),
+    FuncType(..)
-    ValueType(..)
 ) where
 
+import Language.Wasm.Structure (
+        MemArg(..),
+        IUnOp(..),
+        IBinOp(..),
+        IRelOp(..),
+        FUnOp(..),
+        FBinOp(..),
+        FRelOp(..),
+        BitSize(..),
+        TableType(..),
+        ElemType(..),
+        Limit(..),
+        GlobalType(..),
+        ValueType(..)
+    )
+
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLEncoding
@@ -73,7 +75,7 @@ import Debug.Trace as Debug
 
 }
 
-%name parseModule mod
+%name parseModule modAsFields
 %tokentype { Lexeme }
 
 %token
@@ -830,16 +832,9 @@ modulefield1 :: { [ModuleField] }
 modulefield :: { [ModuleField] }
     : '(' modulefield1 { $2 }
 
-modulefields :: { Module }
+modAsFields :: { [ModuleField] }
-    : modulefields modulefield { foldl' (flip appendModuleField) $1 $2 }
+    : '(' 'module' list(modulefield) ')' EOF { concat $3 }
-    | {- empty -} { emptyModule }
+    | '(' modulefield1 list(modulefield) EOF { $2 ++ concat $3}
-
-mod :: { Module }
-    : '(' mod1 { $2 }
-
-mod1 :: { Module }
-    : 'module' modulefields ')' EOF { reverseModuleFields $2 }
-    | modulefield1 modulefields EOF { reverseModuleFields $ foldl' (flip appendModuleField) $2 $1 }
 
 -- utils
 
@@ -915,17 +910,7 @@ asString = Just . TLEncoding.decodeUtf8
 eitherToMaybe :: Either left right -> Maybe right
 eitherToMaybe = either (const Nothing) Just
 
-data ValueType =
+data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq)
-    I32
-    | I64
-    | F32
-    | F64
-    deriving (Show, Eq)
-
-data FuncType = FuncType {
-        params :: [ParamType],
-        results :: [ValueType]
-    } deriving (Show, Eq)
 
 emptyFuncType :: FuncType
 emptyFuncType = FuncType [] []
@@ -937,14 +922,6 @@ data ParamType = ParamType {
 
 newtype Ident = Ident T.Text deriving (Show, Eq)
 
-data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq)
-
-data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq)
-
-data ElemType = AnyFunc deriving (Show, Eq)
-
-data TableType = TableType Limit ElemType deriving (Show, Eq)
-
 data Index = Named Ident | Index Natural deriving (Show, Eq)
 
 type LabelIndex = Index
@@ -955,36 +932,6 @@ type GlobalIndex = Index
 type TableIndex = Index
 type MemoryIndex = Index
 
-data BitSize = BS32 | BS64 deriving (Show, Eq)
-
-data IUnOp = IClz |ICtz | IPopcnt deriving (Show, Eq)
-
-data IBinOp =
-    IAdd
-    | ISub
-    | IMul
-    | IDivU
-    | IDivS
-    | IRemU
-    | IRemS
-    | IAnd
-    | IOr
-    | IXor
-    | IShl
-    | IShrU
-    | IShrS
-    | IRotl
-    | IRotr
-    deriving (Show, Eq)
-
-data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq)
-
-data FUnOp = FAbs | FNeg | FSqrt | FCeil | FFloor | FTrunc | FNearest deriving (Show, Eq)
-
-data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq)
-
-data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq)
-
 data PlainInstr =
     -- Control instructions
     Unreachable
@@ -1063,8 +1010,6 @@ data TypeUse =
     | AnonimousTypeUse FuncType
     deriving (Show, Eq)
 
-data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq)
-
 data Instruction =
     PlainInstr PlainInstr
     | BlockInstr {
@@ -1173,64 +1118,6 @@ data ModuleField =
     | MFData DataSegment
     deriving(Show, Eq)
 
-data Module = Module {
-        types     :: [TypeDef],
-        imports   :: [Import],
-        functions :: [Function],
-        tables    :: [Table],
-        memories  :: [Memory],
-        globals   :: [Global],
-        exports   :: [Export],
-        start     :: Maybe StartFunction,
-        elems     :: [ElemSegment],
-        datas     :: [DataSegment]
-    }
-    deriving (Show, Eq)
-
-emptyModule :: Module
-emptyModule =
-    Module {
-        types = [],
-        imports = [],
-        functions = [],
-        tables = [],
-        memories = [],
-        globals = [],
-        exports = [],
-        start = Nothing,
-        elems = [],
-        datas = []
-    }
-
-appendModuleField :: ModuleField -> Module -> Module
-appendModuleField field mod =
-    case field of
-        MFType typeDef -> mod { types = typeDef : types mod }
-        MFImport imp -> mod { imports = imp : imports mod }
-        MFFunc func -> mod { functions = func : functions mod }
-        MFTable table -> mod { tables = table : tables mod }
-        MFMem mem -> mod { memories = mem : memories mod }
-        MFGlobal global -> mod { globals = global : globals mod }
-        MFExport exp -> mod { exports = exp : exports mod }
-        MFStart startFunc -> mod { start = Just startFunc }
-        MFElem elem -> mod { elems = elem : elems mod }
-        MFData dataSeg -> mod { datas = dataSeg : datas mod }
-
-reverseModuleFields :: Module -> Module
-reverseModuleFields mod =
-    Module {
-        types = reverse $ types mod,
-        imports = reverse $ imports mod,
-        functions = reverse $ functions mod,
-        tables = reverse $ tables mod,
-        memories = reverse $ memories mod,
-        globals = reverse $ globals mod,
-        exports = reverse $ exports mod,
-        start = start mod,
-        elems = reverse $ elems mod,
-        datas = reverse $ datas mod
-    }
-
 happyError (Lexeme _ EOF : []) = error $ "Error occuried during parsing phase at the end of file"
 happyError (Lexeme (AlexPn abs line col) tok : tokens) = error $
     "Error occuried during parsing phase. " ++

src/Language/Wasm/Structure.hs

@@ -0,0 +1,244 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Language.Wasm.Structure (
+    Module(..),
+    DataSegment(..),
+    ElemSegment(..),
+    StartFunction(..),
+    Export(..),
+    ExportDesc(..),
+    Table(..),
+    Memory(..),
+    Global(..),
+    Function(..),
+    Import(..),
+    ImportDesc(..),
+    Instruction(..),
+    MemArg(..),
+    IUnOp(..),
+    IBinOp(..),
+    IRelOp(..),
+    FUnOp(..),
+    FBinOp(..),
+    FRelOp(..),
+    BitSize(..),
+    TableType(..),
+    ElemType(..),
+    Limit(..),
+    GlobalType(..),
+    FuncType(..),
+    ValueType(..)
+) where
+
+import Numeric.Natural (Natural)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Lazy as TL
+
+data BitSize = BS32 | BS64 deriving (Show, Eq)
+
+data IUnOp = IClz | ICtz | IPopcnt deriving (Show, Eq)
+
+data IBinOp =
+    IAdd
+    | ISub
+    | IMul
+    | IDivU
+    | IDivS
+    | IRemU
+    | IRemS
+    | IAnd
+    | IOr
+    | IXor
+    | IShl
+    | IShrU
+    | IShrS
+    | IRotl
+    | IRotr
+    deriving (Show, Eq)
+
+data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq)
+
+data FUnOp = FAbs | FNeg | FSqrt | FCeil | FFloor | FTrunc | FNearest deriving (Show, Eq)
+
+data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq)
+
+data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq)
+
+data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq)
+
+type LabelIndex = Natural
+type FuncIndex = Natural
+type TypeIndex = Natural
+type LocalIndex = Natural
+type GlobalIndex = Natural
+type MemoryIndex = Natural
+type TableIndex = Natural
+
+data ValueType =
+    I32
+    | I64
+    | F32
+    | F64
+    deriving (Show, Eq)
+
+type ResultType = [ValueType]
+type ParamsType = [ValueType]
+type LocalsType = [ValueType]
+
+data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq)
+
+data Instruction =
+    -- 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
+    | Return
+    | Call FuncIndex
+    | CallIndirect TypeIndex
+    -- Parametric instructions
+    | Drop
+    | Select
+    -- Variable instructions
+    | GetLocal LocalIndex
+    | SetLocal LocalIndex
+    | TeeLocal LocalIndex
+    | GetGlobal GlobalIndex
+    | SetGlobal GlobalIndex
+    -- Memory instructions
+    | I32Load MemArg
+    | I64Load MemArg
+    | F32Load MemArg
+    | F64Load MemArg
+    | I32Load8S MemArg
+    | I32Load8U MemArg
+    | I32Load16S MemArg
+    | I32Load16U MemArg
+    | I64Load8S MemArg
+    | I64Load8U MemArg
+    | I64Load16S MemArg
+    | I64Load16U MemArg
+    | I64Load32S MemArg
+    | I64Load32U MemArg
+    | I32Store MemArg
+    | I64Store MemArg
+    | F32Store MemArg
+    | F64Store MemArg
+    | I32Store8 MemArg
+    | I32Store16 MemArg
+    | I64Store8 MemArg
+    | I64Store16 MemArg
+    | I64Store32 MemArg
+    | CurrentMemory
+    | GrowMemory
+    -- Numeric instructions
+    | I32Const Integer
+    | I64Const Integer
+    | F32Const Float
+    | F64Const Double
+    | IUnOp BitSize IUnOp
+    | IBinOp BitSize IBinOp
+    | I32Eqz
+    | I64Eqz
+    | IRelOp BitSize IRelOp
+    | FUnOp BitSize FUnOp
+    | FBinOp BitSize FBinOp
+    | FRelOp BitSize FRelOp
+    | I32WrapI64
+    | ITruncFU {- Int Size -} BitSize {- Float Size -} BitSize
+    | ITruncFS {- Int Size -} BitSize {- Float Size -} BitSize
+    | I64ExtendSI32
+    | I64ExtendUI32
+    | FConvertIU {- Float Size -} BitSize {- Int Size -} BitSize
+    | FConvertIS {- Float Size -} BitSize {- Int Size -} BitSize
+    | F32DemoteF64
+    | F64PromoteF32
+    | IReinterpretF BitSize
+    | FReinterpretI BitSize
+    deriving (Show, Eq)
+
+type Expression = [Instruction]
+
+data Function = Function {
+    funcType :: TypeIndex,
+    locals :: LocalsType,
+    body :: Expression
+} deriving (Show, Eq)
+
+data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq)
+
+data ElemType = AnyFunc deriving (Show, Eq)
+
+data TableType = TableType Limit ElemType deriving (Show, Eq)
+
+data Table = Table TableType deriving (Show, Eq)
+
+data Memory = Memory Limit deriving (Show, Eq)
+
+data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq)
+
+data Global = Global {
+        globalType :: GlobalType,
+        initializer :: Expression
+    }
+    deriving (Show, Eq)
+
+data ElemSegment = ElemSegment {
+        tableIndex :: TableIndex,
+        offset :: [Instruction],
+        funcIndexes :: [FuncIndex]
+    }
+    deriving (Show, Eq)
+
+data DataSegment = DataSegment {
+        memIndex :: MemoryIndex,
+        offset :: Expression,
+        initializer :: LBS.ByteString
+    }
+    deriving (Show, Eq)
+
+data StartFunction = StartFunction FuncIndex deriving (Show, Eq)
+
+data ExportDesc =
+    ExportFunc FuncIndex
+    | ExportTable TableIndex
+    | ExportMemory MemoryIndex
+    | ExportGlobal GlobalIndex
+    deriving (Show, Eq)
+
+data Export = Export {
+        name :: TL.Text,
+        desc :: ExportDesc
+    }
+    deriving (Show, Eq)
+
+data ImportDesc =
+    ImportFunc TypeIndex
+    | ImportTable TableType
+    | ImportMemory Limit
+    | ImportGlobal GlobalType
+    deriving (Show, Eq)
+
+data Import = Import {
+        sourceModule :: TL.Text,
+        name :: TL.Text,
+        desc :: ImportDesc
+    } deriving (Show, Eq)
+
+data Module = Module {
+        types :: [FuncType],
+        functions :: [Function],
+        tables :: [Table],
+        mems :: [Memory],
+        globals :: [Global],
+        elems :: [ElemSegment],
+        datas :: [DataSegment],
+        start :: Maybe StartFunction,
+        imports :: [Import],
+        exports :: [Export]
+    } deriving (Show, Eq)

wasm.cabal

@@ -35,6 +35,7 @@ library
   exposed-modules:
       Language.Wasm.Lexer
       Language.Wasm.Parser
+      Language.Wasm.Structure
       Language.Wasm
   other-modules:
       Paths_wasm