#ifdef ghcjs_HOST_OS
#else
#endif
module Language.Javascript.JSaddle.Types (
JSContextRef(..)
, JSM(..)
, MonadJSM(..)
, liftJSM
, GHCJSPure(..)
, ghcjsPure
, ghcjsPureMap
, ghcjsPureId
, JSVal(..)
, IsJSVal(..)
, jsval
, SomeJSArray(..)
, JSArray
, MutableJSArray
, STJSArray
, Object(..)
, JSString(..)
, Nullable(..)
, JSCallAsFunction
#ifndef ghcjs_HOST_OS
, MutabilityType(..)
, Mutable
, Immutable
, IsItMutable(..)
, Mutability
, JSValueReceived(..)
, JSValueForSend(..)
, JSStringReceived(..)
, JSStringForSend(..)
, JSObjectForSend(..)
, AsyncCommand(..)
, Command(..)
, Batch(..)
, Result(..)
, Results(..)
#endif
) where
import Control.Monad.IO.Class (MonadIO(..))
#ifdef ghcjs_HOST_OS
import GHCJS.Types
import JavaScript.Object.Internal (Object(..))
import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
import GHCJS.Nullable (Nullable(..))
#else
import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
import Data.JSString.Internal.Type (JSString(..))
import Control.DeepSeq (NFData(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State.Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict
(StateT(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Fix (MonadFix)
import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
import Control.Concurrent.STM.TVar (TVar)
import Data.Text (Text)
import Data.Time.Clock (UTCTime(..))
import Data.Typeable (Typeable)
import Data.Coerce (coerce, Coercible)
import Data.Aeson
(defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
import GHC.Generics (Generic)
#endif
#ifdef ghcjs_HOST_OS
type JSContextRef = ()
#else
data JSContextRef = JSContextRef {
startTime :: UTCTime
, doSendCommand :: Command -> IO Result
, doSendAsyncCommand :: AsyncCommand -> IO ()
, addCallback :: Object -> JSCallAsFunction -> IO ()
, freeCallback :: Object -> IO ()
, nextRef :: TVar JSValueRef
}
#endif
#ifdef ghcjs_HOST_OS
type JSM = IO
#else
newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
#endif
#ifdef ghcjs_HOST_OS
type GHCJSPure a = a
#else
newtype GHCJSPure a = GHCJSPure (JSM a)
#endif
ghcjsPure :: GHCJSPure a -> JSM a
#ifdef ghcjs_HOST_OS
ghcjsPure = pure
#else
ghcjsPure (GHCJSPure x) = x
#endif
ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b
#ifdef ghcjs_HOST_OS
ghcjsPureMap = id
#else
ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x)
#endif
ghcjsPureId :: a -> GHCJSPure a
#ifdef ghcjs_HOST_OS
ghcjsPureId = id
#else
ghcjsPureId = GHCJSPure . return
#endif
#ifdef ghcjs_HOST_OS
type MonadJSM = MonadIO
#else
class (Applicative m, MonadIO m) => MonadJSM m where
liftJSM' :: JSM a -> m a
instance MonadJSM JSM where
liftJSM' = id
instance MonadJSM m => MonadJSM (ReaderT e m) where
liftJSM' = lift . liftJSM'
instance MonadJSM m => MonadJSM (StateT r m) where
liftJSM' = lift . liftJSM'
instance MonadJSM m => MonadJSM (Strict.StateT r m) where
liftJSM' = lift . liftJSM'
instance MonadRef JSM where
type Ref JSM = Ref IO
newRef = liftIO . newRef
readRef = liftIO . readRef
writeRef r = liftIO . writeRef r
instance MonadAtomicRef JSM where
atomicModifyRef r = liftIO . atomicModifyRef r
#endif
liftJSM :: MonadJSM m => JSM a -> m a
#ifdef ghcjs_HOST_OS
liftJSM = liftIO
#else
liftJSM = liftJSM'
#endif
type JSCallAsFunction = JSVal
-> JSVal
-> [JSVal]
-> JSM ()
#ifndef ghcjs_HOST_OS
class IsJSVal a where
jsval_ :: a -> GHCJSPure JSVal
default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
jsval_ = GHCJSPure . return . coerce
jsval :: IsJSVal a => a -> GHCJSPure JSVal
jsval = jsval_
data MutabilityType s = Mutable_ s
| Immutable_ s
| STMutable s
type Mutable = Mutable_ ()
type Immutable = Immutable_ ()
data IsItMutable = IsImmutable
| IsMutable
type family Mutability (a :: MutabilityType s) :: IsItMutable where
Mutability Immutable = IsImmutable
Mutability Mutable = IsMutable
Mutability (STMutable s) = IsMutable
newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
deriving (Typeable)
instance IsJSVal (SomeJSArray m)
type JSArray = SomeJSArray Immutable
type MutableJSArray = SomeJSArray Mutable
type STJSArray s = SomeJSArray (STMutable s)
newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
newtype Nullable a = Nullable a
newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON, Generic)
instance NFData JSValueForSend
newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON, Generic)
instance NFData JSObjectForSend
newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON, Generic)
instance NFData JSStringForSend
data AsyncCommand = FreeRef JSValueForSend
| SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
| SetPropertyAtIndex JSObjectForSend Int JSValueForSend
| StringToValue JSStringForSend JSValueForSend
| NumberToValue Double JSValueForSend
| JSONValueToValue Value JSValueForSend
| GetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
| GetPropertyAtIndex JSObjectForSend Int JSValueForSend
| CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
| CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
| NewEmptyObject JSValueForSend
| NewCallback JSValueForSend
| NewArray [JSValueForSend] JSValueForSend
| EvaluateScript JSStringForSend JSValueForSend
| SyncWithAnimationFrame JSValueForSend
deriving (Show, Generic)
instance ToJSON AsyncCommand where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AsyncCommand
instance NFData AsyncCommand
data Command = DeRefVal JSValueForSend
| ValueToBool JSValueForSend
| ValueToNumber JSValueForSend
| ValueToString JSValueForSend
| ValueToJSON JSValueForSend
| ValueToJSONValue JSValueForSend
| IsNull JSValueForSend
| IsUndefined JSValueForSend
| StrictEqual JSValueForSend JSValueForSend
| InstanceOf JSValueForSend JSObjectForSend
| PropertyNames JSObjectForSend
| Sync
deriving (Show, Generic)
instance ToJSON Command where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Command
instance NFData Command
data Batch = Batch [Either AsyncCommand Command] Bool
deriving (Show, Generic)
instance ToJSON Batch where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Batch
instance NFData Batch
data Result = DeRefValResult JSValueRef Text
| ValueToBoolResult Bool
| ValueToNumberResult Double
| ValueToStringResult JSStringReceived
| ValueToJSONResult JSStringReceived
| ValueToJSONValueResult Value
| IsNullResult Bool
| IsUndefinedResult Bool
| StrictEqualResult Bool
| InstanceOfResult Bool
| PropertyNamesResult [JSStringReceived]
| ThrowJSValue JSValueReceived
| SyncResult
deriving (Show, Generic)
instance ToJSON Result where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Result
data Results = Success [Result]
| Failure [Result] JSValueReceived
| Callback JSValueReceived JSValueReceived [JSValueReceived]
| ProtocolError Text
deriving (Show, Generic)
instance ToJSON Results where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Results
#endif