#ifdef ghcjs_HOST_OS
#endif
module Language.Javascript.JSaddle.Value (
JSVal
, ToJSVal(..)
, JSNull(..)
, JSUndefined
, JSString
, JSValue(..)
, showJSValue
, valToBool
, valToNumber
, valToStr
, valToObject
, valToText
, valToJSON
, val
, valMakeNull
, valIsNull
, valMakeUndefined
, valIsUndefined
, maybeNullOrUndefined
, maybeNullOrUndefined'
, valMakeBool
, valMakeNumber
, valMakeString
, deRefVal
, valMakeRef
, strictEqual
, instanceOf
) where
import Control.Applicative
import Prelude hiding (catch)
import Language.Javascript.JSaddle.Types
(Object(..), JSString, JSVal)
#ifdef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Types
(MutableJSArray)
import GHCJS.Types (JSVal(..), isNull, isUndefined)
import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined)
import qualified GHCJS.Marshal as GHCJS (toJSVal)
import GHCJS.Marshal.Pure (pToJSVal)
import Data.JSString.Text (textToJSString)
#else
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
(jsvalueisinstanceofconstructor, jsvaluecreatejsonstring,
JSType(..), jsvaluegettype, jsvaluemakestring, jsvaluemakenumber,
jsvaluemakeboolean, jsvaluemakeundefined, jsvaluemakenull,
jsvaluetoobject, jsvaluetostringcopy, jsvaluetonumber,
jsvaluetoboolean, jsvalueisnull, jsvalueisundefined,
jsvalueisstrictequal)
import Language.Javascript.JSaddle.Native
(makeNewJSVal, wrapJSString, withJSVal, withObject, withJSString,
withToJSVal)
#endif
import Language.Javascript.JSaddle.Monad (JSM)
import Language.Javascript.JSaddle.Exception (rethrow)
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Text (Text)
import qualified Data.Text as T (pack)
import Language.Javascript.JSaddle.Classes
(MakeObject(..), ToJSString(..), ToJSVal(..))
import Language.Javascript.JSaddle.String (strToText, textToStr)
import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
import Data.Word (Word32, Word, Word64)
import Data.Int (Int32, Int64)
data JSNull = JSNull
type JSUndefined = ()
data JSValue = ValNull
| ValUndefined
| ValBool Bool
| ValNumber Double
| ValString Text
| ValObject Object
showJSValue :: JSValue -> String
showJSValue ValNull = "null"
showJSValue ValUndefined = "undefined"
showJSValue (ValBool True) = "true"
showJSValue (ValBool False) = "false"
showJSValue (ValNumber x) = show x
showJSValue (ValString s) = show s
showJSValue (ValObject _) = "object"
valToBool :: ToJSVal value => value -> JSM Bool
#ifdef ghcjs_HOST_OS
valToBool value = isTruthy <$> toJSVal value
#else
valToBool value = do
gctxt <- ask
withToJSVal value $ \rval ->
liftIO $ jsvaluetoboolean gctxt rval
#endif
valToNumber :: ToJSVal value => value -> JSM Double
#ifdef ghcjs_HOST_OS
valToNumber value = jsrefToNumber <$> toJSVal value
foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
#else
valToNumber value = do
gctxt <- ask
withToJSVal value $ \rval ->
rethrow $ liftIO . jsvaluetonumber gctxt rval
#endif
valToStr :: ToJSVal value => value -> JSM JSString
#ifdef ghcjs_HOST_OS
valToStr value = jsrefToString <$> toJSVal value
foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
#else
valToStr value = do
gctxt <- ask
withToJSVal value $ \rval ->
rethrow (liftIO . jsvaluetostringcopy gctxt rval) >>= wrapJSString
#endif
valToText :: ToJSVal value => value -> JSM Text
valToText jsvar = valToStr jsvar >>= strToText
valToJSON :: ToJSVal value => Word -> value -> JSM JSString
#ifdef ghcjs_HOST_OS
valToJSON indent value = jsrefToJSON <$> toJSVal value
foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
#else
valToJSON indent value = do
gctxt <- ask
withToJSVal value $ \rval ->
rethrow (liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent)) >>= wrapJSString
#endif
valToObject :: ToJSVal value => value -> JSM Object
valToObject value = Object <$>
#ifdef ghcjs_HOST_OS
toJSVal value
#else
do gctxt <- ask
withToJSVal value $ \rval ->
rethrow (liftIO . jsvaluetoobject gctxt rval) >>= makeNewJSVal
#endif
instance MakeObject JSVal where
makeObject = valToObject
val :: ToJSVal value
=> value
-> JSM JSVal
val = toJSVal
instance ToJSVal JSVal where
toJSVal = return
instance MakeArgs JSVal where
makeArgs arg = return [arg]
instance ToJSVal v => ToJSVal (JSM v) where
toJSVal v = v >>= toJSVal
valMakeNull :: JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeNull = return jsNull
#else
valMakeNull = ask >>= (liftIO . jsvaluemakenull) >>= makeNewJSVal
#endif
instance ToJSVal JSNull where
toJSVal = const valMakeNull
instance MakeArgs JSNull where
makeArgs _ = valMakeNull >>= (\ref -> return [ref])
instance ToJSVal a => ToJSVal (Maybe a) where
toJSVal Nothing = valMakeNull
toJSVal (Just a) = toJSVal a
valIsNull :: ToJSVal value => value -> JSM Bool
#ifdef ghcjs_HOST_OS
valIsNull value = isNull <$> toJSVal value
#else
valIsNull value = do
gctxt <- ask
withToJSVal value $ \rval ->
liftIO $ jsvalueisnull gctxt rval
#endif
valMakeUndefined :: JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeUndefined = return jsUndefined
#else
valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined) >>= makeNewJSVal
#endif
instance ToJSVal JSUndefined where
toJSVal = const valMakeUndefined
instance MakeArgs () where
makeArgs _ = return []
valIsUndefined :: ToJSVal value => value -> JSM Bool
#ifdef ghcjs_HOST_OS
valIsUndefined value = isUndefined <$> toJSVal value
#else
valIsUndefined value = do
gctxt <- ask
withToJSVal value $ \rval ->
liftIO $ jsvalueisundefined gctxt rval
#endif
maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
maybeNullOrUndefined value = do
rval <- toJSVal value
valIsNull rval >>= \case
True -> return Nothing
_ ->
valIsUndefined rval >>= \case
True -> return Nothing
_ -> return (Just rval)
maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
maybeNullOrUndefined' f value = do
rval <- toJSVal value
valIsNull rval >>= \case
True -> return Nothing
_ ->
valIsUndefined rval >>= \case
True -> return Nothing
_ -> Just <$> f rval
valMakeBool :: Bool -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeBool b = return $ toJSBool b
#else
valMakeBool b = do
gctxt <- ask
liftIO (jsvaluemakeboolean gctxt b) >>= makeNewJSVal
#endif
instance ToJSVal Bool where
toJSVal = valMakeBool
instance MakeArgs Bool where
makeArgs b = valMakeBool b >>= (\ref -> return [ref])
valMakeNumber :: Double -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeNumber n = liftIO $ GHCJS.toJSVal n
#else
valMakeNumber n = do
gctxt <- ask
liftIO (jsvaluemakenumber gctxt n) >>= makeNewJSVal
#endif
instance ToJSVal Double where
toJSVal = valMakeNumber
instance ToJSVal Float where
toJSVal = valMakeNumber . realToFrac
instance ToJSVal Word where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Word32 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Word64 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int32 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int64 where
toJSVal = valMakeNumber . fromIntegral
instance MakeArgs Double where
makeArgs n = valMakeNumber n >>= (\ref -> return [ref])
valMakeText :: Text -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeText = return . pToJSVal . textToJSString
#else
valMakeText text = do
gctxt <- ask
withJSString (textToStr text) $ \s ->
liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal
#endif
valMakeString :: JSString -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeString = return . pToJSVal
#else
valMakeString str = do
gctxt <- ask
withJSString str $ \s ->
liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal
#endif
instance ToJSVal Text where
toJSVal = valMakeText
instance MakeArgs Text where
makeArgs t = valMakeText t >>= (\ref -> return [ref])
instance ToJSVal String where
toJSVal = valMakeText . T.pack
instance ToJSVal JSString where
toJSVal = valMakeString
instance ToJSString JSString where
toJSString = id
instance ToJSString Text where
toJSString = textToStr
instance ToJSString String where
toJSString = textToStr . T.pack
deRefVal :: ToJSVal value => value -> JSM JSValue
#ifdef ghcjs_HOST_OS
deRefVal value = do
valref <- toJSVal value
case (jsrefGetType valref :: Int) of
0 -> return ValUndefined
1 -> return ValNull
2 -> ValBool <$> valToBool valref
3 -> ValNumber <$> valToNumber valref
4 -> ValString <$> valToText valref
5 -> ValObject <$> valToObject valref
foreign import javascript unsafe "$r = ($1 === undefined)?0:\
($1===null)?1:\
(typeof $1===\"boolean\")?2:\
(typeof $1===\"number\")?3:\
(typeof $1===\"string\")?4:\
(typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int
#else
deRefVal value = do
gctxt <- ask
v <- toJSVal value
withJSVal v $ \rval ->
liftIO (jsvaluegettype gctxt rval) >>= \case
Kjstypenull -> return ValNull
Kjstypeundefined -> return ValUndefined
Kjstypeboolean -> ValBool <$> valToBool v
Kjstypenumber -> ValNumber <$> valToNumber v
Kjstypestring -> ValString <$> valToText v
Kjstypeobject -> ValObject <$> valToObject v
#endif
valMakeRef :: JSValue -> JSM JSVal
valMakeRef value =
case value of
ValNull -> valMakeNull
ValUndefined -> valMakeUndefined
ValBool b -> valMakeBool b
ValNumber n -> valMakeNumber n
ValString s -> valMakeText s
ValObject (Object o) -> return o
instance ToJSVal JSValue where
toJSVal = valMakeRef
instance MakeArgs JSValue where
makeArgs v = valMakeRef v >>= (\ref -> return [ref])
#ifdef ghcjs_HOST_OS
foreign import javascript unsafe
"$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool
#endif
strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool
strictEqual a b = do
aval <- toJSVal a
bval <- toJSVal b
#ifdef ghcjs_HOST_OS
return $ jsvalueisstrictequal aval bval
#else
gctxt <- ask
withJSVal aval $ \aref ->
withJSVal bval $ \bref ->
liftIO $ jsvalueisstrictequal gctxt aref bref
#endif
#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "\
try {\
$r = $1 instanceof $2\
}\
catch(e) {\
$3[0] = e;\
}"
js_isInstanceOf :: JSVal -> Object -> MutableJSArray -> Bool
#endif
instanceOf :: (ToJSVal value, MakeObject constructor) => value -> constructor -> JSM Bool
instanceOf value constructor = do
v <- toJSVal value
c <- makeObject constructor
#ifdef ghcjs_HOST_OS
rethrow $ return . js_isInstanceOf v c
#else
gctxt <- ask
withJSVal v $ \rval ->
withObject c $ \c' ->
rethrow $ liftIO . jsvalueisinstanceofconstructor gctxt rval c'
#endif