Marshal.hs

{-# LANGUAGE DefaultSignatures,
             TypeOperators,
             ScopedTypeVariables,
             DefaultSignatures,
             FlexibleContexts,
             FlexibleInstances,
             OverloadedStrings,
             TupleSections,
             MagicHash,
             CPP,
             JavaScriptFFI,
             ForeignFunctionInterface,
             UnliftedFFITypes,
             BangPatterns,
             TypeFamilies,
             StandaloneDeriving,
             GeneralizedNewtypeDeriving
  #-}

-- | This module provides functions for marshaling Haskell datatypes to
-- and from javascript references. The typesafe marshaling API should be
-- used for most things ('fromJS', 'toJS', etc), as it helps enforce
-- that the datatype matches up with the reference type.
--
-- = Laws
--
-- 'fromJS' should convert back to the value given to 'toJS':
--
-- > (toJS x >>= fromJS) === return (Just x)
--
-- If 'fromJS' successfully converts some ref, then 'toJS' should yield
-- a ref which is semantically equivalent (though not necessarily the
-- same ref).
--
-- > (do { Just x <- fromJS ref; toJS x }) === return ref
--
-- (With @(===)@ indicating some reasonable notion of equivalence)
--
-- = Builtin instances
--
-- This module defines a variety of marshaling instances. Here's how
-- they work:
--
-- * All of the numeric types marshal to and from 'JSNumber'.
--
-- * 'String' gets marshaled to 'JSString', whereas all other lists get
-- marshaled to 'AI.JSArray'. This is accomplished with some type system
-- hackery - see "GHCJS.Marshal.List" for details.
--
-- * @('Maybe' a)@ marshals to and from @('Nullable' ('JSType' a))@.
-- 'Nothing' becomes 'jsNull', whereas 'Just' uses the marshaling for
-- @a@. Some type system hackery is used to ensure that we don't try to
-- marshal nested maybes, as @Nothing@ can't be distinguished from @Just
-- Nothing@. See "GHCJS.Marshal.Maybe" for details.
--
-- * Tuples up to arity 7 have instances for marshaling to and from
-- 'JSArray'.
--
-- * Reference types get marshaled by simply passing them through. This
-- needs to be explicitly declared for each reference type, though.
--
-- = Defining new reference types
--
-- New reference types are created by newtype wrapping 'JSRef', like
-- this:
--
-- > {-# LANGUAGE DeriveDataTypeable #-}
-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- >
-- > import Data.Typeable (Typeable)
-- > import GHCJS.Marshal
-- > import GHCJS.Marshal.Pure
-- > import GHCJS.Types
-- >
-- > newtype Wrapper = Wrapper JSRef
-- >   deriving (Typeable, IsJSRef, ToJSRef, FromJSRef, PToJSRef, PFromJSRef)
-- > type instance JSType Wrapper = Wrapper
module GHCJS.Marshal
    (
    -- * Typesafe marshaling API
      fromJS
    , fromJSUnchecked
    , pFromJS
    , toJS
    , pToJS
    , JSType
    -- * Typeclasses for marshaling JSRef
    , FromJSRef(..)
    , ToJSRef(..)
    , toJSRef_aeson
    , toJSRef_pure
    ) where

import           Control.Applicative
import           Control.DeepSeq (NFData)
import           Control.Monad
import           Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

import qualified Data.Aeson as AE
import           Data.Attoparsec.Number (Number(..))
import           Data.Bits ((.&.))
import           Data.Char (chr, ord)
import qualified Data.HashMap.Strict as H
import           Data.Int (Int8, Int16, Int32)
import qualified Data.JSString as JSS
import qualified Data.JSString.Text as JSS
import           Data.JSString.Internal.Type (JSString(..))
import           Data.Maybe
import           Data.Scientific (Scientific, scientific, fromFloatDigits)
import           Data.Text (Text)
import qualified Data.Vector as V
import           Data.Word (Word8, Word16, Word32, Word)
import           Data.Primitive.ByteArray

import           Unsafe.Coerce (unsafeCoerce)

import           GHC.Int
import           GHC.Word
import           GHC.Types
import           GHC.Float
import           GHC.Prim
import           GHC.Generics

import           GHCJS.Foreign.Internal
import           GHCJS.Internal.Types
import           GHCJS.Marshal.List
import           GHCJS.Marshal.Maybe
import           GHCJS.Marshal.Pure
import           GHCJS.Nullable
import           GHCJS.Types

import qualified JavaScript.Array           as A
import qualified JavaScript.Array.Internal  as AI
import           JavaScript.Bool
import           JavaScript.Number
import qualified JavaScript.Object          as O
import qualified JavaScript.Object.Internal as OI

import           GHCJS.Marshal.Internal

fromJS :: (FromJSRef a, IsJSRef (JSType a)) => JSType a -> IO (Maybe a)
fromJS = fromJSRef . jsref

fromJSUnchecked :: (FromJSRef a, IsJSRef (JSType a)) => JSType a -> IO a
fromJSUnchecked = fromJSRefUnchecked . jsref

pFromJS :: (PFromJSRef a, IsJSRef (JSType a)) => JSType a -> a
pFromJS = pFromJSRef . jsref

toJS :: (ToJSRef a, IsJSRef (JSType a)) => a -> IO (JSType a)
toJS = fmap uncheckedWrapJSRef . toJSRef

pToJS :: (PToJSRef a, IsJSRef (JSType a)) => a -> JSType a
pToJS = uncheckedWrapJSRef . pToJSRef

type family JSType a

type instance JSType JSRef = JSRef
type instance JSType () = JSRef
type instance JSType [a] = JSListType a
type instance JSType (Maybe a) = Nullable (JSType a)
type instance JSType Text = JSString
type instance JSType Char = JSString --FIXME: is this right? Should we have JSChar ?
type instance JSType Bool = JSBool
-- FIXME: consider whether we should have fine grained types for numbers
type instance JSType Int = JSNumber
type instance JSType Int8 = JSNumber
type instance JSType Int16 = JSNumber
type instance JSType Int32 = JSNumber
type instance JSType Word = JSNumber
type instance JSType Word8 = JSNumber
type instance JSType Word16 = JSNumber
type instance JSType Word32 = JSNumber
type instance JSType Float = JSNumber
type instance JSType Double = JSNumber
type instance JSType AE.Value = JSRef
type instance JSType (a, b) = AI.JSArray
type instance JSType (a, b, c) = AI.JSArray
type instance JSType (a, b, c, d) = AI.JSArray
type instance JSType (a, b, c, d, e) = AI.JSArray
type instance JSType (a, b, c, d, e, f) = AI.JSArray
type instance JSType (a, b, c, d, e, f, g) = AI.JSArray

-- -----------------------------------------------------------------------------

-- Define instances for all of the JSRef wrappers which are imported
-- into this module.

type instance JSType JSString = JSString
deriving instance FromJSRef  JSString
deriving instance ToJSRef    JSString
deriving instance PFromJSRef JSString
deriving instance PToJSRef   JSString

type instance JSType (Nullable a) = Nullable a
deriving instance FromJSRef  (Nullable a)
deriving instance ToJSRef    (Nullable a)
deriving instance PFromJSRef (Nullable a)
deriving instance PToJSRef   (Nullable a)

type instance JSType (AI.SomeJSArray m) = AI.SomeJSArray m
deriving instance FromJSRef  (AI.SomeJSArray a)
deriving instance ToJSRef    (AI.SomeJSArray a)
deriving instance PFromJSRef (AI.SomeJSArray a)
deriving instance PToJSRef   (AI.SomeJSArray a)

type instance JSType JSBool = JSBool
deriving instance FromJSRef  JSBool
deriving instance ToJSRef    JSBool
deriving instance PFromJSRef JSBool
deriving instance PToJSRef   JSBool

type instance JSType JSNumber = JSNumber
deriving instance FromJSRef  JSNumber
deriving instance ToJSRef    JSNumber
deriving instance PFromJSRef JSNumber
deriving instance PToJSRef   JSNumber

type instance JSType OI.Object = OI.Object
deriving instance FromJSRef  OI.Object
deriving instance ToJSRef    OI.Object
deriving instance PFromJSRef OI.Object
deriving instance PToJSRef   OI.Object

-- -----------------------------------------------------------------------------

instance FromJSRef JSRef where
  fromJSRefUnchecked x = return x
  {-# INLINE fromJSRefUnchecked #-}
  fromJSRef = return . Just
  {-# INLINE fromJSRef #-}
instance FromJSRef () where
  fromJSRefUnchecked = fromJSRefUnchecked_pure
  {-# INLINE fromJSRefUnchecked #-}
  fromJSRef = fromJSRef_pure
--    {-# INLINE fromJSRef #-}
instance FromJSRef Text where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Char where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Bool where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Int where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Int8 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Int16 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Int32 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Word where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Word8 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Word16 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Word32 where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Float where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef Double where
    fromJSRefUnchecked = fromJSRefUnchecked_pure
    {-# INLINE fromJSRefUnchecked #-}
    fromJSRef = fromJSRef_pure
    {-# INLINE fromJSRef #-}
instance FromJSRef AE.Value where
    fromJSRef r = case jsonTypeOf r of
            JSONNull    -> return (Just AE.Null)
            JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer))
                 <$> fromJSRef r
            JSONFloat   -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific))
                 <$> fromJSRef r
            JSONBool    -> liftM AE.Bool  <$> fromJSRef r
            JSONString  -> liftM AE.String <$> fromJSRef r
            JSONArray   -> liftM (AE.Array . V.fromList) <$> fromJSRef r
            JSONObject  -> do
                props <- OI.listProps (OI.Object r)
                runMaybeT $ do
                    propVals <- forM props $ \p -> do
                        v <- MaybeT (fromJSRef =<< OI.getProp p (OI.Object r))
                        return (JSS.textFromJSString p, v)
                    return (AE.Object (H.fromList propVals))
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b) => FromJSRef (a,b) where
    fromJSRef r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c) => FromJSRef (a,b,c) where
    fromJSRef r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d) => FromJSRef (a,b,c,d) where
    fromJSRef r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e) => FromJSRef (a,b,c,d,e) where
    fromJSRef r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f) => FromJSRef (a,b,c,d,e,f) where
    fromJSRef r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f, FromJSRef g) => FromJSRef (a,b,c,d,e,f,g) where
    fromJSRef r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6
    {-# INLINE fromJSRef #-}
instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f, FromJSRef g, FromJSRef h) => FromJSRef (a,b,c,d,e,f,g,h) where
    fromJSRef r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7
    {-# INLINE fromJSRef #-}

jf :: FromJSRef a => JSRef -> Int -> MaybeT IO a
jf r n = MaybeT $ do
  r' <- AI.read n (AI.SomeJSArray r)
  if isUndefined r
    then return Nothing
    else fromJSRef r'

instance ToJSRef JSRef where
  toJSRef = toJSRef_pure
  {-# INLINE toJSRef #-}
instance ToJSRef AE.Value where
    toJSRef = toJSRef_aeson
    {-# INLINE toJSRef #-}
instance ToJSRef Text where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Char where
    toJSRef = return . pToJSRef
    {-# INLINE toJSRef #-}
instance ToJSRef Bool where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Int where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Int8 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Int16 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Int32 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Word where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Word8 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Word16 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Word32 where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Float where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance ToJSRef Double where
    toJSRef = toJSRef_pure
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b) => ToJSRef (a,b) where
    toJSRef (a,b) = join $ arr2 <$> toJSRef a <*> toJSRef b
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b, ToJSRef c) => ToJSRef (a,b,c) where
    toJSRef (a,b,c) = join $ arr3 <$> toJSRef a <*> toJSRef b <*> toJSRef c
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d) => ToJSRef (a,b,c,d) where
    toJSRef (a,b,c,d) = join $ arr4 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e) => ToJSRef (a,b,c,d,e) where
    toJSRef (a,b,c,d,e) = join $ arr5 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e, ToJSRef f) => ToJSRef (a,b,c,d,e,f) where
    toJSRef (a,b,c,d,e,f) = join $ arr6 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e <*> toJSRef f
    {-# INLINE toJSRef #-}
instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e, ToJSRef f, ToJSRef g) => ToJSRef (a,b,c,d,e,f,g) where
    toJSRef (a,b,c,d,e,f,g) = join $ arr7 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e <*> toJSRef f <*> toJSRef g
    {-# INLINE toJSRef #-}

foreign import javascript unsafe "[$1]"                   arr1     :: JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2]"                arr2     :: JSRef -> JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2,$3]"             arr3     :: JSRef -> JSRef -> JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2,$3,$4]"          arr4     :: JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2,$3,$4,$5]"       arr5     :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]"    arr6     :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef
foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7     :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef

toJSRef_aeson :: AE.ToJSON a => a -> IO JSRef
toJSRef_aeson x = cv (AE.toJSON x)
  where
    cv = convertValue

    convertValue :: AE.Value -> IO JSRef
    convertValue AE.Null       = return jsNull
    convertValue (AE.String t) = return (pToJSRef t)
    convertValue (AE.Array a)  = (\(AI.SomeJSArray x) -> x) <$>
                                 (AI.fromListIO =<< mapM convertValue (V.toList a))
    convertValue (AE.Number n) = toJSRef (realToFrac n :: Double)
    convertValue (AE.Bool b)   = return (toJSBool b)
    convertValue (AE.Object o) = do
      obj@(OI.Object obj') <- OI.create
      mapM_ (\(k,v) -> convertValue v >>= \v' -> OI.setProp (JSS.textToJSString k) v' obj) (H.toList o)
      return obj'