module Scripting.Duktape (
DuktapeCtx
, createDuktapeCtx
, evalDuktape
, callDuktape
, exposeFnDuktape
, Duktapeable
) where
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Control.Monad.IO.Class
import Control.Concurrent.MVar (withMVar)
import Control.Monad (void, forM_, liftM)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Foreign as TF
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HMS
import Data.Aeson
import Data.Maybe (fromMaybe)
import Scripting.Duktape.Raw
cMinusOne ∷ CInt
cMinusOne = fromIntegral $ 1
data DukType = DukNone | DukUndefined | DukNull | DukBoolean | DukNumber | DukString | DukObject | DukBuffer | DukPointer | DukLightFunc
withCtx ∷ DuktapeCtx → (Ptr DuktapeHeap → IO α) → IO α
withCtx ctx a = withMVar ctx $ \fPtr → withForeignPtr fPtr a
getTypeOnStack ∷ Ptr DuktapeHeap → Int → IO DukType
getTypeOnStack ctxPtr idx = liftM readType $ c_duk_get_type ctxPtr $ fromIntegral idx
where readType x | x == c_DUK_TYPE_NONE = DukNone
| x == c_DUK_TYPE_UNDEFINED = DukUndefined
| x == c_DUK_TYPE_NULL = DukNull
| x == c_DUK_TYPE_BOOLEAN = DukBoolean
| x == c_DUK_TYPE_NUMBER = DukNumber
| x == c_DUK_TYPE_STRING = DukString
| x == c_DUK_TYPE_OBJECT = DukObject
| x == c_DUK_TYPE_BUFFER = DukBuffer
| x == c_DUK_TYPE_POINTER = DukPointer
| x == c_DUK_TYPE_LIGHTFUNC = DukLightFunc
| otherwise = DukNone
getStringFromStack ∷ Ptr DuktapeHeap → Int → IO BS.ByteString
getStringFromStack ctxPtr idx = alloca $ \lenPtr → do
let cIdx = fromIntegral idx
str ← c_duk_get_lstring ctxPtr cIdx lenPtr
len ← peek lenPtr
retVal ← BS.packCStringLen (str, fromIntegral len)
return retVal
getValueFromStack ∷ Ptr DuktapeHeap → Int → IO (Maybe Value)
getValueFromStack ctxPtr idx = do
retType ← getTypeOnStack ctxPtr idx
let cIdx = fromIntegral idx
ret = return . Just
case retType of
DukNull → ret Null
DukBoolean → c_duk_get_boolean ctxPtr cIdx >>= ret . Bool . (== 1) . fromIntegral
DukNumber → c_duk_get_number ctxPtr cIdx >>= ret . Number . realToFrac
DukString → getStringFromStack ctxPtr idx >>= ret . String . decodeUtf8
DukObject → c_duk_json_encode ctxPtr cIdx >> getStringFromStack ctxPtr idx >>= return . decode . BL.fromStrict
_ → return Nothing
getValueOrError ∷ Ptr DuktapeHeap → CInt → IO (Either String (Maybe Value))
getValueOrError ctxPtr code =
if code /= fromIntegral 0
then c_duk_safe_to_string ctxPtr cMinusOne >>= peekCString >>= return . Left
else getValueFromStack ctxPtr (1) >>= return . Right
pop ∷ Ptr DuktapeHeap → α → IO α
pop ctxPtr retVal = c_duk_pop ctxPtr >> return retVal
pushValue ∷ Ptr DuktapeHeap → Value → IO ()
pushValue ctxPtr Null = c_duk_push_null ctxPtr
pushValue ctxPtr (Bool True) = c_duk_push_boolean ctxPtr 1
pushValue ctxPtr (Bool False) = c_duk_push_boolean ctxPtr 0
pushValue ctxPtr (Number n) = c_duk_push_number ctxPtr $ realToFrac n
pushValue ctxPtr (String s) = void $ TF.withCStringLen s $ \(sCstr, sLen) →
c_duk_push_lstring ctxPtr sCstr $ fromIntegral sLen
pushValue ctxPtr (Array v) = do
idx ← c_duk_push_array ctxPtr
let pushElement x i = pushValue ctxPtr x >> c_duk_put_prop_index ctxPtr idx i
V.zipWithM_ pushElement v (V.enumFromN 0 $ V.length v)
pushValue ctxPtr (Object m) = do
idx ← c_duk_push_object ctxPtr
forM_ (HMS.toList m) $ \(k, x) →
BS.useAsCString (encodeUtf8 k) $ \kCstr →
pushValue ctxPtr x >> c_duk_put_prop_string ctxPtr idx kCstr
pushObjectOrGlobal ∷ Ptr DuktapeHeap → Maybe BS.ByteString → IO Bool
pushObjectOrGlobal ctxPtr (Just on) = liftM (/= 0) $ BS.useAsCString on $ \onameCstr → c_duk_get_global_string ctxPtr onameCstr
pushObjectOrGlobal ctxPtr Nothing = c_duk_push_global_object ctxPtr >> return True
createDuktapeCtx ∷ MonadIO μ ⇒ μ (Maybe DuktapeCtx)
createDuktapeCtx = liftIO $ createHeapF nullFunPtr
evalDuktape ∷ MonadIO μ ⇒ DuktapeCtx → BS.ByteString → μ (Either String (Maybe Value))
evalDuktape ctx src =
liftIO $ withCtx ctx $ \ctxPtr →
BS.useAsCStringLen src $ \(srcCstr, srcLen) →
pop ctxPtr =<< getValueOrError ctxPtr =<< c_duk_peval_lstring ctxPtr srcCstr (fromIntegral srcLen)
callDuktape ∷ MonadIO μ ⇒ DuktapeCtx
→ Maybe BS.ByteString
→ BS.ByteString
→ [Value]
→ μ (Either String (Maybe Value))
callDuktape ctx oname fname args =
liftIO $ withCtx ctx $ \ctxPtr →
BS.useAsCStringLen fname $ \(fnameCstr, fnameLen) → do
oVal ← pushObjectOrGlobal ctxPtr oname
if oVal
then do
void $ c_duk_push_lstring ctxPtr fnameCstr $ fromIntegral fnameLen
forM_ args $ pushValue ctxPtr
pop ctxPtr =<< pop ctxPtr =<< getValueOrError ctxPtr =<< c_duk_pcall_prop ctxPtr (fromIntegral $ 2 length args) (fromIntegral $ length args)
else pop ctxPtr $ Left $ "Nonexistent property of global object: " ++ show (fromMaybe "" oname)
class Duktapeable ξ where
runInDuktape ∷ ξ → Ptr DuktapeHeap → IO CInt
argCount ∷ ξ → Int
instance Duktapeable (IO ()) where
runInDuktape f _ = f >> return 0
argCount _ = 0
instance Duktapeable (IO Value) where
argCount _ = 0
runInDuktape f ctxPtr = f >>= pushValue ctxPtr >> return 1
instance Duktapeable (Value → IO Value) where
argCount _ = 1
runInDuktape f ctxPtr = do
a0 ← getValueFromStack ctxPtr 0
f (fromMaybe Null a0) >>= pushValue ctxPtr >> return 1
instance Duktapeable (Value → Value → IO Value) where
argCount _ = 2
runInDuktape f ctxPtr = do
a0 ← getValueFromStack ctxPtr 0
a1 ← getValueFromStack ctxPtr 1
f (fromMaybe Null a0) (fromMaybe Null a1) >>= pushValue ctxPtr >> return 1
instance Duktapeable (Value → Value → Value → IO Value) where
argCount _ = 3
runInDuktape f ctxPtr = do
a0 ← getValueFromStack ctxPtr 0
a1 ← getValueFromStack ctxPtr 1
a2 ← getValueFromStack ctxPtr 2
f (fromMaybe Null a0) (fromMaybe Null a1) (fromMaybe Null a2) >>= pushValue ctxPtr >> return 1
instance Duktapeable (Value → Value → Value → Value → IO Value) where
argCount _ = 4
runInDuktape f ctxPtr = do
a0 ← getValueFromStack ctxPtr 0
a1 ← getValueFromStack ctxPtr 1
a2 ← getValueFromStack ctxPtr 2
a3 ← getValueFromStack ctxPtr 3
f (fromMaybe Null a0) (fromMaybe Null a1) (fromMaybe Null a2) (fromMaybe Null a3) >>= pushValue ctxPtr >> return 1
instance Duktapeable (Value → Value → Value → Value → Value → IO Value) where
argCount _ = 5
runInDuktape f ctxPtr = do
a0 ← getValueFromStack ctxPtr 0
a1 ← getValueFromStack ctxPtr 1
a2 ← getValueFromStack ctxPtr 2
a3 ← getValueFromStack ctxPtr 3
a4 ← getValueFromStack ctxPtr 4
f (fromMaybe Null a0) (fromMaybe Null a1) (fromMaybe Null a2) (fromMaybe Null a3) (fromMaybe Null a4) >>= pushValue ctxPtr >> return 1
exposeFnDuktape ∷ (MonadIO μ, Duktapeable ξ)
⇒ DuktapeCtx
→ Maybe BS.ByteString
→ BS.ByteString
→ ξ
→ μ (Either String ())
exposeFnDuktape ctx oname fname f =
liftIO $ withCtx ctx $ \ctxPtr →
BS.useAsCString fname $ \fnameCstr → do
oVal ← pushObjectOrGlobal ctxPtr oname
if oVal
then do
wrapped ← c_wrapper $ runInDuktape f
void $ c_duk_push_c_function ctxPtr wrapped $ fromIntegral $ argCount f
void $ c_duk_put_prop_string ctxPtr (2) fnameCstr
pop ctxPtr $ Right ()
else pop ctxPtr $ Left $ "Nonexistent property of global object: " ++ show oname