#ifdef ghcjs_HOST_OS
#endif
module Language.Javascript.JSaddle.Value (
JSVal
, ToJSVal(..)
, JSNull(..)
, JSUndefined
, JSString
, JSValue(..)
, showJSValue
, isTruthyIO
, valToBool
, valToNumber
, valToStr
, valToObject
, valToText
, valToJSON
, val
, jsNull
, valNull
, isNullIO
, valIsNull
, jsUndefined
, valUndefined
, isUndefinedIO
, valIsUndefined
, maybeNullOrUndefined
, maybeNullOrUndefined'
, toJSBool
, jsTrue
, jsFalse
, valBool
, valMakeNumber
, valMakeString
, valMakeText
, valMakeJSON
, deRefVal
, valMakeRef
, strictEqual
, instanceOf
) where
import Data.Text (Text)
import qualified Data.Text as T (pack, unpack)
import Data.Aeson (Value)
#ifdef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Types
(Object(..), JSString(..), JSVal(..))
import GHCJS.Marshal (ToJSVal(..))
import GHCJS.Marshal.Pure (pToJSVal)
import Data.JSString.Text (textToJSString)
#else
import Data.Char (chr, ord)
import Data.Word (Word, Word8, Word16, Word32)
import Data.Int (Int8, Int16, Int32)
import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
import Language.Javascript.JSaddle.Types
(Object(..), JSString(..), JSVal(..), JSValueForSend(..))
import Language.Javascript.JSaddle.Native
(wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
import Language.Javascript.JSaddle.Run
(Command(..), AsyncCommand(..), Result(..), sendCommand,
sendLazyCommand)
#endif
import Language.Javascript.JSaddle.Monad (JSM)
import Language.Javascript.JSaddle.Classes
(MakeObject(..), MakeArgs(..))
import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
import Language.Javascript.JSaddle.String (strToText, textToStr)
import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
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
valToBool value = toJSVal value >>= isTruthyIO
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
instance ToJSVal Object where
toJSVal (Object r) = return r
val :: ToJSVal value
=> value
-> JSM JSVal
val = toJSVal
#ifndef ghcjs_HOST_OS
instance ToJSVal JSVal where
toJSVal = return
#endif
instance MakeArgs JSVal where
makeArgs arg = return [arg]
instance ToJSVal v => ToJSVal (JSM v) where
toJSVal v = v >>= toJSVal
valNull :: JSVal
valNull = jsNull
instance ToJSVal JSNull where
toJSVal = const (return jsNull)
instance MakeArgs JSNull where
makeArgs _ = return [jsNull]
#ifndef ghcjs_HOST_OS
instance ToJSVal a => ToJSVal (Maybe a) where
toJSVal Nothing = return jsNull
toJSVal (Just a) = toJSVal a
instance FromJSVal a => FromJSVal (Maybe a) where
fromJSValUnchecked x =
isUndefinedIO x >>= \case
True -> return Nothing
False -> isNullIO x >>= \case
True -> return Nothing
False -> fromJSVal x
fromJSVal x =
isUndefinedIO x >>= \case
True -> return (Just Nothing)
False -> isNullIO x >>= \case
True -> return (Just Nothing)
False -> fmap (fmap Just) fromJSVal x
instance ToJSVal a => ToJSVal [a] where
toJSVal = toJSValListOf
instance FromJSVal a => FromJSVal [a] where
fromJSVal = fromJSValListOf
#endif
valIsNull :: ToJSVal value => value -> JSM Bool
valIsNull value = toJSVal value >>= isNullIO
valUndefined :: JSVal
valUndefined = jsUndefined
instance ToJSVal JSUndefined where
toJSVal = const (return jsUndefined)
instance MakeArgs () where
makeArgs _ = return []
valIsUndefined :: ToJSVal value => value -> JSM Bool
valIsUndefined value = toJSVal value >>= isUndefinedIO
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
valBool = toJSBool
#ifndef ghcjs_HOST_OS
instance ToJSVal Bool where
toJSVal = return . valBool
#endif
instance MakeArgs Bool where
makeArgs b = return [valBool b]
valMakeNumber :: Double -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeNumber n = toJSVal n
#else
valMakeNumber = sendLazyCommand . NumberToValue
#endif
#ifndef ghcjs_HOST_OS
instance ToJSVal Double where
toJSVal = valMakeNumber
instance ToJSVal Float where
toJSVal = valMakeNumber . realToFrac
instance ToJSVal Word where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Word8 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Word16 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Word32 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int8 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int16 where
toJSVal = valMakeNumber . fromIntegral
instance ToJSVal Int32 where
toJSVal = valMakeNumber . fromIntegral
#endif
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
#ifndef ghcjs_HOST_OS
instance ToJSVal Text where
toJSVal = valMakeText
instance FromJSVal Text where
fromJSValUnchecked = valToText
fromJSVal = fmap Just . valToText
#endif
instance MakeArgs Text where
makeArgs t = valMakeText t >>= (\ref -> return [ref])
#ifndef ghcjs_HOST_OS
instance ToJSVal JSString where
toJSVal = valMakeString
instance FromJSVal JSString where
fromJSValUnchecked = valToStr
fromJSVal = fmap Just . valToStr
#endif
instance ToJSString JSString where
toJSString = id
instance ToJSString Text where
toJSString = textToStr
instance ToJSString String where
toJSString = textToStr . T.pack
instance FromJSString Text where
fromJSString = strToText
instance FromJSString String where
fromJSString v = T.unpack $ strToText v
instance FromJSString JSString where
fromJSString = id
#ifndef ghcjs_HOST_OS
instance ToJSVal Char where
toJSVal = valMakeNumber . fromIntegral . ord
toJSValListOf = valMakeText . T.pack
instance FromJSVal Char where
fromJSValUnchecked = fmap (chr . round) . valToNumber
fromJSVal = fmap (Just . chr . round) . valToNumber
fromJSValUncheckedListOf = fmap (T.unpack . strToText) . valToStr
fromJSValListOf = fmap (Just . T.unpack . strToText) . valToStr
#endif
valMakeJSON :: Value -> JSM JSVal
#ifdef ghcjs_HOST_OS
valMakeJSON = toJSVal
#else
valMakeJSON = sendLazyCommand . JSONValueToValue
#endif
#ifndef ghcjs_HOST_OS
instance ToJSVal Value where
toJSVal = valMakeJSON
#endif
instance MakeArgs Value where
makeArgs t = valMakeJSON t >>= (\ref -> return [ref])
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
_ -> error "Unexpected result dereferencing JSaddle value"
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))
_ -> error "Unexpected result dereferencing JSaddle value"
#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