ghc-internal-9.1001.0: src/GHC/Internal/JS/Prim.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE UnboxedTuples #-}

module GHC.Internal.JS.Prim ( JSVal(..), JSVal#
                   , JSException(..)
                   , WouldBlockException(..)
#if defined(javascript_HOST_ARCH)
                  , toIO
                  , resolve
                  , resolveIO
                  , mkJSException
                  , fromJSString
                  , toJSString
                  , toJSArray
                  , fromJSArray
                  , fromJSInt
                  , toJSInt
                  , isNull
                  , isUndefined
                  , jsNull
                  , getProp
                  , getProp'
                  , getProp#
                  , unsafeGetProp
                  , unsafeGetProp'
                  , unsafeGetProp#
                  , unpackJSString#
                  , unpackJSStringUtf8#
                  , unsafeUnpackJSString#
                  , unsafeUnpackJSStringUtf8#
                  , unpackJSStringUtf8##
                  , unsafeUnpackJSStringUtf8##

#endif
                  ) where

import           GHC.Internal.Data.Typeable (Typeable)
import           GHC.Internal.Unsafe.Coerce (unsafeCoerce)

import           GHC.Prim
import qualified GHC.Internal.Exception as Ex
import qualified GHC.Internal.Exts as Exts
import qualified GHC.CString as GHC
import           GHC.Internal.IO
import           GHC.Internal.Data.Bool
import           GHC.Internal.Base
import           GHC.Internal.Show

{-
  JSVal is a boxed type that can be used as FFI
  argument or result.
-}

#if defined(javascript_HOST_ARCH)
data JSVal  = JSVal ByteArray#
type JSVal# = ByteArray#
#else
data JSVal  = JSVal Addr#
type JSVal# = Addr#
#endif

{-
  When a JavaScript exception is raised inside
  a safe or interruptible foreign call, it is converted
  to a JSException
 -}
data JSException = JSException JSVal String
  deriving (Typeable)

instance Ex.Exception JSException

instance Show JSException where
  show (JSException _ xs) = "JavaScript exception: " ++ xs

#if defined(javascript_HOST_ARCH)

{-# NOINLINE toIO #-}
toIO :: Exts.Any -> IO Exts.Any
toIO x = pure x

{-# NOINLINE resolve #-}
resolve :: JSVal# -> JSVal# -> Exts.Any -> IO ()
resolve accept reject x = resolveIO accept reject (pure x)

{-# NOINLINE resolveIO #-} -- used by the rts
resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO ()
resolveIO accept reject x =
  (x >>= evaluate >>= js_callback_any accept) `catch`
  (\(e::Ex.SomeException) -> do
    exceptionText <- evaluate (toJSString $ Ex.displayException e) `catch`
                         (\(_::Ex.SomeException) -> evaluate (toJSString "unknown exception"))
    js_callback_jsval reject exceptionText)

mkJSException :: JSVal -> IO JSException
mkJSException ref =
  return (JSException (unsafeCoerce ref) (fromJSString ref))

{- | Low-level conversion utilities for packages that cannot
     depend on ghcjs-base
 -}

{- | returns an empty string if the JSVal does not contain
     a string
 -}
fromJSString :: JSVal -> String
fromJSString = unsafeCoerce . js_fromJSString
{-# INLINE fromJSString #-}

toJSString :: String -> JSVal
toJSString = js_toJSString . unsafeCoerce . seqList
{-# INLINE [0] toJSString #-}
{-# RULES
"GHC.JS.PRIM toJSString/literal" forall a.
  toJSString (GHC.unpackCString# a) = JSVal (unsafeUnpackJSStringUtf8## a)
"GHC.JS.PRIM toJSString/literalUtf8" forall a.
  toJSString (GHC.unpackCStringUtf8# a) = JSVal (unsafeUnpackJSStringUtf8## a)
  #-}

fromJSArray :: JSVal -> IO [JSVal]
fromJSArray = unsafeCoerce . js_fromJSArray
{-# INLINE fromJSArray #-}

toJSArray :: [JSVal] -> IO JSVal
toJSArray = js_toJSArray . unsafeCoerce . seqList
{-# INLINE toJSArray #-}

{- | returns zero if the JSVal does not contain a number
 -}
fromJSInt :: JSVal -> Int
fromJSInt = js_fromJSInt
{-# INLINE fromJSInt #-}

toJSInt :: Int -> JSVal
toJSInt = js_toJSInt
{-# INLINE toJSInt #-}

isNull :: JSVal -> Bool
isNull = js_isNull
{-# INLINE isNull #-}

isUndefined :: JSVal -> Bool
isUndefined = js_isUndefined
{-# INLINE isUndefined #-}

jsNull :: JSVal
jsNull = js_null
{-# INLINE CONLIKE jsNull #-}

getProp :: JSVal -> String -> IO JSVal
getProp o p = js_getProp o (unsafeCoerce $ seqList p)
{-# INLINE [0] getProp #-}
{-# RULES
"GHC.JS.PRIM getProp/literal" forall o a.
  getProp o (GHC.unpackCString# a) = getProp# o a
"GHC.JS.PRIM getProp/literalUtf8" forall o a.
  getProp o (GHC.unpackCStringUtf8# a) = getPropUtf8# o a
  #-}

-- | only safe on immutable object
unsafeGetProp :: JSVal -> String -> JSVal
unsafeGetProp o p = js_unsafeGetProp o (unsafeCoerce $ seqList p)
{-# INLINE [0] unsafeGetProp #-}
{-# RULES
"GHC.JS.PRIM unsafeGetProp/literal" forall o a.
  unsafeGetProp o (GHC.unpackCString# a) = unsafeGetProp# o a
"GHC.JS.PRIM unsafeGetProp/literalUtf8" forall o a.
  unsafeGetProp o (GHC.unpackCStringUtf8# a) = unsafeGetPropUtf8# o a
  #-}

getProp' :: JSVal -> JSVal -> IO JSVal
getProp' o p = js_getProp' o p
{-# INLINE [0] getProp' #-}
{-# RULES
"GHC.JS.PRIM getProp'/literal" forall o a.
  getProp' o (unsafeUnpackJSString# a) = getProp# o a
"GHC.JS.PRIM getProp'/literalUtf8" forall o a.
  getProp' o (unsafeUnpackJSStringUtf8# a) = getPropUtf8# o a
  #-}

-- | only safe on immutable object
unsafeGetProp' :: JSVal -> JSVal -> JSVal
unsafeGetProp' o p = js_unsafeGetProp' o p
{-# INLINE [0] unsafeGetProp' #-}
{-# RULES
"GHC.JS.PRIM unsafeGetProp'/literal" forall o a.
  unsafeGetProp' o (unsafeUnpackJSString# a) = unsafeGetPropUtf8# o a
"GHC.JS.PRIM unsafeGetProp'/literalUtf8" forall o a.
  unsafeGetProp' o (unsafeUnpackJSStringUtf8# a) = unsafeGetPropUtf8# o a
  #-}


-- | only safe on immutable Addr#
getProp# :: JSVal -> Addr# -> IO JSVal
getProp# (JSVal o) p = IO $
  \s -> case getPropUtf8## o p s of (# s', v #) -> (# s', JSVal v #)
{-# INLINE [0] getProp# #-}
-- js_getProp# o p

-- | only safe on immutable Addr#
getPropUtf8# :: JSVal -> Addr# -> IO JSVal
getPropUtf8# (JSVal o) p = IO $
  \s -> case getPropUtf8## o p s of (# s', v #) -> (# s', JSVal v #)
{-# INLINE [0] getPropUtf8# #-}

getPropUtf8## :: JSVal# -> Addr# -> State# s -> (# State# s, JSVal# #)
getPropUtf8## o p = js_getPropUtf8## o p
{-# NOINLINE getPropUtf8## #-}

-- | only safe on immutable Addr# and JSVal
unsafeGetProp# :: JSVal -> Addr# -> JSVal
unsafeGetProp# (JSVal o) p = JSVal (unsafeGetPropUtf8## o p)
{-# INLINE [0] unsafeGetProp# #-}

-- | only safe on immutable Addr# and JSVal
unsafeGetPropUtf8# :: JSVal -> Addr# -> JSVal
unsafeGetPropUtf8# (JSVal o) p = JSVal (unsafeGetPropUtf8## o p)
{-# INLINE [0] unsafeGetPropUtf8# #-}

unsafeGetPropUtf8## :: JSVal# -> Addr# -> JSVal#
unsafeGetPropUtf8## o p = js_unsafeGetPropUtf8## o p
{-# NOINLINE unsafeGetPropUtf8## #-}

unpackJSString# :: Addr# -> IO JSVal
unpackJSString# a = IO $
  \s -> case unpackJSStringUtf8## a s of (# s', v #) -> (# s', JSVal v #)
{-# INLINE [0] unpackJSString# #-}

unpackJSStringUtf8# :: Addr# -> IO JSVal
unpackJSStringUtf8# a = IO $
  \s -> case unpackJSStringUtf8## a s of (# s', v #) -> (# s', JSVal v #)
{-# INLINE [0] unpackJSStringUtf8# #-}

unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #)
unpackJSStringUtf8## a s = js_unpackJSStringUtf8## a s
{-# NOINLINE unpackJSStringUtf8## #-}

-- | only safe on immutable Addr#
unsafeUnpackJSString# :: Addr# -> JSVal
unsafeUnpackJSString# a = JSVal (unsafeUnpackJSStringUtf8## a)
  -- js_unsafeUnpackJSString# a
{-# INLINE [0] unsafeUnpackJSString# #-}

-- | only safe on immutable Addr#
unsafeUnpackJSStringUtf8# :: Addr# -> JSVal
unsafeUnpackJSStringUtf8# a = JSVal (unsafeUnpackJSStringUtf8## a)
{-# INLINE [0] unsafeUnpackJSStringUtf8# #-}

unsafeUnpackJSStringUtf8## :: Addr# -> JSVal#
unsafeUnpackJSStringUtf8## a = js_unsafeUnpackJSStringUtf8## a
{-# NOINLINE unsafeUnpackJSStringUtf8## #-}


-- reduce the spine and all list elements to whnf
seqList :: [a] -> [a]
seqList xs = go xs `seq` xs
  where go (y:ys) = y `seq` go ys
        go []     = ()

foreign import javascript unsafe "h$toHsString"
  js_fromJSString :: JSVal -> Exts.Any

foreign import javascript unsafe "h$fromHsString"
  js_toJSString :: Exts.Any -> JSVal

foreign import javascript unsafe "h$toHsListJSVal"
  js_fromJSArray :: JSVal -> IO Exts.Any

foreign import javascript unsafe "h$fromHsListJSVal"
  js_toJSArray :: Exts.Any -> IO JSVal

foreign import javascript unsafe "(($1) => { return ($1 === null); })"
  js_isNull :: JSVal -> Bool

foreign import javascript unsafe "(($1) => { return ($1 === undefined); })"
  js_isUndefined :: JSVal -> Bool

foreign import javascript unsafe "(($1) => { return (typeof($1) === 'number' ? ($1|0) : 0); })"
  js_fromJSInt :: JSVal -> Int

foreign import javascript unsafe "(($1) => { return $1; })"
  js_toJSInt :: Int -> JSVal

foreign import javascript unsafe "(() => { return null; })"
  js_null :: JSVal

foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })"
  js_getProp :: JSVal -> Exts.Any -> IO JSVal

foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })"
  js_unsafeGetProp :: JSVal -> Exts.Any -> JSVal

foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })"
  js_getProp' :: JSVal -> JSVal -> IO JSVal

foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })"
  js_unsafeGetProp' :: JSVal -> JSVal -> JSVal

foreign import javascript unsafe "(($1,$2_1,$2_2) => { return $1[h$decodeUtf8z($2_1, $2_2)]; })"
  js_getPropUtf8## :: JSVal# -> Addr# -> State# s -> (# State# s, JSVal# #)

foreign import javascript unsafe "(($1,$2_1,$2_2) => { return $1[h$decodeUtf8z($2_1, $2_2)]; })"
  js_unsafeGetPropUtf8## :: JSVal# -> Addr# -> JSVal#

foreign import javascript unsafe "(($1_1,$1_2) => { return h$decodeUtf8z($1_1, $1_2); })"
  js_unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #)

foreign import javascript unsafe "(($1_1, $1_2) => { return h$decodeUtf8z($1_1,$1_2); })"
  js_unsafeUnpackJSStringUtf8## :: Addr# -> JSVal#

foreign import javascript unsafe "(($1, $2) => { return $1($2); })"
  js_callback_any :: JSVal# -> Exts.Any -> IO ()

foreign import javascript unsafe "(($1, $2) => { return $1($2); })"
  js_callback_jsval :: JSVal# -> JSVal -> IO ()

#endif

{- | If a synchronous thread tries to do something that can only
     be done asynchronously, and the thread is set up to not
     continue asynchronously, it receives this exception.
 -}
data WouldBlockException = WouldBlockException
  deriving (Typeable)

instance Show WouldBlockException where
  show _ = "thread would block"

instance Ex.Exception WouldBlockException