{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#ifdef ghcjs_HOST_OS
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
#endif
module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
#ifdef USE_TEMPLATE_HASKELL
, Safety (..)
#endif
) where
import Foreign.JavaScript.Orphans ()
import Prelude hiding ((!!))
import Reflex.Class
import Reflex.Adjustable.Class
import Reflex.Host.Class
import Reflex.PerformEvent.Class
#ifdef USE_TEMPLATE_HASKELL
import Language.Haskell.TH
#endif
import GHCJS.DOM.Types (JSContextRef, askJSM)
#ifdef ghcjs_HOST_OS
import qualified GHCJS.Buffer as JS
import GHCJS.DOM.Types (MonadJSM)
import qualified GHCJS.DOM.Types as JS
import qualified GHCJS.Foreign as JS
import qualified GHCJS.Foreign.Callback as JS
import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
import qualified JavaScript.Array as JS
import qualified JavaScript.Array.Internal (SomeJSArray (..))
import qualified JavaScript.Object as JS
import qualified JavaScript.Object.Internal (Object (..))
import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
import Data.Hashable
import Data.Word
import Foreign.C.Types
import Foreign.Ptr
import Text.Encoding.Z
#else
import GHCJS.DOM.Types (MonadJSM (..), runJSM)
#endif
import Control.Monad.Exception
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Primitive
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.Trans.Control
import Data.Coerce (coerce)
newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where
type PrimState (WithJSContextSingleton x m) = PrimState m
primitive = lift . primitive
instance Adjustable t m => Adjustable t (WithJSContextSingleton x m) where
runWithReplace a0 a' = WithJSContextSingleton $ runWithReplace (coerce a0) (coerceEvent a')
traverseIntMapWithKeyWithAdjust f dm0 dm' = WithJSContextSingleton $ traverseIntMapWithKeyWithAdjust (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')
traverseDMapWithKeyWithAdjust f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjust (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')
traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')
instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithJSContextSingleton x m) where
{-# INLINABLE newEventWithTrigger #-}
newEventWithTrigger = lift . newEventWithTrigger
{-# INLINABLE newFanEventWithTrigger #-}
newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithJSContextSingleton x m) where
{-# INLINABLE subscribeEvent #-}
subscribeEvent = lift . subscribeEvent
instance MonadReflexHost t m => MonadReflexHost t (WithJSContextSingleton x m) where
type ReadPhase (WithJSContextSingleton x m) = ReadPhase m
{-# INLINABLE fireEventsAndRead #-}
fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
{-# INLINABLE runHostFrame #-}
runHostFrame = lift . runHostFrame
instance MonadSample t m => MonadSample t (WithJSContextSingleton x m) where
{-# INLINABLE sample #-}
sample = lift . sample
instance MonadHold t m => MonadHold t (WithJSContextSingleton x m) where
{-# INLINABLE hold #-}
hold v0 = lift . hold v0
{-# INLINABLE holdDyn #-}
holdDyn v0 = lift . holdDyn v0
{-# INLINABLE holdIncremental #-}
holdIncremental v0 = lift . holdIncremental v0
{-# INLINABLE buildDynamic #-}
buildDynamic a0 = lift . buildDynamic a0
{-# INLINABLE headE #-}
headE = lift . headE
instance MonadTransControl (WithJSContextSingleton x) where
type StT (WithJSContextSingleton x) a = StT (ReaderT (JSContextSingleton x)) a
{-# INLINABLE liftWith #-}
liftWith = defaultLiftWith WithJSContextSingleton unWithJSContextSingleton
{-# INLINABLE restoreT #-}
restoreT = defaultRestoreT WithJSContextSingleton
instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)
{-# INLINABLE performEvent_ #-}
performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
{-# INLINABLE performEvent #-}
performEvent e = liftWith $ \run -> performEvent $ fmap run e
runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a
runWithJSContextSingleton = runReaderT . unWithJSContextSingleton
instance MonadRef m => MonadRef (WithJSContextSingleton x m) where
type Ref (WithJSContextSingleton x m) = Ref m
newRef = lift . newRef
readRef = lift . readRef
writeRef r = lift . writeRef r
instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where
atomicModifyRef r = lift . atomicModifyRef r
withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r
withJSContextSingleton f = askJSM >>= f . JSContextSingleton
withJSContextSingletonMono :: MonadJSM m => (JSContextSingleton () -> m r) -> m r
withJSContextSingletonMono f = askJSM >>= f . JSContextSingleton
newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }
#ifndef ghcjs_HOST_OS
instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where
liftJSM' f = do
wv <- WithJSContextSingleton ask
runJSM f $ unJSContextSingleton wv
#endif