{
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}

module Language.Wasm.Parser (
    parseModule,
    parseModuleFields,
    desugarize,
    ModuleField(..),
    DataSegment(..),
    ElemSegment(..),
    StartFunction(..),
    Export(..),
    ExportDesc(..),
    Table(..),
    Memory(..),
    Global(..),
    Function(..),
    LocalType(..),
    Import(..),
    ImportDesc(..),
    Instruction(..),
    TypeUse(..),
    TypeDef(..),
    PlainInstr(..),
    Index(..),
    Ident(..),
    ParamType(..),
    FuncType(..)
) where

import Language.Wasm.Structure (
        MemArg(..),
        IUnOp(..),
        IBinOp(..),
        IRelOp(..),
        FUnOp(..),
        FBinOp(..),
        FRelOp(..),
        BitSize(..),
        TableType(..),
        ElemType(..),
        Limit(..),
        GlobalType(..),
        ValueType(..)
    )

import qualified Language.Wasm.Structure as S

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLEncoding
import qualified Data.Text.Lazy.Read as TLRead

import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (fromMaybe)
import Data.List (foldl', findIndex, find)
import Control.Monad (guard)

import Numeric.Natural (Natural)

import Language.Wasm.Lexer (
        Token (
            TKeyword,
            TIntLit,
            TFloatLit,
            TStringLit,
            TId,
            TOpenBracket,
            TCloseBracket,
            TReserved,
            EOF
        ),
        Lexeme(..),
        AlexPosn(..)
    )

import Debug.Trace as Debug

}

%name parseModule mod
%name parseModuleFields modAsFields
%tokentype { Lexeme }

%token

'('                   { Lexeme _ TOpenBracket }
')'                   { Lexeme _ TCloseBracket }
'func'                { Lexeme _ (TKeyword "func") }
'param'               { Lexeme _ (TKeyword "param") }
'result'              { Lexeme _ (TKeyword "result") }
'i32'                 { Lexeme _ (TKeyword "i32") }
'i64'                 { Lexeme _ (TKeyword "i64") }
'f32'                 { Lexeme _ (TKeyword "f32") }
'f64'                 { Lexeme _ (TKeyword "f64") }
'mut'                 { Lexeme _ (TKeyword "mut") }
'anyfunc'             { Lexeme _ (TKeyword "anyfunc") }
'type'                { Lexeme _ (TKeyword "type") }
'unreachable'         { Lexeme _ (TKeyword "unreachable") }
'nop'                 { Lexeme _ (TKeyword "nop") }
'br'                  { Lexeme _ (TKeyword "br") }
'br_if'               { Lexeme _ (TKeyword "br_if") }
'br_table'            { Lexeme _ (TKeyword "br_table") }
'return'              { Lexeme _ (TKeyword "return") }
'call'                { Lexeme _ (TKeyword "call") }
'call_indirect'       { Lexeme _ (TKeyword "call_indirect") }
'drop'                { Lexeme _ (TKeyword "drop") }
'select'              { Lexeme _ (TKeyword "select") }
'get_local'           { Lexeme _ (TKeyword "get_local") }
'set_local'           { Lexeme _ (TKeyword "set_local") }
'tee_local'           { Lexeme _ (TKeyword "tee_local") }
'get_global'          { Lexeme _ (TKeyword "get_global") }
'set_global'          { Lexeme _ (TKeyword "set_global") }
'i32.load'            { Lexeme _ (TKeyword "i32.load") }
'i64.load'            { Lexeme _ (TKeyword "i64.load") }
'f32.load'            { Lexeme _ (TKeyword "f32.load") }
'f64.load'            { Lexeme _ (TKeyword "f64.load") }
'i32.load8_s'         { Lexeme _ (TKeyword "i32.load8_s") }
'i32.load8_u'         { Lexeme _ (TKeyword "i32.load8_u") }
'i32.load16_s'        { Lexeme _ (TKeyword "i32.load16_s") }
'i32.load16_u'        { Lexeme _ (TKeyword "i32.load16_u") }
'i64.load8_s'         { Lexeme _ (TKeyword "i64.load8_s") }
'i64.load8_u'         { Lexeme _ (TKeyword "i64.load8_u") }
'i64.load16_s'        { Lexeme _ (TKeyword "i64.load16_s") }
'i64.load16_u'        { Lexeme _ (TKeyword "i64.load16_u") }
'i64.load32_s'        { Lexeme _ (TKeyword "i64.load32_s") }
'i64.load32_u'        { Lexeme _ (TKeyword "i64.load32_u") }
'i32.store'           { Lexeme _ (TKeyword "i32.store") }
'i64.store'           { Lexeme _ (TKeyword "i64.store") }
'f32.store'           { Lexeme _ (TKeyword "f32.store") }
'f64.store'           { Lexeme _ (TKeyword "f64.store") }
'i32.store8'          { Lexeme _ (TKeyword "i32.store8") }
'i32.store16'         { Lexeme _ (TKeyword "i32.store16") }
'i64.store8'          { Lexeme _ (TKeyword "i64.store8") }
'i64.store16'         { Lexeme _ (TKeyword "i64.store16") }
'i64.store32'         { Lexeme _ (TKeyword "i64.store32") }
'current_memory'      { Lexeme _ (TKeyword "current_memory") }
'grow_memory'         { Lexeme _ (TKeyword "grow_memory") }
'i32.const'           { Lexeme _ (TKeyword "i32.const") }
'i64.const'           { Lexeme _ (TKeyword "i64.const") }
'f32.const'           { Lexeme _ (TKeyword "f32.const") }
'f64.const'           { Lexeme _ (TKeyword "f64.const") }
'i32.clz'             { Lexeme _ (TKeyword "i32.clz") }
'i32.ctz'             { Lexeme _ (TKeyword "i32.ctz") }
'i32.popcnt'          { Lexeme _ (TKeyword "i32.popcnt") }
'i32.add'             { Lexeme _ (TKeyword "i32.add") }
'i32.sub'             { Lexeme _ (TKeyword "i32.sub") }
'i32.mul'             { Lexeme _ (TKeyword "i32.mul") }
'i32.div_s'           { Lexeme _ (TKeyword "i32.div_s") }
'i32.div_u'           { Lexeme _ (TKeyword "i32.div_u") }
'i32.rem_s'           { Lexeme _ (TKeyword "i32.rem_s") }
'i32.rem_u'           { Lexeme _ (TKeyword "i32.rem_u") }
'i32.and'             { Lexeme _ (TKeyword "i32.and") }
'i32.or'              { Lexeme _ (TKeyword "i32.or") }
'i32.xor'             { Lexeme _ (TKeyword "i32.xor") }
'i32.shl'             { Lexeme _ (TKeyword "i32.shl") }
'i32.shr_s'           { Lexeme _ (TKeyword "i32.shr_s") }
'i32.shr_u'           { Lexeme _ (TKeyword "i32.shr_u") }
'i32.rotl'            { Lexeme _ (TKeyword "i32.rotl") }
'i32.rotr'            { Lexeme _ (TKeyword "i32.rotr") }
'i64.clz'             { Lexeme _ (TKeyword "i64.clz") }
'i64.ctz'             { Lexeme _ (TKeyword "i64.ctz") }
'i64.popcnt'          { Lexeme _ (TKeyword "i64.popcnt") }
'i64.add'             { Lexeme _ (TKeyword "i64.add") }
'i64.sub'             { Lexeme _ (TKeyword "i64.sub") }
'i64.mul'             { Lexeme _ (TKeyword "i64.mul") }
'i64.div_s'           { Lexeme _ (TKeyword "i64.div_s") }
'i64.div_u'           { Lexeme _ (TKeyword "i64.div_u") }
'i64.rem_s'           { Lexeme _ (TKeyword "i64.rem_s") }
'i64.rem_u'           { Lexeme _ (TKeyword "i64.rem_u") }
'i64.and'             { Lexeme _ (TKeyword "i64.and") }
'i64.or'              { Lexeme _ (TKeyword "i64.or") }
'i64.xor'             { Lexeme _ (TKeyword "i64.xor") }
'i64.shl'             { Lexeme _ (TKeyword "i64.shl") }
'i64.shr_s'           { Lexeme _ (TKeyword "i64.shr_s") }
'i64.shr_u'           { Lexeme _ (TKeyword "i64.shr_u") }
'i64.rotl'            { Lexeme _ (TKeyword "i64.rotl") }
'i64.rotr'            { Lexeme _ (TKeyword "i64.rotr") }
'f32.abs'             { Lexeme _ (TKeyword "f32.abs") }
'f32.neg'             { Lexeme _ (TKeyword "f32.neg") }
'f32.ceil'            { Lexeme _ (TKeyword "f32.ceil") }
'f32.floor'           { Lexeme _ (TKeyword "f32.floor") }
'f32.trunc'           { Lexeme _ (TKeyword "f32.trunc") }
'f32.nearest'         { Lexeme _ (TKeyword "f32.nearest") }
'f32.sqrt'            { Lexeme _ (TKeyword "f32.sqrt") }
'f32.add'             { Lexeme _ (TKeyword "f32.add") }
'f32.sub'             { Lexeme _ (TKeyword "f32.sub") }
'f32.mul'             { Lexeme _ (TKeyword "f32.mul") }
'f32.div'             { Lexeme _ (TKeyword "f32.div") }
'f32.min'             { Lexeme _ (TKeyword "f32.min") }
'f32.max'             { Lexeme _ (TKeyword "f32.max") }
'f32.copysign'        { Lexeme _ (TKeyword "f32.copysign") }
'f64.abs'             { Lexeme _ (TKeyword "f64.abs") }
'f64.neg'             { Lexeme _ (TKeyword "f64.neg") }
'f64.ceil'            { Lexeme _ (TKeyword "f64.ceil") }
'f64.floor'           { Lexeme _ (TKeyword "f64.floor") }
'f64.trunc'           { Lexeme _ (TKeyword "f64.trunc") }
'f64.nearest'         { Lexeme _ (TKeyword "f64.nearest") }
'f64.sqrt'            { Lexeme _ (TKeyword "f64.sqrt") }
'f64.add'             { Lexeme _ (TKeyword "f64.add") }
'f64.sub'             { Lexeme _ (TKeyword "f64.sub") }
'f64.mul'             { Lexeme _ (TKeyword "f64.mul") }
'f64.div'             { Lexeme _ (TKeyword "f64.div") }
'f64.min'             { Lexeme _ (TKeyword "f64.min") }
'f64.max'             { Lexeme _ (TKeyword "f64.max") }
'f64.copysign'        { Lexeme _ (TKeyword "f64.copysign") }
'i32.eqz'             { Lexeme _ (TKeyword "i32.eqz") }
'i32.eq'              { Lexeme _ (TKeyword "i32.eq") }
'i32.ne'              { Lexeme _ (TKeyword "i32.ne") }
'i32.lt_s'            { Lexeme _ (TKeyword "i32.lt_s") }
'i32.lt_u'            { Lexeme _ (TKeyword "i32.lt_u") }
'i32.gt_s'            { Lexeme _ (TKeyword "i32.gt_s") }
'i32.gt_u'            { Lexeme _ (TKeyword "i32.gt_u") }
'i32.le_s'            { Lexeme _ (TKeyword "i32.le_s") }
'i32.le_u'            { Lexeme _ (TKeyword "i32.le_u") }
'i32.ge_s'            { Lexeme _ (TKeyword "i32.ge_s") }
'i32.ge_u'            { Lexeme _ (TKeyword "i32.ge_u") }
'i64.eqz'             { Lexeme _ (TKeyword "i64.eqz") }
'i64.eq'              { Lexeme _ (TKeyword "i64.eq") }
'i64.ne'              { Lexeme _ (TKeyword "i64.ne") }
'i64.lt_s'            { Lexeme _ (TKeyword "i64.lt_s") }
'i64.lt_u'            { Lexeme _ (TKeyword "i64.lt_u") }
'i64.gt_s'            { Lexeme _ (TKeyword "i64.gt_s") }
'i64.gt_u'            { Lexeme _ (TKeyword "i64.gt_u") }
'i64.le_s'            { Lexeme _ (TKeyword "i64.le_s") }
'i64.le_u'            { Lexeme _ (TKeyword "i64.le_u") }
'i64.ge_s'            { Lexeme _ (TKeyword "i64.ge_s") }
'i64.ge_u'            { Lexeme _ (TKeyword "i64.ge_u") }
'f32.eq'              { Lexeme _ (TKeyword "f32.eq") }
'f32.ne'              { Lexeme _ (TKeyword "f32.ne") }
'f32.lt'              { Lexeme _ (TKeyword "f32.lt") }
'f32.gt'              { Lexeme _ (TKeyword "f32.gt") }
'f32.le'              { Lexeme _ (TKeyword "f32.le") }
'f32.ge'              { Lexeme _ (TKeyword "f32.ge") }
'f64.eq'              { Lexeme _ (TKeyword "f64.eq") }
'f64.ne'              { Lexeme _ (TKeyword "f64.ne") }
'f64.lt'              { Lexeme _ (TKeyword "f64.lt") }
'f64.gt'              { Lexeme _ (TKeyword "f64.gt") }
'f64.le'              { Lexeme _ (TKeyword "f64.le") }
'f64.ge'              { Lexeme _ (TKeyword "f64.ge") }
'i32.wrap/i64'        { Lexeme _ (TKeyword "i32.wrap/i64") }
'i32.trunc_s/f32'     { Lexeme _ (TKeyword "i32.trunc_s/f32") }
'i32.trunc_u/f32'     { Lexeme _ (TKeyword "i32.trunc_u/f32") }
'i32.trunc_s/f64'     { Lexeme _ (TKeyword "i32.trunc_s/f64") }
'i32.trunc_u/f64'     { Lexeme _ (TKeyword "i32.trunc_u/f64") }
'i64.extend_s/i32'    { Lexeme _ (TKeyword "i64.extend_s/i32") }
'i64.extend_u/i32'    { Lexeme _ (TKeyword "i64.extend_u/i32") }
'i64.trunc_s/f32'     { Lexeme _ (TKeyword "i64.trunc_s/f32") }
'i64.trunc_u/f32'     { Lexeme _ (TKeyword "i64.trunc_u/f32") }
'i64.trunc_s/f64'     { Lexeme _ (TKeyword "i64.trunc_s/f64") }
'i64.trunc_u/f64'     { Lexeme _ (TKeyword "i64.trunc_u/f64") }
'f32.convert_s/i32'   { Lexeme _ (TKeyword "f32.convert_s/i32") }
'f32.convert_u/i32'   { Lexeme _ (TKeyword "f32.convert_u/i32") }
'f32.convert_s/i64'   { Lexeme _ (TKeyword "f32.convert_s/i64") }
'f32.convert_u/i64'   { Lexeme _ (TKeyword "f32.convert_u/i64") }
'f32.demote/f64'      { Lexeme _ (TKeyword "f32.demote/f64") }
'f64.convert_s/i32'   { Lexeme _ (TKeyword "f64.convert_s/i32") }
'f64.convert_u/i32'   { Lexeme _ (TKeyword "f64.convert_u/i32") }
'f64.convert_s/i64'   { Lexeme _ (TKeyword "f64.convert_s/i64") }
'f64.convert_u/i64'   { Lexeme _ (TKeyword "f64.convert_u/i64") }
'f64.promote/f32'     { Lexeme _ (TKeyword "f64.promote/f32") }
'i32.reinterpret/f32' { Lexeme _ (TKeyword "i32.reinterpret/f32") }
'i64.reinterpret/f64' { Lexeme _ (TKeyword "i64.reinterpret/f64") }
'f32.reinterpret/i32' { Lexeme _ (TKeyword "f32.reinterpret/i32") }
'f64.reinterpret/i64' { Lexeme _ (TKeyword "f64.reinterpret/i64") }
'block'               { Lexeme _ (TKeyword "block") }
'loop'                { Lexeme _ (TKeyword "loop") }
'if'                  { Lexeme _ (TKeyword "if") }
'else'                { Lexeme _ (TKeyword "else") }
-- unused now 'end'                 { Lexeme _ (TKeyword "end") }
'then'                { Lexeme _ (TKeyword "then") }
'table'               { Lexeme _ (TKeyword "table") }
'memory'              { Lexeme _ (TKeyword "memory") }
'global'              { Lexeme _ (TKeyword "global") }
'import'              { Lexeme _ (TKeyword "import") }
'export'              { Lexeme _ (TKeyword "export") }
'local'               { Lexeme _ (TKeyword "local") }
'elem'                { Lexeme _ (TKeyword "elem") }
'data'                { Lexeme _ (TKeyword "data") }
'offset'              { Lexeme _ (TKeyword "offset") }
'start'               { Lexeme _ (TKeyword "start") }
'module'              { Lexeme _ (TKeyword "module") }
id                    { Lexeme _ (TId $$) }
u32                   { Lexeme _ (TIntLit (asUInt32 -> Just $$)) }
i32                   { Lexeme _ (TIntLit (asInt32 -> Just $$)) }
i64                   { Lexeme _ (TIntLit (asInt64 -> Just $$)) }
f32                   { Lexeme _ (TFloatLit (asFloat32 -> $$)) }
f64                   { Lexeme _ (TFloatLit (asFloat64 -> $$)) }
offset                { Lexeme _ (TKeyword (asOffset -> Just $$)) }
align                 { Lexeme _ (TKeyword (asAlign -> Just $$)) }
string                { Lexeme _ (TStringLit (asString -> Just $$)) }
EOF                   { Lexeme _ EOF }

%%

functype :: { FuncType }
    : '(' 'func' params_results { $3 }

params_results :: { FuncType }
    : ')' { FuncType [] [] }
    | '(' paramsresultstypeuse ')' { $2 }

name :: { TL.Text }
    : string { $1 }

ident :: { Ident }
    : id { Ident (TL.toStrict (TLEncoding.decodeUtf8 $1)) }

valtype :: { ValueType }
    : 'i32' { I32 }
    | 'i64' { I64 }
    | 'f32' { F32 }
    | 'f64' { F64 }

labelidx :: { LabelIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

funcidx :: { FuncIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

typeidx :: { TypeIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

localidx :: { LocalIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

globalidx :: { GlobalIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

tableidx :: { TableIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

memidx :: { MemoryIndex }
    : u32 { Index $1 }
    | ident { Named $1 }

int32 :: { Integer }
    : u32 { fromIntegral $1 }
    | i32 { $1 }

int64 :: { Integer }
    : u32 { fromIntegral $1 }
    | i32 { $1 }
    | i64 { $1 }

float32 :: { Float }
    : u32 { fromIntegral $1 }
    | i32 { fromIntegral $1 }
    | f32 { $1 }

float64 :: { Double }
    : u32 { fromIntegral $1 }
    | i32 { fromIntegral $1 }
    | f32 { realToFrac $1 }
    | f64 { realToFrac $1 }

plaininstr :: { PlainInstr }
    -- control instructions
    : 'unreachable'                  { Unreachable }
    | 'nop'                          { Nop }
    | 'br' labelidx                  { Br $2 }
    | 'br_if' labelidx               { BrIf $2 }
    | 'br_table' rev_list1(labelidx) { BrTable (reverse $ tail $2) (head $2) }
    | 'return'                       { Return }
    | 'call' funcidx                 { Call $2 }
    -- | 'call_indirect' typeuse        { CallIndirect $2 }
    -- call_inderict has special case in folded form
    -- parametric instructions
    | 'drop'                         { Drop }
    | 'select'                       { Select }
    -- variable instructions
    | 'get_local' localidx           { GetLocal $2 }
    | 'set_local' localidx           { SetLocal $2 }
    | 'tee_local' localidx           { TeeLocal $2 }
    | 'get_global' globalidx         { GetGlobal $2 }
    | 'set_global' globalidx         { SetGlobal $2 }
    -- memory instructions
    | 'i32.load' memarg4             { I32Load $2 }
    | 'i64.load' memarg8             { I64Load $2 }
    | 'f32.load' memarg4             { F32Load $2 }
    | 'f64.load' memarg8             { F64Load $2 }
    | 'i32.load8_s' memarg1          { I32Load8S $2 }
    | 'i32.load8_u' memarg1          { I32Load8U $2 }
    | 'i32.load16_s' memarg2         { I32Load16S $2 }
    | 'i32.load16_u' memarg2         { I32Load16U $2 }
    | 'i64.load8_s' memarg1          { I64Load8S $2 }
    | 'i64.load8_u' memarg1          { I64Load8U $2 }
    | 'i64.load16_s' memarg2         { I64Load16S $2 }
    | 'i64.load16_u' memarg2         { I64Load16U $2 }
    | 'i64.load32_s' memarg4         { I64Load32S $2 }
    | 'i64.load32_u' memarg4         { I64Load32U $2 }
    | 'i32.store' memarg4            { I32Store $2 }
    | 'i64.store' memarg8            { I64Store $2 }
    | 'f32.store' memarg4            { F32Store $2 }
    | 'f64.store' memarg8            { F64Store $2 }
    | 'i32.store8' memarg1           { I32Store8 $2 }
    | 'i32.store16' memarg2          { I32Store16 $2 }
    | 'i64.store8' memarg1           { I64Store8 $2 }
    | 'i64.store16' memarg2          { I64Store16 $2 }
    | 'i64.store32' memarg4          { I64Store32 $2 }
    | 'current_memory'               { CurrentMemory }
    | 'grow_memory'                  { GrowMemory }
    -- numeric instructions
    | 'i32.const' int32              { I32Const $2 }
    | 'i64.const' int64              { I64Const $2 }
    | 'f32.const' float32            { F32Const $2 }
    | 'f64.const' float64            { F64Const $2 }
    | 'i32.clz'                      { IUnOp BS32 IClz }
    | 'i32.ctz'                      { IUnOp BS32 ICtz }
    | 'i32.popcnt'                   { IUnOp BS32 IPopcnt }
    | 'i32.add'                      { IBinOp BS32 IAdd }
    | 'i32.sub'                      { IBinOp BS32 ISub }
    | 'i32.mul'                      { IBinOp BS32 IMul }
    | 'i32.div_s'                    { IBinOp BS32 IDivS }
    | 'i32.div_u'                    { IBinOp BS32 IDivU }
    | 'i32.rem_s'                    { IBinOp BS32 IRemS }
    | 'i32.rem_u'                    { IBinOp BS32 IRemU }
    | 'i32.and'                      { IBinOp BS32 IAnd }
    | 'i32.or'                       { IBinOp BS32 IOr }
    | 'i32.xor'                      { IBinOp BS32 IXor }
    | 'i32.shl'                      { IBinOp BS32 IShl }
    | 'i32.shr_s'                    { IBinOp BS32 IShrS }
    | 'i32.shr_u'                    { IBinOp BS32 IShrU }
    | 'i32.rotl'                     { IBinOp BS32 IRotl }
    | 'i32.rotr'                     { IBinOp BS32 IRotr }
    | 'i64.clz'                      { IUnOp BS64 IClz }
    | 'i64.ctz'                      { IUnOp BS64 ICtz }
    | 'i64.popcnt'                   { IUnOp BS64 IPopcnt }
    | 'i64.add'                      { IBinOp BS64 IAdd }
    | 'i64.sub'                      { IBinOp BS64 ISub }
    | 'i64.mul'                      { IBinOp BS64 IMul }
    | 'i64.div_s'                    { IBinOp BS64 IDivS }
    | 'i64.div_u'                    { IBinOp BS64 IDivU }
    | 'i64.rem_s'                    { IBinOp BS64 IRemS }
    | 'i64.rem_u'                    { IBinOp BS64 IRemU }
    | 'i64.and'                      { IBinOp BS64 IAnd }
    | 'i64.or'                       { IBinOp BS64 IOr }
    | 'i64.xor'                      { IBinOp BS64 IXor }
    | 'i64.shl'                      { IBinOp BS64 IShl }
    | 'i64.shr_s'                    { IBinOp BS64 IShrS }
    | 'i64.shr_u'                    { IBinOp BS64 IShrU }
    | 'i64.rotl'                     { IBinOp BS64 IRotl }
    | 'i64.rotr'                     { IBinOp BS64 IRotr }
    | 'f32.abs'                      { FUnOp BS32 FAbs }
    | 'f32.neg'                      { FUnOp BS32 FNeg }
    | 'f32.ceil'                     { FUnOp BS32 FCeil }
    | 'f32.floor'                    { FUnOp BS32 FFloor }
    | 'f32.trunc'                    { FUnOp BS32 FTrunc }
    | 'f32.nearest'                  { FUnOp BS32 FNearest }
    | 'f32.sqrt'                     { FUnOp BS32 FSqrt }
    | 'f32.add'                      { FBinOp BS32 FAdd }
    | 'f32.sub'                      { FBinOp BS32 FSub }
    | 'f32.mul'                      { FBinOp BS32 FMul }
    | 'f32.div'                      { FBinOp BS32 FDiv }
    | 'f32.min'                      { FBinOp BS32 FMin }
    | 'f32.max'                      { FBinOp BS32 FMax }
    | 'f32.copysign'                 { FBinOp BS32 FCopySign }
    | 'f64.abs'                      { FUnOp BS64 FAbs }
    | 'f64.neg'                      { FUnOp BS64 FNeg }
    | 'f64.ceil'                     { FUnOp BS64 FCeil }
    | 'f64.floor'                    { FUnOp BS64 FFloor }
    | 'f64.trunc'                    { FUnOp BS64 FTrunc }
    | 'f64.nearest'                  { FUnOp BS64 FNearest }
    | 'f64.sqrt'                     { FUnOp BS64 FSqrt }
    | 'f64.add'                      { FBinOp BS64 FAdd }
    | 'f64.sub'                      { FBinOp BS64 FSub }
    | 'f64.mul'                      { FBinOp BS64 FMul }
    | 'f64.div'                      { FBinOp BS64 FDiv }
    | 'f64.min'                      { FBinOp BS64 FMin }
    | 'f64.max'                      { FBinOp BS64 FMax }
    | 'f64.copysign'                 { FBinOp BS64 FCopySign }
    | 'i32.eqz'                      { I32Eqz }
    | 'i32.eq'                       { IRelOp BS32 IEq }
    | 'i32.ne'                       { IRelOp BS32 INe }
    | 'i32.lt_s'                     { IRelOp BS32 ILtS }
    | 'i32.lt_u'                     { IRelOp BS32 ILtU }
    | 'i32.gt_s'                     { IRelOp BS32 IGtS }
    | 'i32.gt_u'                     { IRelOp BS32 IGtU }
    | 'i32.le_s'                     { IRelOp BS32 ILeS }
    | 'i32.le_u'                     { IRelOp BS32 ILeU }
    | 'i32.ge_s'                     { IRelOp BS32 IGeS }
    | 'i32.ge_u'                     { IRelOp BS32 IGeU }
    | 'i64.eqz'                      { I64Eqz }
    | 'i64.eq'                       { IRelOp BS64 IEq }
    | 'i64.ne'                       { IRelOp BS64 INe }
    | 'i64.lt_s'                     { IRelOp BS64 ILtS }
    | 'i64.lt_u'                     { IRelOp BS64 ILtU }
    | 'i64.gt_s'                     { IRelOp BS64 IGtS }
    | 'i64.gt_u'                     { IRelOp BS64 IGtU }
    | 'i64.le_s'                     { IRelOp BS64 ILeS }
    | 'i64.le_u'                     { IRelOp BS64 ILeU }
    | 'i64.ge_s'                     { IRelOp BS64 IGeS }
    | 'i64.ge_u'                     { IRelOp BS64 IGeU }
    | 'f32.eq'                       { FRelOp BS32 FEq }
    | 'f32.ne'                       { FRelOp BS32 FNe }
    | 'f32.lt'                       { FRelOp BS32 FLt }
    | 'f32.gt'                       { FRelOp BS32 FGt }
    | 'f32.le'                       { FRelOp BS32 FLe }
    | 'f32.ge'                       { FRelOp BS32 FGe }
    | 'f64.eq'                       { FRelOp BS64 FEq }
    | 'f64.ne'                       { FRelOp BS64 FNe }
    | 'f64.lt'                       { FRelOp BS64 FLt }
    | 'f64.gt'                       { FRelOp BS64 FGt }
    | 'f64.le'                       { FRelOp BS64 FLe }
    | 'f64.ge'                       { FRelOp BS64 FGe }
    | 'i32.wrap/i64'                 { I32WrapI64 }
    | 'i32.trunc_s/f32'              { ITruncFS BS32 BS32 }
    | 'i32.trunc_u/f32'              { ITruncFU BS32 BS32 }
    | 'i32.trunc_s/f64'              { ITruncFS BS32 BS64 }
    | 'i32.trunc_u/f64'              { ITruncFU BS32 BS64 }
    | 'i64.extend_s/i32'             { I64ExtendSI32 }
    | 'i64.extend_u/i32'             { I64ExtendUI32 }
    | 'i64.trunc_s/f32'              { ITruncFS BS64 BS32 }
    | 'i64.trunc_u/f32'              { ITruncFU BS64 BS32 }
    | 'i64.trunc_s/f64'              { ITruncFS BS64 BS64 }
    | 'i64.trunc_u/f64'              { ITruncFU BS64 BS64 }
    | 'f32.convert_s/i32'            { FConvertIS BS32 BS32 }
    | 'f32.convert_u/i32'            { FConvertIU BS32 BS32 }
    | 'f32.convert_s/i64'            { FConvertIS BS32 BS64 }
    | 'f32.convert_u/i64'            { FConvertIU BS32 BS64 }
    | 'f32.demote/f64'               { F32DemoteF64 }
    | 'f64.convert_s/i32'            { FConvertIS BS64 BS32 }
    | 'f64.convert_u/i32'            { FConvertIU BS64 BS32 }
    | 'f64.convert_s/i64'            { FConvertIS BS64 BS64 }
    | 'f64.convert_u/i64'            { FConvertIU BS64 BS64 }
    | 'f64.promote/f32'              { F64PromoteF32 }
    | 'i32.reinterpret/f32'          { IReinterpretF BS32 }
    | 'i64.reinterpret/f64'          { IReinterpretF BS64 }
    | 'f32.reinterpret/i32'          { FReinterpretI BS32 }
    | 'f64.reinterpret/i64'          { FReinterpretI BS64 }

typedef :: { TypeDef }
    : 'type' opt(ident) functype ')' { TypeDef $2 $3 }

typeuse :: { TypeUse }
    : '(' typeuse1 { $2 }
    | {- empty -} { AnonimousTypeUse $ FuncType [] [] }

typeuse1 :: { TypeUse }
    : 'type' typeidx ')' typedtypeuse { IndexedTypeUse $2 $4 }
    | paramsresultstypeuse { AnonimousTypeUse $1 }

typedtypeuse :: { Maybe FuncType }
    : '(' paramsresultstypeuse { Just $2 }
    | {- empty -} { Nothing }

paramsresultstypeuse :: { FuncType }
    : paramsresultstypeuse '(' paramsresulttypeuse { mergeFuncType $1 $3 }
    | paramsresulttypeuse { $1 }

paramsresulttypeuse :: { FuncType }
    : 'param' list(valtype) ')' { FuncType (map (ParamType Nothing) $2) [] }
    | 'param' ident valtype ')' { FuncType [ParamType (Just $2) $3] [] }
    | 'result' list(valtype) ')' { FuncType [] $2 }

memarg1 :: { MemArg }
    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 1 $2) }

memarg2 :: { MemArg }
    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 2 $2) }

memarg4 :: { MemArg }
    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 4 $2) }

memarg8 :: { MemArg }
    : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 8 $2) }

foldedinstr :: { [Instruction] }
    : '(' foldedinstr1 { $2 }

foldedinstr1 :: { [Instruction] }
    : plaininstr list(foldedinstr) ')' { concat $2 ++ [PlainInstr $1] }
    | 'call_indirect' folded_call_indirect { $2 }
    | 'block' opt(ident) folded_block { [$3 $2] }
    | 'loop' opt(ident) folded_loop { [$3 $2] }
    | 'if' opt(ident) '(' folded_if_result { $4 $2 }

folded_block :: { Maybe Ident -> Instruction }
    : ')' { \ident -> BlockInstr ident [] [] }
    | '(' folded_block1 { $2 }

folded_block1 :: { Maybe Ident -> Instruction }
    : 'result' valtype ')' list(foldedinstr) ')' { \ident -> BlockInstr ident [$2] (concat $4) }
    | foldedinstr1 list(foldedinstr) ')' { \ident -> BlockInstr ident [] ($1 ++ concat $2) }

folded_loop :: { Maybe Ident -> Instruction }
    : ')' { \ident -> LoopInstr ident [] [] }
    | '(' folded_loop1 { $2 }

folded_loop1 :: { Maybe Ident -> Instruction }
    : 'result' valtype ')' list(foldedinstr) ')' { \ident -> LoopInstr ident [$2] (concat $4) }
    | foldedinstr1 list(foldedinstr) ')' { \ident -> LoopInstr ident [] ($1 ++ concat $2) }

folded_if_result :: { Maybe Ident -> [Instruction] }
    : 'result' valtype ')' '(' folded_then_else { \ident -> [IfInstr ident [$2] (fst $5) (snd $5)] }
    | 'result' valtype ')' '(' foldedinstr1 '(' folded_then_else { \ident -> $5 ++ [IfInstr ident [$2] (fst $7) (snd $7)] }
    | folded_if { $1 }

folded_if :: { Maybe Ident -> [Instruction] }
    : folded_then_else { \ident -> [IfInstr ident [] (fst $1) (snd $1)] }
    | foldedinstr1 '(' folded_then_else { \ident -> $1 ++ [IfInstr ident [] (fst $3) (snd $3)] }

folded_then_else :: { ([Instruction], [Instruction]) }
    : 'then' list(foldedinstr) ')' folded_else { (concat $2, $4)}

folded_else :: { [Instruction] }
    : ')' { [] }
    | '(' 'else' list(foldedinstr) ')' ')' { concat $3 }

folded_call_indirect :: { [Instruction] }
    : ')' { [PlainInstr $ CallIndirect $ AnonimousTypeUse $ FuncType [] []] }
    | '(' folded_call_indirect_typeuse { (PlainInstr $ CallIndirect $ fst $2) : snd $2 }

folded_call_indirect_typeuse :: { (TypeUse, [Instruction]) }
    : 'type' typeidx ')' folded_call_indirect_functype {
        (IndexedTypeUse $2 $ fst $4, snd $4)
    }
    | folded_call_indirect_functype1 {
        (AnonimousTypeUse $ fromMaybe (FuncType [] []) $ fst $1, snd $1)
    }

folded_call_indirect_functype :: { (Maybe FuncType, [Instruction]) }
    : '(' folded_call_indirect_functype1 { $2 }
    | ')' { (Nothing, []) }

folded_call_indirect_functype1 :: { (Maybe FuncType, [Instruction]) }
    : paramsresulttypeuse folded_call_indirect_functype {
        (Just $ mergeFuncType $1 $ fromMaybe emptyFuncType $ fst $2, snd $2)
    }
    | foldedinstr1 list(foldedinstr) ')' { (Nothing, $1 ++ concat $2) }

importdesc :: { ImportDesc }
    : 'func' opt(ident) typeuse ')' { ImportFunc $2 $3 }
    | 'table' opt(ident) tabletype ')' { ImportTable $2 $3 }
    | 'memory' opt(ident) limits ')' { ImportMemory $2 $3 }
    | 'global' opt(ident) globaltype ')' { ImportGlobal $2 $3 }

import :: { Import }
    : 'import' name name '(' importdesc ')' { Import $2 $3 $5 }

-- FUNCTION --
function :: { [ModuleField] }
    : 'func' opt(ident) export_import_typeuse_locals_body { $3 $2 }

export_import_typeuse_locals_body :: { Maybe Ident -> [ModuleField] }
    : ')' { \ident -> [MFFunc $ Function ident (AnonimousTypeUse $ FuncType [] []) [] []] }
    | '(' export_import_typeuse_locals_body1 { $2 }

export_import_typeuse_locals_body1 :: { Maybe Ident -> [ModuleField] }
    : 'export' name ')' export_import_typeuse_locals_body {
        \ident -> (MFExport $ Export $2 $ ExportFunc (Named `fmap` ident)) : ($4 ident)
    }
    | import_typeuse_locals_body1 { \ident -> [$1 ident] }

import_typeuse_locals_body1 :: { Maybe Ident -> ModuleField }
    : 'import' name name ')' typeuse ')' {
        \ident -> MFImport $ Import $2 $3 $ ImportFunc ident $5
    }
    | typeuse_locals_body1 { MFFunc . $1 }

typeuse_locals_body1 :: { Maybe Ident -> Function }
    : 'type' typeidx ')' signature_locals_body {
        \i ->
            let (AnonimousTypeUse signature) = funcType $4 in
            let typeSign = if signature == emptyFuncType then Nothing else Just signature in
            $4 { funcType = IndexedTypeUse $2 typeSign, ident = i }
    }
    | signature_locals_body1 { \i -> $1 { ident = i } }

signature_locals_body :: { Function }
    : ')' { emptyFunction }
    | '(' signature_locals_body1 { $2 }

signature_locals_body1 :: { Function }
    : 'param' list(valtype) ')' signature_locals_body {
        prependFuncParams (map (ParamType Nothing) $2) $4
    }
    | 'param' ident valtype ')' signature_locals_body {
        prependFuncParams [ParamType (Just $2) $3] $5
    }
    | 'result' list(valtype) ')' signature_locals_body {
        prependFuncResults $2 $4
    }
    | locals_body1 {
        emptyFunction { locals = fst $1, body = snd $1 }
    } 

locals_body :: { ([LocalType], [Instruction]) }
    : ')' { ([], []) }
    | '(' locals_body1 { $2 }

locals_body1 :: { ([LocalType], [Instruction]) }
    : 'local' list(valtype) ')' locals_body { (map (LocalType Nothing) $2 ++ fst $4, snd $4) }
    | 'local' ident valtype ')' locals_body { (LocalType (Just $2) $3 : fst $5, snd $5) }
    | foldedinstr1 list(foldedinstr) ')' { ([], $1 ++ concat $2) }

-- FUNCTION END --

-- GLOBAL --

global :: { [ModuleField] }
    : 'global' opt(ident) global_type_export_import { $3 $2 }

globaltype :: { GlobalType }
    : valtype { Const $1 }
    | '(' 'mut' valtype ')' { Mut $3 }

global_type_export_import :: { Maybe Ident -> [ModuleField] }
    : valtype list(foldedinstr) ')' { \ident -> [MFGlobal $ Global ident (Const $1) $ concat $2] }
    | '(' global_mut_export_import { $2 }

global_mut_export_import :: { Maybe Ident -> [ModuleField] }
    : 'mut' valtype ')' list(foldedinstr) ')' { \ident -> [MFGlobal $ Global ident (Mut $2) $ concat $4] }
    | 'export' name ')' global_type_export_import {
        \ident -> (MFExport $ Export $2 $ ExportGlobal $ Named `fmap` ident) : ($4 ident)
    }
    | 'import' name name ')' globaltype ')' {
        \ident -> [MFImport $ Import $2 $3 $ ImportGlobal ident $5]
    }

-- GLOBAL END --

-- MEMORY --

memory :: { [ModuleField] }
    : 'memory' opt(ident) memory_limits_export_import { $3 $2 }

memory_limits_export_import :: { Maybe Ident -> [ModuleField] }
    : memory_limits { $1 }
    | '(' memory_limits_export_import1 { $2 }

memory_limits_export_import1 :: { Maybe Ident -> [ModuleField] }
    : 'export' name ')' memory_limits_export_import {
        \ident -> (MFExport $ Export $2 $ ExportMemory $ Named `fmap` ident) : $4 ident
    }
    | 'import' name name ')' limits ')' {
        \ident -> [MFImport $ Import $2 $3 $ ImportMemory ident $5]
    }
    | 'data' string ')' ')' {
        \ident ->
            let m = fromIntegral $ TL.length $2 in
            [
                MFMem $ Memory ident $ Limit m $ Just m,
                MFData $ DataSegment (fromMaybe (Index 0) $ Named `fmap` ident) [PlainInstr $ I32Const 0] $2
            ]
    }

memory_limits :: { Maybe Ident -> [ModuleField] }
    : limits ')' { \ident -> [MFMem $ Memory ident $1] }

-- MEMOTY END --

-- TABLE --
limits :: { Limit }
    : u32 opt(u32) { Limit (fromIntegral $1) (fromIntegral `fmap` $2) }

elemtype :: { ElemType }
    : 'anyfunc' { AnyFunc }

tabletype :: { TableType }
    : limits elemtype { TableType $1 $2 }

table :: { [ModuleField] }
    : 'table' opt(ident) limits_elemtype_elem { $3 $2 }

limits_elemtype_elem :: { Maybe Ident -> [ModuleField] }
    : tabletype ')' { \ident -> [MFTable $ Table ident $1] }
    | elemtype '(' 'elem' list(funcidx) ')' ')' {
        \ident ->
            let funcsLen = fromIntegral $ length $4 in [
                MFTable $ Table ident $ TableType (Limit funcsLen (Just funcsLen)) $1,
                MFElem $ ElemSegment (fromMaybe (Index 0) $ Named `fmap` ident) [PlainInstr $ I32Const 0] $4
            ]
    }
    | '(' import_export_table { $2 }

import_export_table :: { Maybe Ident -> [ModuleField] }
    : 'import' name name ')' tabletype ')' {
        \ident -> [MFImport $ Import $2 $3 $ ImportTable ident $5]
    }
    | 'export' name ')' limits_elemtype_elem {
        \ident -> (MFExport $ Export $2 $ ExportTable $ Named `fmap` ident) : ($4 ident)
    }

-- TABLE END --

exportdesc :: { ExportDesc }
    : 'func' funcidx ')' { ExportFunc (Just $2) }
    | 'table' tableidx ')' { ExportTable (Just $2) }
    | 'memory' memidx ')' { ExportMemory (Just $2) }
    | 'global' globalidx ')' { ExportGlobal (Just $2) }

export :: { Export }
    : 'export' name '(' exportdesc ')' { Export $2 $4 }

start :: { StartFunction }
    : 'start' funcidx ')' { StartFunction $2 }

-- TODO: Spec from 09 Jan 2018 declares 'offset' keyword as mandatory,
-- but collection of testcases omits 'offset' in this position
-- I am going to support both options for now, but maybe it has to be updated in future.
offsetexpr :: { [Instruction] }
    : 'offset' foldedinstr ')' { $2 }
    | foldedinstr1 { $1 }

elemsegment :: { ElemSegment }
    : 'elem' opt(tableidx) '(' offsetexpr list(funcidx) ')' { ElemSegment (fromMaybe (Index 0) $2) $4 $5 }

datasegment :: { DataSegment }
    : 'data' opt(memidx) '(' offsetexpr list(string) ')' { DataSegment (fromMaybe (Index 0) $2) $4 (TL.concat $5) }

modulefield1_single :: { ModuleField }
    : typedef { MFType $1 }
    | import { MFImport $1 }
    | export { MFExport $1 }
    | start { MFStart $1 }
    | elemsegment { MFElem $1 }
    | datasegment { MFData $1 }

modulefield1_multi :: { [ModuleField] }
    : function { $1 }
    | table { $1 }
    | memory { $1 }
    | global { $1 }

modulefield1 :: { [ModuleField] }
    : modulefield1_single { [$1] }
    | modulefield1_multi { $1 }

modulefield :: { [ModuleField] }
    : '(' modulefield1 { $2 }

modAsFields :: { [ModuleField] }
    : '(' 'module' list(modulefield) ')' EOF { concat $3 }
    | '(' modulefield1 list(modulefield) EOF { $2 ++ concat $3}

mod :: { S.Module }
    : modAsFields { desugarize $1 }

-- utils

rev_list(p)
    : rev_list(p) p  { $2 : $1 }
    | {- empty -}    { [] }

rev_list1(p)
    : rev_list1(p) p { $2 : $1 }
    | p              { [$1] }

list(p)
    : rev_list(p)    { reverse $1 }

opt(p)
    : p { Just $1 }
    | {- empty -} { Nothing }

{

-- partial function by intention
prependFuncParams :: [ParamType] -> Function -> Function
prependFuncParams prep f@(Function { funcType = AnonimousTypeUse ft }) =
    f { funcType = AnonimousTypeUse $ ft { params = prep ++ params ft } }

prependFuncResults :: [ValueType] -> Function -> Function
prependFuncResults prep f@(Function { funcType = AnonimousTypeUse ft }) =
    f { funcType = AnonimousTypeUse $ ft { results = prep ++ results ft } }

mergeFuncType :: FuncType -> FuncType -> FuncType
mergeFuncType (FuncType lps lrs) (FuncType rps rrs) = FuncType (lps ++ rps) (lrs ++ rrs)

asUInt32 :: Integer -> Maybe Natural
asUInt32 val
    | val >= 0, val < 2 ^ 32 = Just $ fromIntegral val
    | otherwise = Nothing

asInt32 :: Integer -> Maybe Integer
asInt32 val
    | val >= -2 ^ 31, val < 2 ^ 32 = Just $ fromIntegral val
    | otherwise = Nothing

asInt64 :: Integer -> Maybe Integer
asInt64 val
    | val >= -2 ^ 63, val < 2 ^ 64 = Just $ fromIntegral val
    | otherwise = Nothing

asFloat32 :: Double -> Float
asFloat32 = realToFrac

asFloat64 :: Double -> Double
asFloat64 = id

asOffset :: LBS.ByteString -> Maybe Natural
asOffset str = do
    num <- TL.stripPrefix "offset=" $ TLEncoding.decodeUtf8 str
    fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)

asAlign :: LBS.ByteString -> Maybe Natural
asAlign str = do
    num <- TL.stripPrefix "align=" $ TLEncoding.decodeUtf8 str
    fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)

-- TODO: check name conditions.
-- Presuming the source text is itself encoded correctly,
-- strings that do not contain any uses of hexadecimal byte escapes are always valid names.
asName :: LBS.ByteString -> Maybe TL.Text
asName = Just . TLEncoding.decodeUtf8

asString :: LBS.ByteString -> Maybe TL.Text
asString = Just . TLEncoding.decodeUtf8

eitherToMaybe :: Either left right -> Maybe right
eitherToMaybe = either (const Nothing) Just

data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq)

emptyFuncType :: FuncType
emptyFuncType = FuncType [] []

data ParamType = ParamType {
        ident :: Maybe Ident,
        paramType :: ValueType
    } deriving (Show, Eq)

newtype Ident = Ident T.Text deriving (Show, Eq)

data Index = Named Ident | Index Natural deriving (Show, Eq)

type LabelIndex = Index
type FuncIndex = Index
type TypeIndex = Index
type LocalIndex = Index
type GlobalIndex = Index
type TableIndex = Index
type MemoryIndex = Index

data PlainInstr =
    -- Control instructions
    Unreachable
    | Nop
    | Br LabelIndex
    | BrIf LabelIndex
    | BrTable [LabelIndex] LabelIndex
    | Return
    | Call FuncIndex
    | CallIndirect TypeUse
    -- 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)

data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)

data TypeUse =
    IndexedTypeUse TypeIndex (Maybe FuncType)
    | AnonimousTypeUse FuncType
    deriving (Show, Eq)

data Instruction =
    PlainInstr PlainInstr
    | BlockInstr {
        label :: Maybe Ident,
        resultType :: [ValueType],
        body :: [Instruction]
    }
    | LoopInstr {
        label :: Maybe Ident,
        resultType :: [ValueType],
        body :: [Instruction]
    }
    | IfInstr {
        label :: Maybe Ident,
        resultType :: [ValueType],
        trueBranch :: [Instruction],
        falseBranch :: [Instruction]
    }
    deriving (Show, Eq)

data Import = Import {
        sourceModule :: TL.Text,
        name :: TL.Text,
        desc :: ImportDesc
    } deriving (Show, Eq)

data ImportDesc =
    ImportFunc (Maybe Ident) TypeUse
    | ImportTable (Maybe Ident) TableType
    | ImportMemory (Maybe Ident) Limit
    | ImportGlobal (Maybe Ident) GlobalType
    deriving (Show, Eq)

data LocalType = LocalType {
        ident :: Maybe Ident,
        localType :: ValueType
    } deriving (Show, Eq)

data Function = Function {
        ident :: Maybe Ident,
        funcType :: TypeUse,
        locals :: [LocalType],
        body :: [Instruction]
    }
    deriving (Show, Eq)

emptyFunction :: Function
emptyFunction =
    Function {
        ident = Nothing,
        funcType = AnonimousTypeUse emptyFuncType,
        locals = [],
        body = []
    }

data Global = Global {
        ident :: Maybe Ident,
        globalType :: GlobalType,
        initializer :: [Instruction]
    }
    deriving (Show, Eq)

data Memory = Memory (Maybe Ident) Limit deriving (Show, Eq)

data Table = Table (Maybe Ident) TableType deriving (Show, Eq)

data ExportDesc =
    ExportFunc (Maybe FuncIndex)
    | ExportTable (Maybe TableIndex)
    | ExportMemory (Maybe MemoryIndex)
    | ExportGlobal (Maybe GlobalIndex)
    deriving (Show, Eq)

data Export = Export {
        name :: TL.Text,
        desc :: ExportDesc
    }
    deriving (Show, Eq)

data StartFunction = StartFunction FuncIndex deriving (Show, Eq)

data ElemSegment = ElemSegment {
        tableIndex :: TableIndex,
        offset :: [Instruction],
        funcIndexes :: [FuncIndex]
    }
    deriving (Show, Eq)

data DataSegment = DataSegment {
        memIndex :: MemoryIndex,
        offset :: [Instruction],
        datastring :: TL.Text
    }
    deriving (Show, Eq)

data ModuleField =
    MFType TypeDef
    | MFImport Import
    | MFFunc Function
    | MFTable Table
    | MFMem Memory
    | MFGlobal Global
    | MFExport Export
    | MFStart StartFunction
    | MFElem ElemSegment
    | MFData DataSegment
    deriving(Show, Eq)

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. " ++
    "Line " ++ show line ++ ", " ++
    "Column " ++ show col ++ ", " ++
    "Token " ++ show tok ++ ". " ++
    "Token lookahed: " ++ show (take 3 tokens)

desugarize :: [ModuleField] -> S.Module
desugarize fields =
    let typeDefs = extract extractTypeDef fields in
    let imports = extract extractImport fields in
    S.emptyModule {
        S.types = map synTypeDefToStruct typeDefs,
        S.imports = map (synImportToStruct typeDefs) imports
    }
    where
        -- utils
        extract :: ([a] -> ModuleField -> [a]) -> [ModuleField] -> [a]
        extract extractor = reverse . foldl' extractor []

        findWithIndex :: (a -> Bool) -> [a] -> Maybe (a, Int)
        findWithIndex pred l = find (pred . fst) $ zip l [1..]

        -- types
        synTypeDefToStruct :: TypeDef -> S.FuncType
        synTypeDefToStruct (TypeDef _ FuncType { params, results }) =
            S.FuncType (map paramType params) results

        extractTypeDef :: [TypeDef] -> ModuleField -> [TypeDef]
        extractTypeDef defs (MFType def) = def : defs
        extractTypeDef defs (MFImport Import { desc = ImportFunc _ typeUse }) =
            matchTypeUse defs typeUse
        extractTypeDef defs (MFFunc Function { funcType, body }) =
            extractTypeDefFromInstructions (matchTypeUse defs funcType) body
        extractTypeDef defs (MFGlobal Global { initializer }) =
            extractTypeDefFromInstructions defs initializer
        extractTypeDef defs (MFElem ElemSegment { offset }) =
            extractTypeDefFromInstructions defs offset
        extractTypeDef defs (MFData DataSegment { offset }) =
            extractTypeDefFromInstructions defs offset
        extractTypeDef defs _ = defs

        extractTypeDefFromInstructions :: [TypeDef] -> [Instruction] -> [TypeDef]
        extractTypeDefFromInstructions = foldl' extractTypeDefFromInstruction

        extractTypeDefFromInstruction :: [TypeDef] -> Instruction -> [TypeDef]
        extractTypeDefFromInstruction defs (PlainInstr (CallIndirect typeUse)) =
            matchTypeUse defs typeUse
        extractTypeDefFromInstruction defs (BlockInstr { body }) =
            extractTypeDefFromInstructions defs body
        extractTypeDefFromInstruction defs (LoopInstr { body }) =
            extractTypeDefFromInstructions defs body
        extractTypeDefFromInstruction defs (IfInstr { trueBranch, falseBranch }) =
            extractTypeDefFromInstructions defs $ trueBranch ++ falseBranch
        extractTypeDefFromInstruction defs _ = defs

        funcTypesEq :: FuncType -> FuncType -> Bool
        funcTypesEq l r =
            let paramTypes = map paramType . params in
            paramTypes l == paramTypes r && results l == results r

        matchTypeFunc :: FuncType -> TypeDef -> Bool
        matchTypeFunc funcType (TypeDef _ ft) = funcTypesEq ft funcType

        matchTypeUse :: [TypeDef] -> TypeUse -> [TypeDef]
        matchTypeUse defs (AnonimousTypeUse funcType) =
            if any (matchTypeFunc funcType) defs
            then defs
            else (TypeDef Nothing funcType) : defs
        matchTypeUse defs _ = defs

        getTypeIndex :: [TypeDef] -> TypeUse -> Maybe Natural
        getTypeIndex defs (AnonimousTypeUse funcType) =
            fromIntegral <$> findIndex (matchTypeFunc funcType) defs
        getTypeIndex defs (IndexedTypeUse (Named ident) (Just funcType)) = do
            (def, idx) <- findWithIndex (\(TypeDef i _) -> i == Just ident) defs
            guard $ matchTypeFunc funcType def
            return $ fromIntegral idx
        getTypeIndex defs (IndexedTypeUse (Named ident) Nothing) =
            fromIntegral <$> findIndex (\(TypeDef i _) -> i == Just ident) defs
        getTypeIndex defs (IndexedTypeUse (Index n) (Just funcType)) = do
            guard $ length defs > fromIntegral n
            guard $ matchTypeFunc funcType $ defs !! fromIntegral n
            return n
        getTypeIndex defs (IndexedTypeUse (Index n) Nothing) = do
            guard $ length defs > fromIntegral n
            return n
        
        -- imports

        synImportToStruct :: [TypeDef] -> Import -> S.Import
        synImportToStruct defs (Import mod name (ImportFunc _ typeUse)) =
            case getTypeIndex defs typeUse of
                Just idx -> S.Import mod name $ S.ImportFunc idx
                Nothing -> error $ "cannot find type index for function import: " ++ show typeUse
        synImportToStruct _ (Import mod name (ImportTable _ tableType)) =
            S.Import mod name $ S.ImportTable tableType
        synImportToStruct _ (Import mod name (ImportMemory _ limit)) =
            S.Import mod name $ S.ImportMemory limit
        synImportToStruct _ (Import mod name (ImportGlobal _ globalType)) =
            S.Import mod name $ S.ImportGlobal globalType

        extractImport :: [Import] -> ModuleField -> [Import]
        extractImport imports (MFImport imp) = imp : imports
        extractImport imports _ = imports

        -- functions
        extractFunctions :: [ModuleField] -> [Function]
        extractFunctions = extract extractFunction

        extractFunction :: [Function] -> ModuleField -> [Function]
        extractFunction funcs (MFFunc fun) = fun : funcs
        extractFunction funcs _ = funcs

        -- tables
        extractTables :: [ModuleField] -> [Table]
        extractTables = extract extractTable

        extractTable :: [Table] -> ModuleField -> [Table]
        extractTable tables (MFTable table) = table : tables
        extractTable tables _ = tables
}