{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE LambdaCase #-}
#ifdef ghcjs_HOST_OS
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Javascript.JSaddle.Value (
JSVal
, ToJSVal(..)
, JSNull(..)
, JSUndefined
, JSString
, JSValue(..)
, showJSValue
, isTruthy
, valToBool
, valToNumber
, valToStr
, valToObject
, valToText
, valToJSON
, val
, jsNull
, valNull
, isNull
, valIsNull
, jsUndefined
, valUndefined
, isUndefined
, 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)
import Data.JSString.Text (textToJSString)
#ifdef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Types
(Object(..), JSString(..), JSVal(..), ghcjsPure)
import GHCJS.Marshal (ToJSVal(..))
#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(..), ghcjsPure)
import Language.Javascript.JSaddle.Native
(valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue)
import qualified Language.Javascript.JSaddle.Native as N
(deRefVal, strictEqual, instanceOf)
import Language.Javascript.JSaddle.Run (Result(..))
#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 GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
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 >>= ghcjsPure . isTruthy
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 = toJSVal value >>= valueToNumber
#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 = toJSVal value >>= valueToString
#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 = toJSVal value >>= valueToJSON
#endif
valToObject :: ToJSVal value => value -> JSM Object
valToObject value = Object <$> toJSVal value
instance MakeObject JSVal where
makeObject = return . Object
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
{-# INLINE toJSVal #-}
#endif
instance MakeArgs JSVal where
makeArgs arg = return [arg]
instance ToJSVal v => ToJSVal (JSM v) where
toJSVal v = v >>= toJSVal
{-# INLINE toJSVal #-}
valNull :: JSVal
valNull = jsNull
{-# INLINE valNull #-}
instance ToJSVal JSNull where
toJSVal = const (return jsNull)
{-# INLINE toJSVal #-}
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
{-# INLINE toJSVal #-}
instance FromJSVal a => FromJSVal (Maybe a) where
fromJSValUnchecked x =
ghcjsPure (isUndefined x) >>= \case
True -> return Nothing
False -> ghcjsPure (isNull x) >>= \case
True -> return Nothing
False -> fromJSVal x
{-# INLINE fromJSValUnchecked #-}
fromJSVal x =
ghcjsPure (isUndefined x) >>= \case
True -> return (Just Nothing)
False -> ghcjsPure (isNull x) >>= \case
True -> return (Just Nothing)
False -> fmap (fmap Just) fromJSVal x
{-# INLINE fromJSVal #-}
instance ToJSVal a => ToJSVal [a] where
toJSVal = toJSValListOf
{-# INLINE toJSVal #-}
instance FromJSVal a => FromJSVal [a] where
fromJSVal = fromJSValListOf
{-# INLINE fromJSVal #-}
#endif
valIsNull :: ToJSVal value => value -> JSM Bool
valIsNull value = toJSVal value >>= ghcjsPure . isNull
valUndefined :: JSVal
valUndefined = jsUndefined
{-# INLINE valUndefined #-}
instance ToJSVal JSUndefined where
toJSVal = const (return jsUndefined)
instance MakeArgs () where
makeArgs _ = return []
valIsUndefined :: ToJSVal value => value -> JSM Bool
valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
maybeNullOrUndefined value = do
rval <- toJSVal value
ghcjsPure (isNull rval) >>= \case
True -> return Nothing
_ ->
ghcjsPure (isUndefined 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
ghcjsPure (isNull rval) >>= \case
True -> return Nothing
_ ->
ghcjsPure (isUndefined rval) >>= \case
True -> return Nothing
_ -> Just <$> f rval
valBool :: Bool -> JSVal
valBool = toJSBool
{-# INLINE valBool #-}
#ifndef ghcjs_HOST_OS
instance ToJSVal Bool where
toJSVal = return . valBool
{-# INLINE toJSVal #-}
#endif
instance MakeArgs Bool where
makeArgs b = return [valBool b]
valMakeNumber :: Double -> JSM JSVal
valMakeNumber = toJSVal
{-# INLINE valMakeNumber #-}
#ifndef ghcjs_HOST_OS
instance ToJSVal Double where
toJSVal = numberToValue
{-# INLINE toJSVal #-}
instance ToJSVal Float where
toJSVal = numberToValue . realToFrac
{-# INLINE toJSVal #-}
instance ToJSVal Word where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Word8 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Word16 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Word32 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Int where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Int8 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Int16 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
instance ToJSVal Int32 where
toJSVal = numberToValue . fromIntegral
{-# INLINE toJSVal #-}
#endif
instance MakeArgs Double where
makeArgs n = valMakeNumber n >>= (\ref -> return [ref])
valMakeText :: Text -> JSM JSVal
valMakeText = toJSVal . textToJSString
{-# INLINE valMakeText #-}
valMakeString :: JSString -> JSM JSVal
valMakeString = toJSVal
{-# INLINE valMakeString #-}
#ifndef ghcjs_HOST_OS
instance ToJSVal Text where
toJSVal = stringToValue . JSString
{-# INLINE toJSVal #-}
instance FromJSVal Text where
fromJSValUnchecked = valToText
{-# INLINE fromJSValUnchecked #-}
fromJSVal = fmap Just . valToText
{-# INLINE fromJSVal #-}
#endif
instance MakeArgs Text where
makeArgs t = valMakeText t >>= (\ref -> return [ref])
#ifndef ghcjs_HOST_OS
instance ToJSVal JSString where
toJSVal = stringToValue
{-# INLINE toJSVal #-}
instance FromJSVal JSString where
fromJSValUnchecked = valToStr
{-# INLINE fromJSValUnchecked #-}
fromJSVal = fmap Just . valToStr
{-# INLINE fromJSVal #-}
#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
{-# INLINE toJSVal #-}
toJSValListOf = valMakeText . T.pack
{-# INLINE toJSValListOf #-}
instance FromJSVal Char where
fromJSValUnchecked = fmap (chr . round) . valToNumber
{-# INLINE fromJSValUnchecked #-}
fromJSVal = fmap (Just . chr . round) . valToNumber
{-# INLINE fromJSVal #-}
fromJSValUncheckedListOf = fmap (T.unpack . strToText) . valToStr
{-# INLINE fromJSValListOf #-}
fromJSValListOf = fmap (Just . T.unpack . strToText) . valToStr
{-# INLINE fromJSValUncheckedListOf #-}
#endif
valMakeJSON :: Value -> JSM JSVal
valMakeJSON = toJSVal
#ifndef ghcjs_HOST_OS
instance ToJSVal Value where
toJSVal = jsonValueToValue
{-# INLINE toJSVal #-}
#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
result <- N.deRefVal v
return $ case result of
DeRefValResult 0 _ -> ValNull
DeRefValResult 1 _ -> ValUndefined
DeRefValResult 2 _ -> ValBool False
DeRefValResult 3 _ -> ValBool True
DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
DeRefValResult (-2) s -> ValString s
DeRefValResult (-3) _ -> ValObject (Object v)
_ -> 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
{-# INLINE toJSVal #-}
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
N.strictEqual aval bval
#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
N.instanceOf v c
#endif