#ifdef ghcjs_HOST_OS
#endif
module Language.Javascript.JSaddle.Value (
JSVal
, ToJSVal(..)
, JSNull(..)
, JSUndefined
, JSString
, JSValue(..)
, showJSValue
, valToBool
, valToNumber
, valToStr
, valToObject
, valToText
, valToJSON
, val
, valNull
, valIsNull
, valUndefined
, valIsUndefined
, maybeNullOrUndefined
, maybeNullOrUndefined'
, valBool
, 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 Control.Monad.IO.Class (MonadIO(..))
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 Language.Javascript.JSaddle.Native
(wrapJSString, withJSVal, withObject, withJSString,
withToJSVal, wrapJSVal)
import Language.Javascript.JSaddle.WebSockets
(Command(..), AsyncCommand(..), Result(..), sendCommand,
sendLazyCommand)
#endif
import Language.Javascript.JSaddle.Monad (JSM)
import Data.Text (Text)
import qualified Data.Text as T (pack, unpack)
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 =
toJSVal value >>= \case
(JSVal 0) -> return False
(JSVal 1) -> return False
(JSVal 2) -> return False
(JSVal 3) -> return True
val ->
withJSVal val $ \rval -> do
ValueToBoolResult result <- sendCommand (ValueToBool rval)
return result
#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 =
withToJSVal value $ \rval -> do
ValueToNumberResult result <- sendCommand (ValueToNumber rval)
return result
#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 =
withToJSVal value $ \rval -> do
ValueToStringResult result <- sendCommand (ValueToString rval)
wrapJSString result
#endif
valToText :: ToJSVal value => value -> JSM Text
valToText jsvar = strToText <$> valToStr jsvar
valToJSON :: ToJSVal value => value -> JSM JSString
#ifdef ghcjs_HOST_OS
valToJSON value = jsrefToJSON <$> toJSVal value
foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
#else
valToJSON value =
withToJSVal value $ \rval -> do
ValueToJSONResult result <- sendCommand (ValueToJSON rval)
wrapJSString result
#endif
valToObject :: ToJSVal value => value -> JSM Object
valToObject value = Object <$> toJSVal value
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
valNull :: JSVal
#ifdef ghcjs_HOST_OS
valNull = jsNull
#else
valNull = JSVal 0
#endif
instance ToJSVal JSNull where
toJSVal = const (return valNull)
instance MakeArgs JSNull where
makeArgs _ = return [valNull]
instance ToJSVal a => ToJSVal (Maybe a) where
toJSVal Nothing = return valNull
toJSVal (Just a) = toJSVal a
valIsNull :: ToJSVal value => value -> JSM Bool
#ifdef ghcjs_HOST_OS
valIsNull value = isNull <$> toJSVal value
#else
valIsNull value =
toJSVal value >>= \case
JSVal 0 -> return True
v ->
withJSVal v $ \rval -> do
IsNullResult result <- sendCommand $ IsNull rval
return result
#endif
valUndefined :: JSVal
#ifdef ghcjs_HOST_OS
valUndefined = jsUndefined
#else
valUndefined = JSVal 1
#endif
instance ToJSVal JSUndefined where
toJSVal = const (return valUndefined)
instance MakeArgs () where
makeArgs _ = return []
valIsUndefined :: ToJSVal value => value -> JSM Bool
#ifdef ghcjs_HOST_OS
valIsUndefined value = isUndefined <$> toJSVal value
#else
valIsUndefined value = toJSVal value >>= \case
JSVal 1 -> return True
v ->
withJSVal v $ \rval -> do
IsUndefinedResult result <- sendCommand $ IsUndefined rval
return result
#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
valBool :: Bool -> JSVal
#ifdef ghcjs_HOST_OS
valBool b = toJSBool b
#else
valBool b = JSVal $ if b then 3 else 2
#endif
instance ToJSVal Bool where
toJSVal = return . valBool
instance MakeArgs Bool where
makeArgs b = return [valBool b]
valMakeNumber :: Double -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeNumber n = liftIO $ GHCJS.toJSVal n
#else
valMakeNumber = sendLazyCommand . NumberToValue
#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 = valMakeString (textToStr text)
#endif
valMakeString :: JSString -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeString = return . pToJSVal
#else
valMakeString s =
withJSString s $ sendLazyCommand . StringToValue
#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
v <- toJSVal value
withJSVal v $ \rval ->
sendCommand (DeRefVal rval) >>= \case
DeRefValResult 0 _ -> return ValNull
DeRefValResult 1 _ -> return ValUndefined
DeRefValResult 2 _ -> return $ ValBool False
DeRefValResult 3 _ -> return $ ValBool True
DeRefValResult (1) s -> return $ ValNumber (read (T.unpack s))
DeRefValResult (2) s -> return $ ValString s
DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref))
#endif
valMakeRef :: JSValue -> JSM JSVal
valMakeRef value =
case value of
ValNull -> return valNull
ValUndefined -> return valUndefined
ValBool b -> return $ valBool 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
withJSVal aval $ \aref ->
withJSVal bval $ \bref -> do
StrictEqualResult result <- sendCommand $ StrictEqual aref bref
return result
#endif
#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "$1 instanceof $2"
js_isInstanceOf :: JSVal -> Object -> 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
return $ js_isInstanceOf v c
#else
withJSVal v $ \rval ->
withObject c $ \c' -> do
InstanceOfResult result <- sendCommand $ InstanceOf rval c'
return result
#endif