diff --git a/Data/JSString.hs b/Data/JSString.hs index 88f24d7..2a6e04d 100644 --- a/Data/JSString.hs +++ b/Data/JSString.hs @@ -166,10 +166,6 @@ import Data.JSString.Internal.Fusion (stream, unstream) import qualified Data.JSString.Internal.Fusion as S import qualified Data.JSString.Internal.Fusion.Common as S -getJSVal :: JSString -> JSVal -getJSVal (JSString x) = x -{-# INLINE getJSVal #-} - instance Exts.IsString JSString where fromString = pack diff --git a/Data/JSString/Internal/Type.hs b/Data/JSString/Internal/Type.hs index 7a91b78..3d26385 100644 --- a/Data/JSString/Internal/Type.hs +++ b/Data/JSString/Internal/Type.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash, - BangPatterns, ForeignFunctionInterface, JavaScriptFFI #-} + BangPatterns, ForeignFunctionInterface, JavaScriptFFI, + GeneralizedNewtypeDeriving #-} {-# OPTIONS_HADDOCK not-home #-} module Data.JSString.Internal.Type ( JSString(..) , empty @@ -42,9 +43,7 @@ import GHCJS.Internal.Types -- | A wrapper around a JavaScript string newtype JSString = JSString JSVal -instance IsJSVal JSString - -instance NFData JSString where rnf !x = () + deriving (IsJSVal, Typeable, NFData) foreign import javascript unsafe "$r = '';" js_empty :: JSString diff --git a/GHCJS/Foreign.hs b/GHCJS/Foreign.hs index bccafa0..3f97f02 100644 --- a/GHCJS/Foreign.hs +++ b/GHCJS/Foreign.hs @@ -3,11 +3,10 @@ {-# LANGUAGE DefaultSignatures #-} {- | Basic interop between Haskell and JavaScript. - The principal type here is 'JSVal', which is a lifted type that contains - a JavaScript reference. The 'JSVal' type is parameterized with one phantom - type, and GHCJS.Types defines several type synonyms for specific variants. + The principle type here is 'JSVal', which contains a JavaScript + value. - The code in this module makes no assumptions about 'JSVal a' types. + The code in this module makes no assumptions about 'JSVal' types. Operations that can result in a JS exception that can kill a Haskell thread are marked unsafe (for example if the 'JSVal' contains a null or undefined value). There are safe variants where the JS exception is propagated as @@ -67,8 +66,8 @@ module GHCJS.Foreign ( jsTrue , getPropMaybe, unsafeGetPropMaybe , setProp, unsafeSetProp , listProps -} - , jsTypeOf, JSType(..) - , jsonTypeOf, JSONType(..) + , jsTypeOf, JSTypeOf(..) + , jsonTypeOf, JSONTypeOf(..) {- , wrapBuffer, wrapMutableBuffer , byteArrayJSVal, mutableByteArrayJSVal , bufferByteString, byteArrayByteString diff --git a/GHCJS/Foreign/Internal.hs b/GHCJS/Foreign/Internal.hs index 5ac81f0..8472132 100644 --- a/GHCJS/Foreign/Internal.hs +++ b/GHCJS/Foreign/Internal.hs @@ -2,48 +2,9 @@ UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim, MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-} -{- | Basic interop between Haskell and JavaScript. - - The principal type here is 'JSVal', which is a lifted type that contains - a JavaScript reference. The 'JSVal' type is parameterized with one phantom - type, and GHCJS.Types defines several type synonyms for specific variants. - - The code in this module makes no assumptions about 'JSVal a' types. - Operations that can result in a JS exception that can kill a Haskell thread - are marked unsafe (for example if the 'JSVal' contains a null or undefined - value). There are safe variants where the JS exception is propagated as - a Haskell exception, so that it can be handled on the Haskell side. - - For more specific types, like 'JSArray' or 'JSBool', the code assumes that - the contents of the 'JSVal' actually is a JavaScript array or bool value. - If it contains an unexpected value, the code can result in exceptions that - kill the Haskell thread, even for functions not marked unsafe. - - The code makes use of `foreign import javascript', enabled with the - `JavaScriptFFI` extension, available since GHC 7.8. There are three different - safety levels: - - * unsafe: The imported code is run directly. returning an incorrectly typed - value leads to undefined behaviour. JavaScript exceptions in the foreign - code kill the Haskell thread. - * safe: Returned values are replaced with a default value if they have - the wrong type. JavaScript exceptions are caught and propagated as - Haskell exceptions ('JSException'), so they can be handled with the - standard "Control.Exception" machinery. - * interruptible: The import is asynchronous. The calling Haskell thread - sleeps until the foreign code calls the `$c` JavaScript function with - the result. The thread is in interruptible state while blocked, so it - can receive asynchronous exceptions. - - Unlike the FFI for native code, it's safe to call back into Haskell - (`h$run`, `h$runSync`) from foreign code in any of the safety levels. - Since JavaScript is single threaded, no Haskell threads can run while - the foreign code is running. - -} - -module GHCJS.Foreign.Internal ( JSType(..) +module GHCJS.Foreign.Internal ( JSTypeOf(..) , jsTypeOf - , JSONType(..) + , JSONTypeOf(..) , jsonTypeOf -- , mvarRef , isTruthy @@ -108,25 +69,25 @@ import qualified Data.Text.Lazy as TL (Text, toStrict, fromStrict) import Unsafe.Coerce -- types returned by JS typeof operator -data JSType = Undefined - | Object - | Boolean - | Number - | String - | Symbol - | Function - | Other -- ^ implementation dependent - deriving (Show, Eq, Ord, Enum, Typeable) +data JSTypeOf = Undefined + | Object + | Boolean + | Number + | String + | Symbol + | Function + | Other -- ^ implementation dependent + deriving (Show, Eq, Ord, Enum, Typeable) -- JSON value type -data JSONType = JSONNull - | JSONInteger - | JSONFloat - | JSONBool - | JSONString - | JSONArray - | JSONObject - deriving (Show, Eq, Ord, Enum, Typeable) +data JSONTypeOf = JSONNull + | JSONInteger + | JSONFloat + | JSONBool + | JSONString + | JSONArray + | JSONObject + deriving (Show, Eq, Ord, Enum, Typeable) fromJSBool :: JSVal -> Bool fromJSBool b = js_fromBool b @@ -257,11 +218,11 @@ listProps :: JSVal a -> IO [JSString] listProps o = fmap unsafeCoerce . Prim.fromJSArray =<< js_listProps o {-# INLINE listProps #-} -} -jsTypeOf :: JSVal -> JSType +jsTypeOf :: JSVal -> JSTypeOf jsTypeOf r = tagToEnum# (js_jsTypeOf r) {-# INLINE jsTypeOf #-} -jsonTypeOf :: JSVal -> JSONType +jsonTypeOf :: JSVal -> JSONTypeOf jsonTypeOf r = tagToEnum# (js_jsonTypeOf r) {-# INLINE jsonTypeOf #-} diff --git a/GHCJS/Internal/Types.hs b/GHCJS/Internal/Types.hs index 1fb1e8d..4e5445d 100644 --- a/GHCJS/Internal/Types.hs +++ b/GHCJS/Internal/Types.hs @@ -18,17 +18,36 @@ import GHCJS.Prim (JSVal) instance NFData JSVal where rnf x = x `seq` () +instance IsJSVal JSVal + +-- | Instances of this class should be newtype wrappers around 'JSVal`. It +-- should never be necessary to provide definitions for the methods, as +-- they have defaults in terms of 'Coercible'. This is why the methods +-- aren't exported by "GHCJS.Types". class IsJSVal a where jsval_ :: a -> JSVal - default jsval_ :: Coercible a JSVal => a -> JSVal jsval_ = coerce {-# INLINE jsval_ #-} + uncheckedWrapJSVal_ :: JSVal -> a + default uncheckedWrapJSVal_ :: Coercible a JSVal => JSVal -> a + uncheckedWrapJSVal_ = coerce + {-# INLINE uncheckedWrapJSVal_ #-} + +-- | This gets the 'JSVal' stored within a newtype wrapper. jsval :: IsJSVal a => a -> JSVal jsval = jsval_ {-# INLINE jsval #-} +-- | This is an unchecked downcast from 'JSVal' to some newtype wrapper. +-- Use with care, because this is an unchecked downcast. It should only +-- be used when you know that the 'JSVal' is a valid inhabitant of the +-- newtype. +uncheckedWrapJSVal :: IsJSVal a => JSVal -> a +uncheckedWrapJSVal = uncheckedWrapJSVal_ +{-# INLINE uncheckedWrapJSVal #-} + data MutabilityType s = Mutable | Immutable | STMutable s diff --git a/GHCJS/Marshal.hs b/GHCJS/Marshal.hs index b0b2718..5478ec1 100644 --- a/GHCJS/Marshal.hs +++ b/GHCJS/Marshal.hs @@ -11,27 +11,100 @@ JavaScriptFFI, ForeignFunctionInterface, UnliftedFFITypes, - BangPatterns + BangPatterns, + TypeFamilies, + StandaloneDeriving, + GeneralizedNewtypeDeriving #-} -module GHCJS.Marshal ( FromJSVal(..) - , ToJSVal(..) - , toJSVal_aeson - , toJSVal_pure - ) where +-- | 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 >=> fromJS) === (return . Just) +-- +-- If 'fromJS' successfully converts some ref, then 'toJS' should yield +-- a ref which is semantically equivalent (though not necessarily the +-- same ref). +-- +-- > (\x -> fromJS >>= maybe (return x) toJS) === return +-- +-- (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 'JSVal', 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 JSVal +-- > deriving (Typeable, IsJSVal, ToJSVal, FromJSVal, PToJSVal, PFromJSVal) +-- > type instance JSType Wrapper = Wrapper +module GHCJS.Marshal + ( + -- * Typesafe marshaling API + fromJS + , fromJSUnchecked + , pFromJS + , toJS + , pToJS + , JSType + -- * Typeclasses for marshaling JSVal + , FromJSVal(..) + , ToJSVal(..) + , toJSVal_aeson + , toJSVal_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) @@ -48,18 +121,109 @@ import GHC.Float import GHC.Prim import GHC.Generics -import GHCJS.Types 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.Boolean +import JavaScript.Number import qualified JavaScript.Object as O import qualified JavaScript.Object.Internal as OI import GHCJS.Marshal.Internal +fromJS :: (FromJSVal a, IsJSVal (JSType a)) => JSType a -> IO (Maybe a) +fromJS = fromJSVal . jsval + +fromJSUnchecked :: (FromJSVal a, IsJSVal (JSType a)) => JSType a -> IO a +fromJSUnchecked = fromJSValUnchecked . jsval + +pFromJS :: (PFromJSVal a, IsJSVal (JSType a)) => JSType a -> a +pFromJS = pFromJSVal . jsval + +toJS :: (ToJSVal a, IsJSVal (JSType a)) => a -> IO (JSType a) +toJS = fmap uncheckedWrapJSVal . toJSVal + +pToJS :: (PToJSVal a, IsJSVal (JSType a)) => a -> JSType a +pToJS = uncheckedWrapJSVal . pToJSVal + +type family JSType a + +type instance JSType JSVal = JSVal +type instance JSType () = JSVal +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 = Boolean +-- FIXME: consider whether we should have fine grained types for numbers +type instance JSType Int = Number +type instance JSType Int8 = Number +type instance JSType Int16 = Number +type instance JSType Int32 = Number +type instance JSType Word = Number +type instance JSType Word8 = Number +type instance JSType Word16 = Number +type instance JSType Word32 = Number +type instance JSType Float = Number +type instance JSType Double = Number +type instance JSType AE.Value = JSVal +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 JSVal wrappers which are imported +-- into this module. + +type instance JSType JSString = JSString +deriving instance FromJSVal JSString +deriving instance ToJSVal JSString +deriving instance PFromJSVal JSString +deriving instance PToJSVal JSString + +type instance JSType (Nullable a) = Nullable a +deriving instance FromJSVal (Nullable a) +deriving instance ToJSVal (Nullable a) +deriving instance PFromJSVal (Nullable a) +deriving instance PToJSVal (Nullable a) + +type instance JSType (AI.SomeJSArray m) = AI.SomeJSArray m +deriving instance FromJSVal (AI.SomeJSArray a) +deriving instance ToJSVal (AI.SomeJSArray a) +deriving instance PFromJSVal (AI.SomeJSArray a) +deriving instance PToJSVal (AI.SomeJSArray a) + +type instance JSType Boolean = Boolean +deriving instance FromJSVal Boolean +deriving instance ToJSVal Boolean +deriving instance PFromJSVal Boolean +deriving instance PToJSVal Boolean + +type instance JSType Number = Number +deriving instance FromJSVal Number +deriving instance ToJSVal Number +deriving instance PFromJSVal Number +deriving instance PToJSVal Number + +type instance JSType OI.Object = OI.Object +deriving instance FromJSVal OI.Object +deriving instance ToJSVal OI.Object +deriving instance PFromJSVal OI.Object +deriving instance PToJSVal OI.Object + +-- ----------------------------------------------------------------------------- + instance FromJSVal JSVal where fromJSValUnchecked x = return x {-# INLINE fromJSValUnchecked #-} @@ -70,21 +234,6 @@ instance FromJSVal () where {-# INLINE fromJSValUnchecked #-} fromJSVal = fromJSVal_pure -- {-# INLINE fromJSVal #-} -instance FromJSVal a => FromJSVal [a] where - fromJSVal = fromJSValListOf - {-# INLINE fromJSVal #-} -instance FromJSVal a => FromJSVal (Maybe a) where - fromJSValUnchecked x | isUndefined x || isNull x = return Nothing - | otherwise = fromJSVal x - {-# INLINE fromJSValUnchecked #-} - fromJSVal x | isUndefined x || isNull x = return (Just Nothing) - | otherwise = fmap (fmap Just) fromJSVal x - {-# INLINE fromJSVal #-} -instance FromJSVal JSString where - fromJSValUnchecked = fromJSValUnchecked_pure - {-# INLINE fromJSValUnchecked #-} - fromJSVal = fromJSVal_pure - {-# INLINE fromJSVal #-} instance FromJSVal Text where fromJSValUnchecked = fromJSValUnchecked_pure {-# INLINE fromJSValUnchecked #-} @@ -95,10 +244,6 @@ instance FromJSVal Char where {-# INLINE fromJSValUnchecked #-} fromJSVal = fromJSVal_pure {-# INLINE fromJSVal #-} - fromJSValUncheckedListOf = fromJSValUnchecked_pure - {-# INLINE fromJSValListOf #-} - fromJSValListOf = fromJSVal_pure - {-# INLINE fromJSValUncheckedListOf #-} instance FromJSVal Bool where fromJSValUnchecked = fromJSValUnchecked_pure {-# INLINE fromJSValUnchecked #-} @@ -207,17 +352,12 @@ instance ToJSVal JSVal where instance ToJSVal AE.Value where toJSVal = toJSVal_aeson {-# INLINE toJSVal #-} -instance ToJSVal JSString where - toJSVal = toJSVal_pure - {-# INLINE toJSVal #-} instance ToJSVal Text where toJSVal = toJSVal_pure {-# INLINE toJSVal #-} instance ToJSVal Char where toJSVal = return . pToJSVal {-# INLINE toJSVal #-} - toJSValListOf = return . pToJSVal - {-# INLINE toJSValListOf #-} instance ToJSVal Bool where toJSVal = toJSVal_pure {-# INLINE toJSVal #-} @@ -251,13 +391,6 @@ instance ToJSVal Float where instance ToJSVal Double where toJSVal = toJSVal_pure {-# INLINE toJSVal #-} -instance ToJSVal a => ToJSVal [a] where - toJSVal = toJSValListOf - {-# INLINE toJSVal #-} -instance ToJSVal a => ToJSVal (Maybe a) where - toJSVal Nothing = return jsNull - toJSVal (Just a) = toJSVal a - {-# INLINE toJSVal #-} instance (ToJSVal a, ToJSVal b) => ToJSVal (a,b) where toJSVal (a,b) = join $ arr2 <$> toJSVal a <*> toJSVal b {-# INLINE toJSVal #-} diff --git a/GHCJS/Marshal/Internal.hs b/GHCJS/Marshal/Internal.hs index 379db1d..6c3eb63 100644 --- a/GHCJS/Marshal/Internal.hs +++ b/GHCJS/Marshal/Internal.hs @@ -49,9 +49,6 @@ class PFromJSVal a where class ToJSVal a where toJSVal :: a -> IO JSVal - toJSValListOf :: [a] -> IO JSVal - toJSValListOf = Prim.toJSArray <=< mapM toJSVal - -- default toJSVal :: PToJSVal a => a -> IO (JSVal a) -- toJSVal x = return (pToJSVal x) @@ -65,12 +62,6 @@ class FromJSVal a where fromJSValUnchecked = fmap fromJust . fromJSVal {-# INLINE fromJSValUnchecked #-} - fromJSValListOf :: JSVal -> IO (Maybe [a]) - fromJSValListOf = fmap sequence . (mapM fromJSVal <=< Prim.fromJSArray) -- fixme should check that it's an array - - fromJSValUncheckedListOf :: JSVal -> IO [a] - fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< Prim.fromJSArray - -- default fromJSVal :: PFromJSVal a => JSVal a -> IO (Maybe a) -- fromJSVal x = return (Just (pFromJSVal x)) diff --git a/GHCJS/Marshal/List.hs b/GHCJS/Marshal/List.hs new file mode 100644 index 0000000..b4fc933 --- /dev/null +++ b/GHCJS/Marshal/List.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module implements instances of 'ToJS' and 'FromJS' for lists, +-- specializing the instance for @[Char]@ ('String') so that it is +-- efficiently converted to and from a 'JSString'. +-- +-- It safely uses @-XUndecidableInstances@ and a closed type family to +-- accomplish this, and the result is that +-- +-- > toJS [True] :: JSArray +-- +-- Whereas +-- +-- > toJS "Hi!" :: JSString +-- +-- Since this uses a closed type family, no additional specializations +-- can be added for lists. This is why the methods for the `ListToJSVal` +-- and `ListFromJSVal` classes aren't exported. +module GHCJS.Marshal.List + ( ListToJSVal + , ListFromJSVal + , JSListType + ) where + +import Control.Monad +import GHCJS.Marshal.Pure +import GHCJS.Marshal.Internal +import GHCJS.Types +import qualified GHCJS.Prim as Prim +import JavaScript.Array (JSArray) + +instance ListToJSVal a => ToJSVal [a] where + toJSVal = listToJSVal + +instance ListFromJSVal a => FromJSVal [a] where + fromJSVal = listFromJSVal + +-- | This implements conversion of a list of values to a javascript +-- reference. The type parameter is the type of the list element. If +-- it's 'Char', then the result is a 'JSString'. Otherwise, it's a +-- 'JSArray'. +class ListToJSVal a where + listToJSVal :: [a] -> IO JSVal + +instance {-# OVERLAPPABLE #-} ToJSVal a => ListToJSVal a where + listToJSVal = Prim.toJSArray <=< mapM toJSVal + +instance {-# OVERLAPPING #-} ListToJSVal Char where + listToJSVal = toJSVal_pure + +-- This implements conversion of a javascript reference to a list of +-- values. The type parameter is the type of the list element. If it's +-- 'Char', then it expects a 'JSString'. Otherwise, it expects a +-- 'JSArray'. +class ListFromJSVal a where + listFromJSVal :: JSVal -> IO (Maybe [a]) + +instance {-# OVERLAPPABLE #-} FromJSVal a => ListFromJSVal a where + listFromJSVal = fmap sequence . (mapM fromJSVal <=< Prim.fromJSArray) -- fixme should check that it's an array + +instance {-# OVERLAPPING #-} ListFromJSVal Char where + listFromJSVal = fromJSVal_pure + +type family JSListType a where + JSListType Char = JSString + -- FIXME: this should really have the list type. + JSListType a = JSArray diff --git a/GHCJS/Marshal/Maybe.hs b/GHCJS/Marshal/Maybe.hs new file mode 100644 index 0000000..c401f58 --- /dev/null +++ b/GHCJS/Marshal/Maybe.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies, + DataKinds, + PolyKinds, + UndecidableInstances + #-} + +-- | This module implements instances of 'ToJS' and 'FromJS' for +-- 'Maybe'. @(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@. +-- +-- In particular, this uses the closed type family 'EnsureNotMaybe' to +-- throw a descriptive compile time when marshaling nested 'Maybe' types +-- is attempted. It also relies on a safe usage of +-- 'UndecidableInstances'. +module GHCJS.Marshal.Maybe + ( EnsureNotMaybe + ) where + +import GHC.Prim +import GHCJS.Foreign.Internal +import GHCJS.Marshal.Internal +import GHCJS.Marshal.Pure +import GHCJS.Types + +-- | The result of 'EnsureNotMaybe' is a 'Constraint'. When its +-- parameter matches 'Maybe', it invokes an uninhabited type family in +-- order to cause a type error. Otherwise, it yields an empty +-- constraint, @()@. +type family EnsureNotMaybe a :: Constraint where + EnsureNotMaybe (Maybe x) = Error "Can't correctly marshal nested Maybe types to / from JS." + EnsureNotMaybe x = () + +type family Error (a :: k1) :: k2 + +instance (FromJSVal a, EnsureNotMaybe a) => FromJSVal (Maybe a) where + fromJSValUnchecked x | isUndefined x || isNull x = return Nothing + | otherwise = fromJSVal x + {-# INLINE fromJSValUnchecked #-} + fromJSVal x | isUndefined x || isNull x = return (Just Nothing) + | otherwise = fmap (fmap Just) fromJSVal x + {-# INLINE fromJSVal #-} + +instance (ToJSVal a, EnsureNotMaybe a) => ToJSVal (Maybe a) where + toJSVal Nothing = return jsNull + toJSVal (Just a) = toJSVal a + {-# INLINE toJSVal #-} + +instance (PFromJSVal a, EnsureNotMaybe a) => PFromJSVal (Maybe a) where + pFromJSVal x | isUndefined x || isNull x = Nothing + pFromJSVal x = Just (pFromJSVal x) + {-# INLINE pFromJSVal #-} + +instance (PToJSVal a, EnsureNotMaybe a) => PToJSVal (Maybe a) where + pToJSVal Nothing = jsNull + pToJSVal (Just a) = pToJSVal a + {-# INLINE pToJSVal #-} diff --git a/GHCJS/Marshal/Pure.hs b/GHCJS/Marshal/Pure.hs index 056d01d..74f77a7 100644 --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -60,9 +60,6 @@ instance PFromJSVal JSVal where pFromJSVal = id {-# INLINE pFromJSVal #-} instance PFromJSVal () where pFromJSVal _ = () {-# INLINE pFromJSVal #-} - -instance PFromJSVal JSString where pFromJSVal = JSString - {-# INLINE pFromJSVal #-} instance PFromJSVal [Char] where pFromJSVal = Prim.fromJSString {-# INLINE pFromJSVal #-} instance PFromJSVal Text where pFromJSVal = textFromJSVal @@ -92,15 +89,8 @@ instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x) instance PFromJSVal Double where pFromJSVal x = D# (jsvalToDouble x) {-# INLINE pFromJSVal #-} -instance PFromJSVal a => PFromJSVal (Maybe a) where - pFromJSVal x | isUndefined x || isNull x = Nothing - pFromJSVal x = Just (pFromJSVal x) - {-# INLINE pFromJSVal #-} - instance PToJSVal JSVal where pToJSVal = id {-# INLINE pToJSVal #-} -instance PToJSVal JSString where pToJSVal = jsval - {-# INLINE pToJSVal #-} instance PToJSVal [Char] where pToJSVal = Prim.toJSString {-# INLINE pToJSVal #-} instance PToJSVal Text where pToJSVal = jsval . textToJSString @@ -131,11 +121,6 @@ instance PToJSVal Float where pToJSVal (F# x) = floatToJSVal x instance PToJSVal Double where pToJSVal (D# x) = doubleToJSVal x {-# INLINE pToJSVal #-} -instance PToJSVal a => PToJSVal (Maybe a) where - pToJSVal Nothing = jsNull - pToJSVal (Just a) = pToJSVal a - {-# INLINE pToJSVal #-} - foreign import javascript unsafe "$r = $1|0;" jsvalToWord :: JSVal -> Word# foreign import javascript unsafe "$r = $1&0xff;" jsvalToWord8 :: JSVal -> Word# foreign import javascript unsafe "$r = $1&0xffff;" jsvalToWord16 :: JSVal -> Word# diff --git a/GHCJS/Nullable.hs b/GHCJS/Nullable.hs index e2bf601..5de1b6b 100644 --- a/GHCJS/Nullable.hs +++ b/GHCJS/Nullable.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module GHCJS.Nullable ( Nullable(..) , nullableToMaybe , maybeToNullable ) where -import GHCJS.Prim (JSVal(..)) +import Data.Typeable (Typeable) import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..)) +import GHCJS.Marshal.Maybe +import GHCJS.Prim (JSVal(..)) +import GHCJS.Types (IsJSVal) newtype Nullable a = Nullable JSVal + deriving (Typeable, IsJSVal) -nullableToMaybe :: PFromJSVal a => Nullable a -> Maybe a +nullableToMaybe :: (PFromJSVal a, EnsureNotMaybe a) => Nullable a -> Maybe a nullableToMaybe (Nullable r) = pFromJSVal r {-# INLINE nullableToMaybe #-} -maybeToNullable :: PToJSVal a => Maybe a -> Nullable a +maybeToNullable :: (PToJSVal a, EnsureNotMaybe a) => Maybe a -> Nullable a maybeToNullable = Nullable . pToJSVal {-# INLINE maybeToNullable #-} diff --git a/JavaScript/Bool.hs b/JavaScript/Bool.hs new file mode 100644 index 0000000..48655bc --- /dev/null +++ b/JavaScript/Bool.hs @@ -0,0 +1,6 @@ +module JavaScript.Bool where + +import GHCJS.Types + +newtype JSBool = JSBool JSVal +instance IsJSVal JSBool diff --git a/JavaScript/Boolean.hs b/JavaScript/Boolean.hs new file mode 100644 index 0000000..abacb11 --- /dev/null +++ b/JavaScript/Boolean.hs @@ -0,0 +1,6 @@ +module JavaScript.Boolean where + +import GHCJS.Types + +newtype Boolean = Boolean JSVal +instance IsJSVal Boolean diff --git a/JavaScript/Number.hs b/JavaScript/Number.hs index 523c211..f7e2e49 100644 --- a/JavaScript/Number.hs +++ b/JavaScript/Number.hs @@ -1,2 +1,6 @@ module JavaScript.Number where +import GHCJS.Types + +newtype Number = Number JSVal +instance IsJSVal Number diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/JavaScript/TypedArray/ArrayBuffer/Internal.hs index 87c93a6..fc18647 100644 --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ b/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -10,31 +10,27 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module JavaScript.TypedArray.ArrayBuffer.Internal where import GHCJS.Types import GHCJS.Internal.Types +import GHCJS.Marshal import GHCJS.Marshal.Pure import GHC.Exts (State#) import Data.Typeable -newtype SomeArrayBuffer (a :: MutabilityType s) = - SomeArrayBuffer JSVal deriving Typeable -instance IsJSVal (SomeArrayBuffer m) +newtype SomeArrayBuffer (a :: MutabilityType s) = SomeArrayBuffer JSVal + deriving (Typeable, IsJSVal, ToJSVal, FromJSVal, PToJSVal, PFromJSVal) type ArrayBuffer = SomeArrayBuffer Immutable type MutableArrayBuffer = SomeArrayBuffer Mutable type STArrayBuffer s = SomeArrayBuffer (STMutable s) -instance PToJSVal MutableArrayBuffer where - pToJSVal (SomeArrayBuffer b) = b -instance PFromJSVal MutableArrayBuffer where - pFromJSVal = SomeArrayBuffer - -- ---------------------------------------------------------------------------- foreign import javascript unsafe diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index c7fd047..e401a7f 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -70,12 +70,15 @@ library GHCJS.Foreign.Internal GHCJS.Marshal GHCJS.Marshal.Internal + GHCJS.Marshal.List + GHCJS.Marshal.Maybe GHCJS.Marshal.Pure GHCJS.Nullable GHCJS.Types JavaScript.Array JavaScript.Array.Internal JavaScript.Array.ST + JavaScript.Boolean JavaScript.Cast JavaScript.JSON JavaScript.JSON.Types diff --git a/test/Tests/Marshal.hs b/test/Tests/Marshal.hs index 020a5a5..9425b30 100644 --- a/test/Tests/Marshal.hs +++ b/test/Tests/Marshal.hs @@ -5,6 +5,8 @@ module Tests.Marshal ( import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) +import GHCJS.Marshal.Maybe (EnsureNotMaybe) +import GHCJS.Marshal.List (ListToJSVal, ListFromJSVal) import GHCJS.Marshal.Pure (PFromJSVal(..), PToJSVal(..)) import GHCJS.Marshal (FromJSVal(..), ToJSVal(..)) import Tests.QuickCheckUtils (eq) @@ -24,7 +26,7 @@ pure_to_from_jsval' a = pFromJSVal (pToJSVal a) == a pure_to_from_jsval :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> a -> Bool pure_to_from_jsval _ = pure_to_from_jsval' -pure_to_from_jsval_maybe :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> Maybe a -> Bool +pure_to_from_jsval_maybe :: (PToJSVal a, PFromJSVal a, Eq a, EnsureNotMaybe a) => TypeName a -> Maybe a -> Bool pure_to_from_jsval_maybe _ = pure_to_from_jsval' to_from_jsval' :: (ToJSVal a, FromJSVal a, Eq a) => a -> Property @@ -35,22 +37,22 @@ to_from_jsval' a = monadicIO $ do to_from_jsval :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> a -> Property to_from_jsval _ = to_from_jsval' -to_from_jsval_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe a -> Property +to_from_jsval_maybe :: (ToJSVal a, FromJSVal a, Eq a, EnsureNotMaybe a) => TypeName a -> Maybe a -> Property to_from_jsval_maybe _ = to_from_jsval' -to_from_jsval_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [a] -> Property +to_from_jsval_list :: (ListToJSVal a, ListFromJSVal a, FromJSVal a, Eq a) => TypeName a -> [a] -> Property to_from_jsval_list _ = to_from_jsval' -to_from_jsval_list_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [Maybe a] -> Property +to_from_jsval_list_maybe :: (ListToJSVal (Maybe a), ListFromJSVal (Maybe a), FromJSVal a, Eq a) => TypeName a -> [Maybe a] -> Property to_from_jsval_list_maybe _ = to_from_jsval' -to_from_jsval_list_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [[a]] -> Property +to_from_jsval_list_list :: (ListToJSVal [a], ListFromJSVal [a], FromJSVal a, Eq a) => TypeName a -> [[a]] -> Property to_from_jsval_list_list _ = to_from_jsval' -to_from_jsval_maybe_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe [a] -> Property +to_from_jsval_maybe_list :: (ListToJSVal a, ListFromJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe [a] -> Property to_from_jsval_maybe_list _ = to_from_jsval' -pureMarshalTestGroup :: (PToJSVal a, PFromJSVal a, ToJSVal a, FromJSVal a, Eq a, Show a, Arbitrary a) => TypeName a -> Test +pureMarshalTestGroup :: (PToJSVal a, PFromJSVal a, ToJSVal a, FromJSVal a, ListToJSVal a, ListFromJSVal a, EnsureNotMaybe a, Eq a, Show a, Arbitrary a) => TypeName a -> Test pureMarshalTestGroup t@(TypeName n) = testGroup n [ testProperty "pure_to_from_jsval" (pure_to_from_jsval t),