Types.hsc

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving #-}

module Quickjs.Types where

import qualified Data.Map                  as Map
import           Data.Bits                 (Bits)
import           Foreign.C.Types
import           Foreign.Ptr               (plusPtr)
import           Foreign.Storable          (Storable(..))
import           Language.C.Inline
import           Language.C.Inline.Context (Context(..), TypesTable)
import qualified Language.C.Types          as C

#include "quickjs.h"

data JSValue = JSValue
  { u :: {-# UNPACK #-} !CDouble
  , tag :: {-# UNPACK #-} !CLong
  } deriving (Show, Eq)

instance Storable JSValue where
  sizeOf _ = #{size JSValue}
  alignment _ = #{alignment JSValue}
  peek ptr = do
    u <- peek (#{ptr JSValue, u} ptr)
    tag <- peek (#{ptr JSValue, tag} ptr)
    Prelude.pure (JSValue u tag)
  poke ptr (JSValue u tag) = do
    poke (#{ptr JSValue, u} ptr) u
    poke (#{ptr JSValue, tag} ptr) tag

type JSValueConst = JSValue

newtype JSRuntime = JSRuntime { _unusedRuntime :: CUChar }

newtype JSContext = JSContext { _unusedContext :: CUChar }


type JSBool = CInt

type JSAtom = CUInt


data JSPropertyEnum = JSPropertyEnum
  { is_enumerable :: {-# UNPACK #-} !JSBool
  , atom :: {-# UNPACK #-} !JSAtom
  } deriving (Show, Eq)

instance Storable JSPropertyEnum where
  sizeOf _ = #{size JSPropertyEnum}
  alignment _ = #{alignment JSPropertyEnum}
  peek ptr = do
    is_enumerable <- peek (#{ptr JSPropertyEnum, is_enumerable} ptr)
    atom <- peek (#{ptr JSPropertyEnum, atom} ptr)
    Prelude.pure (JSPropertyEnum is_enumerable atom)
  poke ptr (JSPropertyEnum is_enumerable atom) = do
    poke (#{ptr JSPropertyEnum, is_enumerable} ptr) is_enumerable
    poke (#{ptr JSPropertyEnum, atom} ptr) atom



data JSRefCountHeader = JSRefCountHeader
  { ref_count :: {-# UNPACK #-} !CInt
  } deriving (Show, Eq)

instance Storable JSRefCountHeader where
  sizeOf _ = #{size JSRefCountHeader}
  alignment _ = #{alignment JSRefCountHeader}
  peek ptr = do
    ref_count <- peek (#{ptr JSRefCountHeader, ref_count} ptr)
    Prelude.pure (JSRefCountHeader ref_count)
  poke ptr (JSRefCountHeader ref_count) = do
    poke (#{ptr JSRefCountHeader, ref_count} ptr) ref_count



class ToCType ty cty where
  toCType :: ty -> cty


class FromCType ty cty where
  fromCType :: cty -> Maybe ty


data JSTagEnum = JSTagFirst
               | JSTagBigDecimal
               | JSTagBigInt
               | JSTagBigFloat
               | JSTagSymbol
               | JSTagString
               | JSTagModule
               | JSTagFunctionBytecode
               | JSTagObject
               | JSTagInt
               | JSTagBool
               | JSTagNull
               | JSTagUndefined
               | JSTagUninitialized
               | JSTagCatchOffset
               | JSTagException
               | JSTagFloat64
  deriving (Show, Eq)
  
instance Num a => ToCType JSTagEnum a where
  toCType JSTagFirst            = #{const JS_TAG_FIRST}
  toCType JSTagBigDecimal       = #{const JS_TAG_BIG_DECIMAL}
  toCType JSTagBigInt           = #{const JS_TAG_BIG_INT}
  toCType JSTagBigFloat         = #{const JS_TAG_BIG_FLOAT}
  toCType JSTagSymbol           = #{const JS_TAG_SYMBOL}
  toCType JSTagString           = #{const JS_TAG_STRING}
  toCType JSTagModule           = #{const JS_TAG_MODULE}
  toCType JSTagFunctionBytecode = #{const JS_TAG_FUNCTION_BYTECODE}
  toCType JSTagObject           = #{const JS_TAG_OBJECT}
  toCType JSTagInt              = #{const JS_TAG_INT}
  toCType JSTagBool             = #{const JS_TAG_BOOL}
  toCType JSTagNull             = #{const JS_TAG_NULL}
  toCType JSTagUndefined        = #{const JS_TAG_UNDEFINED}
  toCType JSTagUninitialized    = #{const JS_TAG_UNINITIALIZED}
  toCType JSTagCatchOffset      = #{const JS_TAG_CATCH_OFFSET}
  toCType JSTagException        = #{const JS_TAG_EXCEPTION}
  toCType JSTagFloat64          = #{const JS_TAG_FLOAT64}


instance (Eq a, Num a) => FromCType JSTagEnum a where
  fromCType (#{const JS_TAG_BIG_DECIMAL}) = Just JSTagBigDecimal
  fromCType (#{const JS_TAG_BIG_INT}) = Just JSTagBigInt
  fromCType (#{const JS_TAG_BIG_FLOAT}) = Just JSTagBigFloat
  fromCType (#{const JS_TAG_SYMBOL}) = Just JSTagSymbol
  fromCType (#{const JS_TAG_STRING}) = Just JSTagString
  fromCType (#{const JS_TAG_MODULE}) = Just JSTagModule
  fromCType (#{const JS_TAG_FUNCTION_BYTECODE}) = Just JSTagFunctionBytecode
  fromCType (#{const JS_TAG_OBJECT}) = Just JSTagObject
  fromCType (#{const JS_TAG_INT}) = Just JSTagInt
  fromCType (#{const JS_TAG_BOOL}) = Just JSTagBool
  fromCType (#{const JS_TAG_NULL}) = Just JSTagNull
  fromCType (#{const JS_TAG_UNDEFINED}) = Just JSTagUndefined
  fromCType (#{const JS_TAG_UNINITIALIZED}) = Just JSTagUninitialized
  fromCType (#{const JS_TAG_CATCH_OFFSET}) = Just JSTagCatchOffset
  fromCType (#{const JS_TAG_EXCEPTION}) = Just JSTagException 
  fromCType (#{const JS_TAG_FLOAT64}) = Just JSTagFloat64
  fromCType _ = Nothing

data JSTypeEnum = JSTypeFromTag JSTagEnum
                | JSIsNumber
                | JSIsArray
                | JSIsDate
                | JSIsError
  deriving Show

data JSEvalType = Global | Module

  
instance Num a => ToCType JSEvalType a where
  toCType Global = #{const JS_EVAL_TYPE_GLOBAL}
  toCType Module = #{const JS_EVAL_TYPE_MODULE}


newtype JSGPNMask = JSGPNMask { unJSGPNMask :: CInt }
  deriving (Eq, Bits)

#{enum JSGPNMask, JSGPNMask
, jsGPNStringMask  = JS_GPN_STRING_MASK
, jsGPNSymbolMask  = JS_GPN_SYMBOL_MASK
, jsGPNPrivateMask = JS_GPN_PRIVATE_MASK
, jsGPNEnumOnly    = JS_GPN_ENUM_ONLY
, jsGPNSetEnum     = JS_GPN_SET_ENUM
}


quickjsCtx :: Context
quickjsCtx = baseCtx <> fptrCtx <> ctx
  where
    ctx = mempty
      { ctxTypesTable = quickjsTypesTable
      }

quickjsTypesTable :: TypesTable
quickjsTypesTable = Map.fromList
  [ 
    (C.TypeName "JSValue", [t| JSValue |])
  , (C.TypeName "JSValueConst", [t| JSValueConst |])
  , (C.TypeName "JSRuntime", [t| JSRuntime |])
  , (C.TypeName "JSContext", [t| JSContext |])
  , (C.TypeName "JSBool", [t| JSBool |])
  , (C.TypeName "JSAtom", [t| JSAtom |])
  , (C.TypeName "JSPropertyEnum", [t| JSPropertyEnum |])
  ]