diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,12 @@
+Copyright (c) 2015, Obsidian Systems LLC
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/reflex-dom-core.cabal b/reflex-dom-core.cabal
new file mode 100644
--- /dev/null
+++ b/reflex-dom-core.cabal
@@ -0,0 +1,172 @@
+Name: reflex-dom-core
+Version: 0.4
+Synopsis: Functional Reactive Web Apps with Reflex
+Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
+License: BSD3
+License-file: LICENSE
+Author: Ryan Trinkle
+Maintainer: ryan.trinkle@gmail.com
+Stability: Experimental
+Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
+Build-type: Simple
+Cabal-version: >=1.9.2
+-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
+extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs
+ src-ghcjs/Foreign/JavaScript/Internal/Utils.hs
+ src/Reflex/Dom/Xhr/Foreign.hs
+ src/Reflex/Dom/WebSocket/Foreign.hs
+ src/Reflex/Dom/Xhr/ResponseType.hs
+ src/Reflex/Dom/Xhr/Exception.hs
+
+flag use-template-haskell
+ description: Use template haskell to generate lenses
+ default: True
+ manual: True
+
+flag use-reflex-optimizer
+ description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
+ default: False
+ manual: True
+
+flag expose-all-unfoldings
+ description: Build the library with -fexpose-all-unfoldings which can help client code specialize better
+ default: False
+ manual: True
+
+flag profile-reflex
+ description: Add a layer of profiling to all Reflex events in the system
+ default: False
+ manual: True
+
+library
+ hs-source-dirs: src
+ build-depends:
+ aeson >= 0.8 && < 1.4,
+ base >= 4.7 && < 4.12,
+ bifunctors >= 4.2 && < 6,
+ bimap >= 0.3 && < 0.4,
+ blaze-builder,
+ bytestring == 0.10.*,
+ containers == 0.5.*,
+ constraints >= 0.9 && < 0.11,
+ contravariant >= 1.4 && < 1.5,
+ data-default >= 0.5 && < 0.8,
+ dependent-map == 0.2.*,
+ dependent-sum >= 0.3 && < 0.5,
+ dependent-sum-template >= 0.0.0.4 && < 0.1,
+ directory >= 1.2 && < 1.4,
+ exception-transformers == 0.4.*,
+ ghcjs-dom >= 0.9.1.0 && < 0.10,
+ jsaddle >=0.9.0.0 && <0.10,
+ -- keycode-0.2 has a bug on firefox
+ keycode >= 0.2.1 && < 0.3,
+ lens >= 4.7 && < 5,
+ monad-control >= 1.0.1 && < 1.1,
+ mtl >= 2.1 && < 2.3,
+ primitive >= 0.5 && < 0.7,
+ ref-tf == 0.4.*,
+ reflex == 0.5.*,
+ semigroups >= 0.16 && < 0.19,
+ stm == 2.4.*,
+ text == 1.2.*,
+ these >= 0.4 && < 0.8,
+ transformers >= 0.3 && < 0.6,
+ network-uri >= 2.6.1 && < 2.7,
+ zenc == 0.1.*
+
+ if impl(ghcjs)
+ hs-source-dirs: src-ghcjs
+ build-depends:
+ ghcjs-base,
+ hashable == 1.2.*
+ else
+ hs-source-dirs: src-ghc
+ if !os(windows)
+ build-depends: unix == 2.7.*
+
+ exposed-modules:
+ Foreign.JavaScript.TH
+ Foreign.JavaScript.Orphans
+ Foreign.JavaScript.Utils
+ Reflex.Dom.Builder.Class
+ Reflex.Dom.Builder.Class.Events
+ Reflex.Dom.Builder.Immediate
+ Reflex.Dom.Builder.InputDisabled
+ Reflex.Dom.Builder.Static
+ Reflex.Dom.Class
+ Reflex.Dom.Core
+ Reflex.Dom.Location
+ Reflex.Dom.Main
+ Reflex.Dom.Modals.Class
+ Reflex.Dom.Old
+ Reflex.Dom.Prerender
+ Reflex.Dom.Specializations
+ Reflex.Dom.Time
+ Reflex.Dom.WebSocket
+ Reflex.Dom.WebSocket.Query
+ Reflex.Dom.Widget
+ Reflex.Dom.Widget.Basic
+ Reflex.Dom.Widget.Input
+ Reflex.Dom.Widget.Lazy
+ Reflex.Dom.Widget.Resize
+ Reflex.Dom.Xhr
+ other-modules:
+ Foreign.JavaScript.Internal.Utils
+ Reflex.Dom.WebSocket.Foreign
+ Reflex.Dom.Xhr.Foreign
+ Reflex.Dom.Xhr.ResponseType
+ Reflex.Dom.Xhr.Exception
+
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
+ ghc-prof-options: -fprof-auto
+
+ if flag(expose-all-unfoldings)
+ ghc-options: -fexpose-all-unfoldings
+
+ if flag(use-reflex-optimizer)
+ ghc-options: -fplugin=Reflex.Optimizer
+
+ if flag(profile-reflex)
+ cpp-options: -DPROFILE_REFLEX
+
+ if flag(use-template-haskell)
+ build-depends:
+ dependent-sum >= 0.3 && < 0.5,
+ dependent-sum-template >= 0.0.0.5 && < 0.1,
+ template-haskell
+ other-extensions: TemplateHaskell
+ cpp-options: -DUSE_TEMPLATE_HASKELL
+ other-modules:
+ Reflex.Dom.Builder.Class.TH
+ else
+ build-depends:
+ dependent-sum == 0.4.*
+
+test-suite hlint
+ build-depends: base, hlint
+ hs-source-dirs: test
+ main-is: hlint.hs
+ type: exitcode-stdio-1.0
+
+test-suite gc
+ build-depends: base
+ , reflex
+ , reflex-dom-core
+ , jsaddle
+ , jsaddle-warp
+ , linux-namespaces
+ , process
+ , temporary
+ , unix
+ hs-source-dirs: test
+ ghc-options: -rtsopts -with-rtsopts=-T -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
+ ghc-prof-options: -fprof-auto -optP-DPROFILING
+ main-is: gc.hs
+ type: exitcode-stdio-1.0
+ if !os(linux) || !arch(x86_64)
+ buildable: False
+
+source-repository head
+ type: git
+ location: https://github.com/reflex-frp/reflex-dom
+ subdir: reflex-dom-core
diff --git a/src-ghc/Foreign/JavaScript/Internal/Utils.hs b/src-ghc/Foreign/JavaScript/Internal/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src-ghc/Foreign/JavaScript/Internal/Utils.hs
@@ -0,0 +1,17 @@
+module Foreign.JavaScript.Internal.Utils
+ ( synchronously
+ , freeRequestAnimationFrameCallback
+ , js_dataView
+ ) where
+
+import GHCJS.DOM.Types (Callback (..), JSM, JSVal, RequestAnimationFrameCallback (..))
+import Language.Javascript.JSaddle.Object (freeFunction, jsg, new)
+
+synchronously :: JSM a -> JSM a
+synchronously = id
+
+freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()
+freeRequestAnimationFrameCallback (RequestAnimationFrameCallback (Callback cb)) = freeFunction cb
+
+js_dataView :: Int -> Int -> JSVal -> JSM JSVal
+js_dataView off len ref = new (jsg "DataView") (ref, off, len)
diff --git a/src-ghcjs/Foreign/JavaScript/Internal/Utils.hs b/src-ghcjs/Foreign/JavaScript/Internal/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src-ghcjs/Foreign/JavaScript/Internal/Utils.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE JavaScriptFFI #-}
+
+module Foreign.JavaScript.Internal.Utils
+ ( synchronously
+ , freeRequestAnimationFrameCallback
+ , js_dataView
+ ) where
+
+import GHCJS.Concurrent
+import GHCJS.DOM.Types (JSM, JSVal, RequestAnimationFrameCallback (..))
+import GHCJS.Foreign.Callback (releaseCallback)
+
+freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()
+freeRequestAnimationFrameCallback (RequestAnimationFrameCallback cb) = releaseCallback cb
+
+foreign import javascript safe "new DataView($3,$1,$2)"
+ js_dataView :: Int -> Int -> JSVal -> IO JSVal
diff --git a/src/Foreign/JavaScript/Orphans.hs b/src/Foreign/JavaScript/Orphans.hs
new file mode 100644
--- /dev/null
+++ b/src/Foreign/JavaScript/Orphans.hs
@@ -0,0 +1,35 @@
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Foreign.JavaScript.Orphans where
+
+#ifndef ghcjs_HOST_OS
+
+import Control.Monad.Trans.Class (lift)
+import GHCJS.DOM.Types (MonadJSM (..))
+import Reflex.DynamicWriter.Base (DynamicWriterT)
+import Reflex.EventWriter.Base (EventWriterT)
+import Reflex.Host.Class (HostFrame, ReflexHost)
+import Reflex.PerformEvent.Base (PerformEventT (..))
+import Reflex.PostBuild.Base (PostBuildT)
+import Reflex.Requester.Base (RequesterT)
+import Reflex.TriggerEvent.Base
+import Reflex.Query.Base (QueryT)
+
+instance MonadJSM m => MonadJSM (PostBuildT t m) where
+ liftJSM' = lift . liftJSM'
+instance (MonadJSM (HostFrame t), ReflexHost t) => MonadJSM (PerformEventT t m) where
+ liftJSM' = PerformEventT . lift . liftJSM'
+instance MonadJSM m => MonadJSM (DynamicWriterT t w m) where
+ liftJSM' = lift . liftJSM'
+instance MonadJSM m => MonadJSM (EventWriterT t w m) where
+ liftJSM' = lift . liftJSM'
+instance MonadJSM m => MonadJSM (RequesterT t request response m) where
+ liftJSM' = lift . liftJSM'
+instance MonadJSM m => MonadJSM (TriggerEventT t m) where
+ liftJSM' = lift . liftJSM'
+instance MonadJSM m => MonadJSM (QueryT t q m) where
+ liftJSM' = lift . liftJSM'
+
+#endif
diff --git a/src/Foreign/JavaScript/TH.hs b/src/Foreign/JavaScript/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Foreign/JavaScript/TH.hs
@@ -0,0 +1,583 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+#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.DynamicWriter.Base
+import Reflex.EventWriter.Base
+import Reflex.Host.Class
+import Reflex.PerformEvent.Base
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Base
+import Reflex.Requester.Base
+import Reflex.Query.Base (QueryT (..))
+
+#ifdef USE_TEMPLATE_HASKELL
+import Language.Haskell.TH
+#endif
+
+import GHCJS.DOM.Types (JSContextRef, Node (..), 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 Control.Lens.Operators ((^.))
+import Data.Word (Word8)
+import GHCJS.DOM.Types (JSVal, MonadJSM (..), liftJSM, runJSM, toJSString, toJSVal)
+import Language.Javascript.JSaddle (Function (..), array, eval, freeFunction, function, js, js1, jss, valBool,
+ valIsNull, valIsUndefined, valMakeNumber, valMakeString, valToBool,
+ valToNumber, valToText, valUndefined, (!!))
+#endif
+
+import Control.Concurrent
+import Control.Monad
+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.State
+import qualified Control.Monad.State.Strict as Strict
+import Control.Monad.Trans.Control
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Coerce (coerce)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+
+class Monad m => HasJSContext m where
+ type JSContextPhantom m :: *
+ askJSContext :: m (JSContextSingleton (JSContextPhantom m))
+
+type HasWebView = HasJSContext
+-- Not sure if we should deprecate this {-# DEPRECATED HasWebView "Use HasJSContext" #-}
+
+instance HasJSContext m => HasJSContext (ReaderT r m) where
+ type JSContextPhantom (ReaderT r m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (StateT r m) where
+ type JSContextPhantom (StateT r m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (Strict.StateT r m) where
+ type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (PostBuildT t m) where
+ type JSContextPhantom (PostBuildT t m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where
+ type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)
+ askJSContext = PerformEventT $ lift askJSContext
+
+instance HasJSContext m => HasJSContext (EventWriterT t w m) where
+ type JSContextPhantom (EventWriterT t w m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where
+ type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (RequesterT t request response m) where
+ type JSContextPhantom (RequesterT t request response m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJSContext m => HasJSContext (QueryT t q m) where
+ type JSContextPhantom (QueryT t q m) = JSContextPhantom m
+ askJSContext = QueryT askJSContext
+
+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) --TODO: Can we eliminate this wrapper?
+ {-# 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 (Monad m) => HasJSContext (WithJSContextSingleton x m) where
+ type JSContextPhantom (WithJSContextSingleton x m) = x
+ askJSContext = WithJSContextSingleton ask
+
+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
+
+-- | Warning: `withJSContextSingletonMono` does not provide the same guarantees that `withJSContextSingleton` does.
+withJSContextSingletonMono :: MonadJSM m => (JSContextSingleton () -> m r) -> m r
+withJSContextSingletonMono f = askJSM >>= f . JSContextSingleton
+
+-- | A singleton type for a given JSContext; we use this to statically guarantee that different JSContexts don't get mixed up
+newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }
+
+#ifdef ghcjs_HOST_OS
+type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
+newtype JSFFI = JSFFI JSFFI_Internal
+#else
+newtype JSFFI = JSFFI String
+#endif
+
+data JSFun x = JSFun { unJSFun :: JSRef x
+#ifndef ghcjs_HOST_OS
+ , unJSFunction :: Function
+#endif
+ }
+
+instance ToJS x (JSFun x) where
+ withJS r f = f (unJSFun r)
+
+class IsJSContext x where
+ data JSRef x
+
+class (Monad m, MonadJSM (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where
+ type JSX m :: * -> *
+ liftJS :: JSX m a -> m a
+
+instance HasJS x m => HasJS x (ReaderT r m) where
+ type JSX (ReaderT r m) = JSX m
+ liftJS = lift . liftJS
+
+instance HasJS x m => HasJS x (PostBuildT t m) where
+ type JSX (PostBuildT t m) = JSX m
+ liftJS = lift . liftJS
+
+instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
+ type JSX (PerformEventT t m) = JSX (HostFrame t)
+ liftJS = PerformEventT . lift . liftJS
+
+instance HasJS x m => HasJS x (DynamicWriterT t w m) where
+ type JSX (DynamicWriterT t w m) = JSX m
+ liftJS = lift . liftJS
+
+instance HasJS x m => HasJS x (EventWriterT t w m) where
+ type JSX (EventWriterT t w m) = JSX m
+ liftJS = lift . liftJS
+
+instance HasJS x m => HasJS x (RequesterT t request response m) where
+ type JSX (RequesterT t request response m) = JSX m
+ liftJS = lift . liftJS
+
+instance HasJS x m => HasJS x (QueryT t q m) where
+ type JSX (QueryT t q m) = JSX m
+ liftJS = lift . liftJS
+
+-- | A Monad that is capable of executing JavaScript
+class Monad m => MonadJS x m | m -> x where
+ runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
+ forkJS :: m () -> m ThreadId
+ mkJSUndefined :: m (JSRef x)
+ isJSNull :: JSRef x -> m Bool
+ isJSUndefined :: JSRef x -> m Bool
+ fromJSBool :: JSRef x -> m Bool
+ fromJSString :: JSRef x -> m String
+ fromJSArray :: JSRef x -> m [JSRef x]
+ fromJSUint8Array :: JSRef x -> m ByteString
+ fromJSNumber :: JSRef x -> m Double
+ withJSBool :: Bool -> (JSRef x -> m r) -> m r
+ withJSString :: String -> (JSRef x -> m r) -> m r
+ withJSNumber :: Double -> (JSRef x -> m r) -> m r
+ withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
+ withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
+ -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
+ mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
+ freeJSFun :: JSFun x -> m ()
+ setJSProp :: String -> JSRef x -> JSRef x -> m ()
+ getJSProp :: String -> JSRef x -> m (JSRef x)
+ withJSNode :: Node -> (JSRef x -> m r) -> m r
+
+#ifdef ghcjs_HOST_OS
+
+data JSCtx_IO
+type HasJS' = HasJS JSCtx_IO
+
+instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where
+ type JSX (WithJSContextSingleton x m) = IO
+ liftJS = liftIO
+
+instance IsJSContext JSCtx_IO where
+ newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
+
+instance MonadJS JSCtx_IO IO where
+ runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
+ forkJS = forkIO
+ mkJSUndefined = return $ JSRef_IO JS.jsUndefined
+ isJSNull (JSRef_IO r) = return $ JS.isNull r
+ isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
+ fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
+ fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
+ fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
+ fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
+ fromJSNumber (JSRef_IO r) = JS.fromJSValUnchecked r
+ withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
+ withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
+ withJSNumber n f = do
+ r <- JS.toJSVal n
+ f $ JSRef_IO r
+ withJSArray l f = do
+ r <- JS.fromListIO $ coerce l
+ f $ JSRef_IO $ coerce r
+ withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
+ ba <- extractByteArray cStr $ BS.length payload
+ f $ JSUint8Array $ JSRef_IO ba
+ mkJSFun f = do
+ cb <- JS.syncCallback1' $ \args -> do
+ l <- JS.toListIO $ coerce args
+ JSRef_IO result <- f $ coerce l
+ return result
+ fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
+ freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
+ setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
+ getJSProp s (JSRef_IO o) = do
+ r <- JS.getProp (JS.toJSString s) $ coerce o
+ return $ JSRef_IO r
+ withJSNode n f = f $ JSRef_IO $ unNode n
+
+foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
+
+foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
+
+#else
+
+data JSCtx_JavaScriptCore x
+type HasJS' = HasJS (JSCtx_JavaScriptCore ())
+
+instance IsJSContext (JSCtx_JavaScriptCore x) where
+ newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }
+
+instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where
+ type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO
+ liftJS a = do
+ wv <- askJSContext
+ liftIO $ runWithJSContextSingleton a wv
+
+newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
+
+runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
+runWithJSContext = runReaderT . unWithJSContext
+
+instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where
+ liftJSM' f = do
+ wv <- askJSContext
+ runJSM f $ unJSContextSingleton wv
+
+instance MonadIO m => MonadJSM (WithJSContext x m) where
+ liftJSM' f =
+ runJSM f =<< WithJSContext ask
+
+lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a
+lowerWithJSContext a = do
+ c <- askJSM
+ liftIO $ runWithJSContext a c
+
+liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)
+ => ((t1 -> t m1 a) -> WithJSContext x IO b)
+ -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)
+ -> m b
+liftWithJSContextSingletonThroughWithJSContext f a = do
+ wv <- askJSContext
+ lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv
+
+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where
+ forkJS a = do
+ wv <- askJSContext
+ liftIO $ forkIO $ runWithJSContextSingleton a wv
+ mkJSFun a = do
+ wv <- askJSContext
+ lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv
+ runJS expr args = lowerWithJSContext $ runJS expr args
+ mkJSUndefined = lowerWithJSContext mkJSUndefined
+ isJSNull = lowerWithJSContext . isJSNull
+ isJSUndefined = lowerWithJSContext . isJSUndefined
+ fromJSBool = lowerWithJSContext . fromJSBool
+ fromJSString = lowerWithJSContext . fromJSString
+ fromJSArray = lowerWithJSContext . fromJSArray
+ fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
+ fromJSNumber = lowerWithJSContext . fromJSNumber
+ freeJSFun = lowerWithJSContext . freeJSFun
+ withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool
+ withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString
+ withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber
+ withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray
+ withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array
+ withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode
+ setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
+ getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
+
+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
+ runJS (JSFFI body) args =
+ withJSArray args $ \(JSRef_JavaScriptCore this) -> do
+ result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this
+ return $ JSRef_JavaScriptCore result
+ forkJS a = do
+ c <- askJSM
+ liftIO . forkIO $ runWithJSContext a c
+ mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined
+ isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r
+ isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r
+ fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r
+ fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)
+ withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)
+ withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)
+ withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)
+ withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM
+ (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))
+ withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
+ payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
+ f $ JSUint8Array payloadRef
+ fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do
+ len <- round <$> (valToNumber =<< (a ^. js "length"))
+ forM [0..len-1] $ fmap JSRef_JavaScriptCore . (a !!)
+ fromJSUint8Array a = do
+ vals <- fromJSArray a
+ doubles <- mapM fromJSNumber vals
+ return $ BS.pack $ map round doubles
+ fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val
+ mkJSFun a = liftJSM $ do
+ ctx <- askJSM
+ f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx
+ fRef <- toJSVal f
+ return $ JSFun (JSRef_JavaScriptCore fRef) f
+ freeJSFun (JSFun _ f) = liftJSM $ freeFunction f
+ setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =
+ liftJSM $ objRef ^. jss propName valRef
+ getJSProp propName (JSRef_JavaScriptCore objRef) =
+ JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)
+ withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)
+
+#endif
+
+class FromJS x a where
+ fromJS :: MonadJS x m => JSRef x -> m a
+
+instance FromJS x () where
+ fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
+
+instance FromJS x Bool where
+ fromJS = fromJSBool
+
+instance ToJS x Bool where
+ withJS = withJSBool
+
+instance FromJS x String where
+ fromJS = fromJSString
+
+instance FromJS x Text where
+ fromJS s = T.pack <$> fromJSString s
+
+instance FromJS x a => FromJS x (Maybe a) where
+ fromJS x = do
+ n <- isJSNull x
+ if n then return Nothing else Just <$> fromJS x
+
+class ToJS x a where
+ withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
+
+instance ToJS x (JSRef x) where
+ withJS r = ($ r)
+
+instance FromJS x (JSRef x) where
+ fromJS = return
+
+instance ToJS x String where
+ withJS = withJSString
+
+instance ToJS x Text where
+ withJS = withJSString . T.unpack
+
+newtype JSArray a = JSArray { unJSArray :: [a] }
+
+instance ToJS x a => ToJS x (JSArray a) where
+ withJS = withJSArrayFromList . unJSArray
+
+instance FromJS x a => FromJS x (JSArray a) where
+ fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
+
+withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
+withJSArrayFromList as f = go as []
+ where go [] jsRefs = withJSArray (reverse jsRefs) f
+ go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
+
+newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
+
+instance ToJS x (JSUint8Array x) where
+ withJS (JSUint8Array r) = ($ r)
+
+instance FromJS x (JSUint8Array x) where
+ fromJS = return . JSUint8Array
+
+instance ToJS x Word8 where
+ withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
+
+instance ToJS x Int where
+ withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
+
+instance FromJS x Int where
+ fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
+
+instance ToJS x Double where
+ withJS = withJSNumber
+
+instance FromJS x Double where
+ fromJS = fromJSNumber
+
+instance ToJS x Node where
+ withJS = withJSNode
+
+
+#ifdef USE_TEMPLATE_HASKELL
+
+importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
+importJS safety body name qt = do
+ t <- qt
+ let (argTypes, _) = parseType t
+ argNames <- forM argTypes $ \_ -> do
+ arg <- newName "arg"
+ argRef <- newName "argRef"
+ return (arg, argRef)
+ (jsffiDecs, jsffiExp) <- mkJSFFI safety body
+ let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
+ |]
+ go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
+ e <- lamE (map (varP. fst) argNames) $ go argNames
+ let n = mkName name
+ return $ jsffiDecs ++
+ [ SigD n t
+ , ValD (VarP n) (NormalB e) []
+ ]
+
+mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
+#ifdef ghcjs_HOST_OS
+mkJSFFI safety body = do
+ -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
+ l <- location
+ n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
+ t <- [t| JSFFI_Internal |]
+ let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
+ let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
+ e <- [| JSFFI $(varE n) |]
+ return (decs, e)
+#else
+mkJSFFI _ body = do
+ e <- [| JSFFI body |]
+ return ([], e)
+#endif
+
+parseType :: Type -> ([Type], Type)
+parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
+ | monadJs == ''MonadJS = go funType
+ where go t = case t of
+ AppT (AppT ArrowT arg) t' ->
+ let (args, result) = go t'
+ in (arg : args, result)
+ AppT (VarT m') result
+ | m' == m -> ([], result)
+ _ -> error $ "parseType: can't parse type " <> show t
+parseType t = error $ "parseType: can't parse type " <> show t
+
+#endif
diff --git a/src/Foreign/JavaScript/Utils.hs b/src/Foreign/JavaScript/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Foreign/JavaScript/Utils.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Foreign.JavaScript.Utils
+ ( bsFromMutableArrayBuffer
+ , bsToArrayBuffer
+ , jsonDecode
+ , js_jsonParse
+ ) where
+
+import Control.Lens
+import Data.Aeson
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Foreign.JavaScript.Internal.Utils (js_dataView)
+import qualified GHCJS.Buffer as JS
+import GHCJS.DOM.Types (ArrayBuffer (..))
+import GHCJS.Marshal ()
+import Language.Javascript.JSaddle (jsg, js1)
+import qualified JavaScript.TypedArray.ArrayBuffer as JS
+import Language.Javascript.JSaddle.Types (JSString, JSM, JSVal, MonadJSM, ghcjsPure, jsval, liftJSM)
+#ifdef ghcjs_HOST_OS
+import Control.Exception (SomeException)
+import Language.Javascript.JSaddle (fromJSVal, catch)
+import System.IO.Unsafe
+#else
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text.Encoding
+import Language.Javascript.JSaddle (textFromJSString)
+#endif
+
+{-# INLINABLE bsFromMutableArrayBuffer #-}
+bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString
+bsFromMutableArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=
+ ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing
+
+{-# INLINABLE bsToArrayBuffer #-}
+bsToArrayBuffer :: MonadJSM m => ByteString -> m ArrayBuffer
+bsToArrayBuffer bs = liftJSM $ do
+ (b, off, len) <- ghcjsPure $ JS.fromByteString bs
+ ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
+ then JS.create 0 >>= ghcjsPure . JS.getArrayBuffer >>= ghcjsPure . jsval
+ else do
+ ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval
+ js_dataView off len ref
+
+jsonDecode :: FromJSON a => JSString -> Maybe a
+#ifdef ghcjs_HOST_OS
+jsonDecode t = do
+ result <- unsafePerformIO $ (fromJSVal =<< js_jsonParse t) `catch` (\(_ :: SomeException) -> pure Nothing)
+ case fromJSON result of
+ Success a -> Just a
+ Error _ -> Nothing
+#else
+jsonDecode = decode . LBS.fromStrict . encodeUtf8 . textFromJSString
+#endif
+
+js_jsonParse :: JSString -> JSM JSVal
+js_jsonParse a = jsg "JSON" ^. js1 "parse" a
diff --git a/src/Reflex/Dom/Builder/Class.hs b/src/Reflex/Dom/Builder/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/Class.hs
@@ -0,0 +1,697 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+#if !MIN_VERSION_base(4,9,0)
+{-# LANGUAGE ImpredicativeTypes #-}
+#endif
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Dom.Builder.Class
+ ( module Reflex.Dom.Builder.Class
+ , module Reflex.Dom.Builder.Class.Events
+ , module Reflex.NotReady.Class
+ ) where
+
+import Reflex.Adjustable.Class
+import Reflex.Class as Reflex
+import Reflex.Dom.Builder.Class.Events
+#ifdef USE_TEMPLATE_HASKELL
+import Reflex.Dom.Builder.Class.TH
+#endif
+import Reflex.DynamicWriter.Base
+import Reflex.EventWriter.Base
+import Reflex.NotReady.Class
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Base
+import Reflex.Query.Base
+import Reflex.Query.Class
+import Reflex.Requester.Base
+
+import qualified Control.Category
+import Control.Lens hiding (element)
+import Control.Monad.Reader
+import qualified Control.Monad.State as Lazy
+import Control.Monad.State.Strict
+import Control.Monad.Trans.Control
+import Data.Default
+import Data.Functor.Misc
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Proxy
+import Data.Semigroup
+import Data.String
+import Data.Text (Text)
+import Data.Type.Coercion
+import GHCJS.DOM.Types (JSM)
+
+class Default (EventSpec d EventResult) => DomSpace d where
+ type EventSpec d :: (EventTag -> *) -> *
+ type RawDocument d :: *
+ type RawTextNode d :: *
+ type RawElement d :: *
+ type RawFile d :: *
+ type RawInputElement d :: *
+ type RawTextAreaElement d :: *
+ type RawSelectElement d :: *
+ addEventSpecFlags :: proxy d -> EventName en -> (Maybe (er en) -> EventFlags) -> EventSpec d er -> EventSpec d er
+
+-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building
+-- dynamic DOM in the 'Reflex' timeline @t@
+class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable t m) => DomBuilder t m | m -> t where
+ type DomBuilderSpace m :: *
+ textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
+ default textNode :: ( MonadTrans f
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
+ textNode = lift . textNode
+ {-# INLINABLE textNode #-}
+ element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
+ default element :: ( MonadTransControl f
+ , StT f a ~ a
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
+ element t cfg child = liftWith $ \run -> element t cfg $ run child
+ {-# INLINABLE element #-}
+ inputElement :: InputElementConfig er t (DomBuilderSpace m) -> m (InputElement er (DomBuilderSpace m) t)
+ default inputElement :: ( MonadTransControl f
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => InputElementConfig er t (DomBuilderSpace m) -> m (InputElement er (DomBuilderSpace m) t)
+ inputElement = lift . inputElement
+ {-# INLINABLE inputElement #-}
+ textAreaElement :: TextAreaElementConfig er t (DomBuilderSpace m) -> m (TextAreaElement er (DomBuilderSpace m) t)
+ default textAreaElement :: ( MonadTransControl f
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => TextAreaElementConfig er t (DomBuilderSpace m) -> m (TextAreaElement er (DomBuilderSpace m) t)
+ textAreaElement = lift . textAreaElement
+ {-# INLINABLE textAreaElement #-}
+ selectElement :: SelectElementConfig er t (DomBuilderSpace m) -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
+ default selectElement :: ( MonadTransControl f
+ , StT f a ~ a
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => SelectElementConfig er t (DomBuilderSpace m) -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
+ selectElement cfg child = do
+ liftWith $ \run -> selectElement cfg $ run child
+ {-# INLINABLE selectElement #-}
+ placeRawElement :: RawElement (DomBuilderSpace m) -> m ()
+ default placeRawElement :: ( MonadTrans f
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => RawElement (DomBuilderSpace m) -> m ()
+ placeRawElement = lift . placeRawElement
+ {-# INLINABLE placeRawElement #-}
+ wrapRawElement :: RawElement (DomBuilderSpace m) -> RawElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t)
+ default wrapRawElement :: ( MonadTrans f
+ , m ~ f m'
+ , DomBuilderSpace m' ~ DomBuilderSpace m
+ , DomBuilder t m'
+ )
+ => RawElement (DomBuilderSpace m) -> RawElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t)
+ wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
+ { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
+ }
+ {-# INLINABLE wrapRawElement #-}
+
+class DomBuilder t m => MountableDomBuilder t m where
+ type DomFragment m :: *
+ buildDomFragment :: m a -> m (DomFragment m, a)
+ mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()
+
+type Namespace = Text
+
+data TextNodeConfig t
+ = TextNodeConfig { _textNodeConfig_initialContents :: {-# UNPACK #-} !Text
+ , _textNodeConfig_setContents :: !(Maybe (Event t Text))
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+textNodeConfig_initialContents :: Lens' (TextNodeConfig t) Text
+textNodeConfig_initialContents f (TextNodeConfig a b) = (\a' -> TextNodeConfig a' b) <$> f a
+{-# INLINE textNodeConfig_initialContents #-}
+#endif
+
+instance (Reflex t) => Default (TextNodeConfig t) where
+ {-# INLINABLE def #-}
+ def = TextNodeConfig
+ { _textNodeConfig_initialContents = mempty
+ , _textNodeConfig_setContents = Nothing
+ }
+
+newtype TextNode d t = TextNode
+ { _textNode_raw :: RawTextNode d
+ }
+
+data AttributeName = AttributeName !(Maybe Namespace) !Text deriving (Show, Read, Eq, Ord)
+
+mapKeysToAttributeName :: Map Text v -> Map AttributeName v
+mapKeysToAttributeName = Map.mapKeysMonotonic (AttributeName Nothing)
+
+-- | By default, AttributeNames are unnamespaced
+instance IsString AttributeName where
+ fromString = AttributeName Nothing . fromString
+
+data Propagation
+ = Propagation_Continue
+ | Propagation_Stop
+ | Propagation_StopImmediate
+ deriving (Show, Read, Eq, Ord)
+
+instance Semigroup Propagation where
+ {-# INLINABLE (<>) #-}
+ (<>) = max
+
+instance Monoid Propagation where
+ {-# INLINABLE mempty #-}
+ mempty = Propagation_Continue
+ {-# INLINABLE mappend #-}
+ mappend = (<>)
+
+data EventFlags = EventFlags --TODO: Monoid; ways of building each flag
+ { _eventFlags_propagation :: Propagation
+ , _eventFlags_preventDefault :: Bool
+ }
+
+instance Semigroup EventFlags where
+ {-# INLINABLE (<>) #-}
+ EventFlags p pd <> EventFlags p' pd' = EventFlags (p <> p') (pd || pd')
+
+instance Monoid EventFlags where
+ {-# INLINABLE mempty #-}
+ mempty = EventFlags Propagation_Continue False
+ {-# INLINABLE mappend #-}
+ mappend = (<>)
+
+preventDefault :: EventFlags
+preventDefault = mempty { _eventFlags_preventDefault = True }
+
+stopPropagation :: EventFlags
+stopPropagation = mempty { _eventFlags_propagation = Propagation_Stop }
+
+data ElementConfig er t s
+ = ElementConfig { _elementConfig_namespace :: Maybe Namespace
+ , _elementConfig_initialAttributes :: Map AttributeName Text
+ , _elementConfig_modifyAttributes :: Maybe (Event t (Map AttributeName (Maybe Text)))
+ , _elementConfig_eventSpec :: EventSpec s er
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+elementConfig_namespace :: Lens' (ElementConfig er t s) (Maybe Namespace)
+elementConfig_namespace f (ElementConfig a b c d) = (\a' -> ElementConfig a' b c d) <$> f a
+{-# INLINE elementConfig_namespace #-}
+elementConfig_initialAttributes :: Lens' (ElementConfig er t s) (Map AttributeName Text)
+elementConfig_initialAttributes f (ElementConfig a b c d) = (\b' -> ElementConfig a b' c d) <$> f b
+{-# INLINE elementConfig_initialAttributes #-}
+elementConfig_eventSpec :: Lens
+ (ElementConfig er1 t s1)
+ (ElementConfig er2 t s2)
+ (EventSpec s1 er1)
+ (EventSpec s2 er2)
+elementConfig_eventSpec f (ElementConfig a b c d) = (\d' -> ElementConfig a b c d') <$> f d
+{-# INLINE elementConfig_eventSpec #-}
+#endif
+
+data Element er d t
+ = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments
+ , _element_raw :: RawElement d
+ }
+
+data InputElementConfig er t s
+ = InputElementConfig { _inputElementConfig_initialValue :: Text
+ , _inputElementConfig_setValue :: Maybe (Event t Text)
+ , _inputElementConfig_initialChecked :: Bool
+ , _inputElementConfig_setChecked :: Maybe (Event t Bool)
+ , _inputElementConfig_elementConfig :: ElementConfig er t s
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+inputElementConfig_initialValue :: Lens' (InputElementConfig er t m) Text
+inputElementConfig_initialValue f (InputElementConfig a b c d e) = (\a' -> InputElementConfig a' b c d e) <$> f a
+{-# INLINE inputElementConfig_initialValue #-}
+inputElementConfig_initialChecked :: Lens' (InputElementConfig er t m) Bool
+inputElementConfig_initialChecked f (InputElementConfig a b c d e) = (\c' -> InputElementConfig a b c' d e) <$> f c
+{-# INLINE inputElementConfig_initialChecked #-}
+inputElementConfig_elementConfig :: Lens
+ (InputElementConfig er1 t m1)
+ (InputElementConfig er2 t m2)
+ (ElementConfig er1 t m1)
+ (ElementConfig er2 t m2)
+inputElementConfig_elementConfig f (InputElementConfig a b c d e) = (\e' -> InputElementConfig a b c d e') <$> f e
+{-# INLINE inputElementConfig_elementConfig #-}
+#endif
+
+instance (Reflex t, er ~ EventResult, DomSpace s) => Default (InputElementConfig er t s) where
+ {-# INLINABLE def #-}
+ def = InputElementConfig
+ { _inputElementConfig_initialValue = ""
+ , _inputElementConfig_setValue = Nothing
+ , _inputElementConfig_initialChecked = False
+ , _inputElementConfig_setChecked = Nothing
+ , _inputElementConfig_elementConfig = def
+ }
+
+data InputElement er d t
+ = InputElement { _inputElement_value :: Dynamic t Text
+ , _inputElement_checked :: Dynamic t Bool
+ , _inputElement_checkedChange :: Event t Bool
+ , _inputElement_input :: Event t Text
+ , _inputElement_hasFocus :: Dynamic t Bool
+ , _inputElement_element :: Element er d t
+ , _inputElement_raw :: RawInputElement d
+ , _inputElement_files :: Dynamic t [RawFile d]
+ }
+
+data TextAreaElementConfig er t m
+ = TextAreaElementConfig { _textAreaElementConfig_initialValue :: Text
+ , _textAreaElementConfig_setValue :: Maybe (Event t Text)
+ , _textAreaElementConfig_elementConfig :: ElementConfig er t m
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+textAreaElementConfig_initialValue :: Lens' (TextAreaElementConfig er t m) Text
+textAreaElementConfig_initialValue f (TextAreaElementConfig a b c) = (\a' -> TextAreaElementConfig a' b c) <$> f a
+{-# INLINE textAreaElementConfig_initialValue #-}
+textAreaElementConfig_elementConfig :: Lens
+ (TextAreaElementConfig er1 t m1)
+ (TextAreaElementConfig er2 t m2)
+ (ElementConfig er1 t m1)
+ (ElementConfig er2 t m2)
+textAreaElementConfig_elementConfig f (TextAreaElementConfig a b c) = (\c' -> TextAreaElementConfig a b c') <$> f c
+{-# INLINE textAreaElementConfig_elementConfig #-}
+#endif
+
+instance (Reflex t, er ~ EventResult, DomSpace s) => Default (TextAreaElementConfig er t s) where
+ {-# INLINABLE def #-}
+ def = TextAreaElementConfig
+ { _textAreaElementConfig_initialValue = ""
+ , _textAreaElementConfig_setValue = Nothing
+ , _textAreaElementConfig_elementConfig = def
+ }
+
+data TextAreaElement er d t
+ = TextAreaElement { _textAreaElement_value :: Dynamic t Text
+ , _textAreaElement_input :: Event t Text
+ , _textAreaElement_hasFocus :: Dynamic t Bool
+ , _textAreaElement_element :: Element er d t
+ , _textAreaElement_raw :: RawTextAreaElement d
+ }
+
+extractRawElementConfig :: ElementConfig er t m -> RawElementConfig er t m
+extractRawElementConfig cfg = RawElementConfig
+ { _rawElementConfig_modifyAttributes = _elementConfig_modifyAttributes cfg
+ , _rawElementConfig_eventSpec = _elementConfig_eventSpec cfg
+ }
+
+data RawElementConfig er t s = RawElementConfig
+ { _rawElementConfig_modifyAttributes :: Maybe (Event t (Map AttributeName (Maybe Text)))
+ , _rawElementConfig_eventSpec :: EventSpec s er
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+rawElementConfig_eventSpec :: Lens
+ (RawElementConfig er1 t s1)
+ (RawElementConfig er2 t s2)
+ (EventSpec s1 er1)
+ (EventSpec s2 er2)
+rawElementConfig_eventSpec f (RawElementConfig a b) = (\b' -> RawElementConfig a b') <$> f b
+{-# INLINE rawElementConfig_eventSpec #-}
+#endif
+
+instance (Reflex t, er ~ EventResult, DomSpace s) => Default (RawElementConfig er t s) where
+ def = RawElementConfig
+ { _rawElementConfig_modifyAttributes = Nothing
+ , _rawElementConfig_eventSpec = def
+ }
+
+data SelectElementConfig er t m = SelectElementConfig
+ { _selectElementConfig_initialValue :: Text
+ , _selectElementConfig_setValue :: Maybe (Event t Text)
+ , _selectElementConfig_elementConfig :: ElementConfig er t m
+ }
+
+#ifndef USE_TEMPLATE_HASKELL
+selectElementConfig_initialValue :: Lens' (SelectElementConfig er t m) Text
+selectElementConfig_initialValue f (SelectElementConfig a b c) = (\a' -> SelectElementConfig a' b c) <$> f a
+{-# INLINE selectElementConfig_initialValue #-}
+selectElementConfig_elementConfig :: Lens
+ (SelectElementConfig er1 t m1)
+ (SelectElementConfig er2 t m2)
+ (ElementConfig er1 t m1)
+ (ElementConfig er2 t m2)
+selectElementConfig_elementConfig f (SelectElementConfig a b c) = (\c' -> SelectElementConfig a b c') <$> f c
+{-# INLINE selectElementConfig_elementConfig #-}
+#endif
+
+instance (Reflex t, er ~ EventResult, DomSpace s) => Default (SelectElementConfig er t s) where
+ def = SelectElementConfig
+ { _selectElementConfig_initialValue = ""
+ , _selectElementConfig_setValue = Nothing
+ , _selectElementConfig_elementConfig = def
+ }
+
+data SelectElement er d t = SelectElement
+ { _selectElement_element :: Element er d t
+ , _selectElement_value :: Dynamic t Text
+ , _selectElement_change :: Event t Text -- ^ Fires when the value is changed by the user, but not when it is set by setValue
+ , _selectElement_hasFocus :: Dynamic t Bool
+ , _selectElement_raw :: RawSelectElement d
+ }
+
+#ifdef USE_TEMPLATE_HASKELL
+concat <$> mapM (uncurry makeLensesWithoutField)
+ [ (["_textNodeConfig_setContents"], ''TextNodeConfig)
+ , ([ "_inputElementConfig_setValue"
+ , "_inputElementConfig_setChecked" ], ''InputElementConfig)
+ , (["_rawElementConfig_modifyAttributes"], ''RawElementConfig)
+ , (["_elementConfig_modifyAttributes"], ''ElementConfig)
+ , (["_textAreaElementConfig_setValue"], ''TextAreaElementConfig)
+ , (["_selectElementConfig_setValue"], ''SelectElementConfig)
+ ]
+#endif
+
+-- | This lens is technically illegal. The implementation of 'TextNodeConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'TextNodeConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+textNodeConfig_setContents :: Reflex t => Lens' (TextNodeConfig t) (Event t Text)
+textNodeConfig_setContents =
+ let getter = fromMaybe never . _textNodeConfig_setContents
+ setter t e = t { _textNodeConfig_setContents = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'InputElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'InputElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+inputElementConfig_setValue :: Reflex t => Lens' (InputElementConfig er t m) (Event t Text)
+inputElementConfig_setValue =
+ let getter = fromMaybe never . _inputElementConfig_setValue
+ setter t e = t { _inputElementConfig_setValue = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'InputElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'InputElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+inputElementConfig_setChecked :: Reflex t => Lens' (InputElementConfig er t m) (Event t Bool)
+inputElementConfig_setChecked =
+ let getter = fromMaybe never . _inputElementConfig_setChecked
+ setter t e = t { _inputElementConfig_setChecked = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'RawElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'RawElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+rawElementConfig_modifyAttributes :: Reflex t => Lens' (RawElementConfig er t m) (Event t (Map AttributeName (Maybe Text)))
+rawElementConfig_modifyAttributes =
+ let getter = fromMaybe never . _rawElementConfig_modifyAttributes
+ setter t e = t { _rawElementConfig_modifyAttributes = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'RawElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'RawElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+elementConfig_modifyAttributes :: Reflex t => Lens' (ElementConfig er t m) (Event t (Map AttributeName (Maybe Text)))
+elementConfig_modifyAttributes =
+ let getter = fromMaybe never . _elementConfig_modifyAttributes
+ setter t e = t { _elementConfig_modifyAttributes = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'TextAreaElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'TextAreaElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+textAreaElementConfig_setValue :: Reflex t => Lens' (TextAreaElementConfig er t m) (Event t Text)
+textAreaElementConfig_setValue =
+ let getter = fromMaybe never . _textAreaElementConfig_setValue
+ setter t e = t { _textAreaElementConfig_setValue = Just e }
+ in lens getter setter
+
+-- | This lens is technically illegal. The implementation of 'SelectElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'SelectElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.
+selectElementConfig_setValue :: Reflex t => Lens' (SelectElementConfig er t m) (Event t Text)
+selectElementConfig_setValue =
+ let getter = fromMaybe never . _selectElementConfig_setValue
+ setter t e = t { _selectElementConfig_setValue = Just e }
+ in lens getter setter
+
+class InitialAttributes a where
+ initialAttributes :: Lens' a (Map AttributeName Text)
+
+instance InitialAttributes (ElementConfig er t m) where
+ {-# INLINABLE initialAttributes #-}
+ initialAttributes = elementConfig_initialAttributes
+
+instance InitialAttributes (InputElementConfig er t m) where
+ {-# INLINABLE initialAttributes #-}
+ initialAttributes = inputElementConfig_elementConfig . elementConfig_initialAttributes
+
+instance InitialAttributes (TextAreaElementConfig er t m) where
+ {-# INLINABLE initialAttributes #-}
+ initialAttributes = textAreaElementConfig_elementConfig . elementConfig_initialAttributes
+
+instance InitialAttributes (SelectElementConfig er t m) where
+ {-# INLINABLE initialAttributes #-}
+ initialAttributes = selectElementConfig_elementConfig . elementConfig_initialAttributes
+
+class ModifyAttributes t a | a -> t where
+ modifyAttributes :: Reflex t => Lens' a (Event t (Map AttributeName (Maybe Text)))
+
+instance ModifyAttributes t (ElementConfig er t m) where
+ {-# INLINABLE modifyAttributes #-}
+ modifyAttributes = elementConfig_modifyAttributes
+
+instance ModifyAttributes t (InputElementConfig er t m) where
+ {-# INLINABLE modifyAttributes #-}
+ modifyAttributes = inputElementConfig_elementConfig . elementConfig_modifyAttributes
+
+instance ModifyAttributes t (TextAreaElementConfig er t m) where
+ {-# INLINABLE modifyAttributes #-}
+ modifyAttributes = textAreaElementConfig_elementConfig . elementConfig_modifyAttributes
+
+instance ModifyAttributes t (SelectElementConfig er t m) where
+ {-# INLINABLE modifyAttributes #-}
+ modifyAttributes = selectElementConfig_elementConfig . elementConfig_modifyAttributes
+
+instance ModifyAttributes t (RawElementConfig er t m) where
+ {-# INLINABLE modifyAttributes #-}
+ modifyAttributes = rawElementConfig_modifyAttributes
+
+class HasNamespace a where
+ namespace :: Lens' a (Maybe Namespace)
+
+instance HasNamespace (ElementConfig er t m) where
+ {-# INLINABLE namespace #-}
+ namespace = elementConfig_namespace
+
+instance (Reflex t, er ~ EventResult, DomSpace s) => Default (ElementConfig er t s) where
+ {-# INLINABLE def #-}
+ def = ElementConfig
+ { _elementConfig_namespace = Nothing
+ , _elementConfig_initialAttributes = mempty
+ , _elementConfig_modifyAttributes = Nothing
+ , _elementConfig_eventSpec = def
+ }
+
+instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where
+ type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
+ wrapRawElement e = lift . wrapRawElement e
+
+instance (MountableDomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => MountableDomBuilder t (PostBuildT t m) where
+ type DomFragment (PostBuildT t m) = DomFragment m
+ buildDomFragment = liftThrough buildDomFragment
+ mountDomFragment f0 f' = lift $ mountDomFragment f0 f'
+
+instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
+ type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
+ textNode = liftTextNode
+ element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do
+ s <- get
+ (el, (a, newS)) <- lift $ element elementTag cfg $ runStateT child s
+ put newS
+ return (el, a)
+ inputElement = lift . inputElement
+ textAreaElement = lift . textAreaElement
+ selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do
+ s <- get
+ (el, (a, newS)) <- lift $ selectElement cfg $ runStateT child s
+ put newS
+ return (el, a)
+ placeRawElement = lift . placeRawElement
+ wrapRawElement e = lift . wrapRawElement e
+
+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT t request response m) where
+ type DomBuilderSpace (RequesterT t request response m) = DomBuilderSpace m
+ textNode = liftTextNode
+ element elementTag cfg (RequesterT child) = RequesterT $ do
+ r <- ask
+ old <- get
+ (el, (a, new)) <- lift $ lift $ element elementTag cfg $ runReaderT (runStateT child old) r
+ put new
+ return (el, a)
+ inputElement = lift . inputElement
+ textAreaElement = lift . textAreaElement
+ selectElement cfg (RequesterT child) = RequesterT $ do
+ r <- ask
+ old <- get
+ (el, (a, new)) <- lift $ lift $ selectElement cfg $ runReaderT (runStateT child old) r
+ put new
+ return (el, a)
+ placeRawElement = lift . placeRawElement
+ wrapRawElement e = lift . wrapRawElement e
+
+instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => DomBuilder t (EventWriterT t w m) where
+ type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m
+ textNode = liftTextNode
+ element elementTag cfg (EventWriterT child) = EventWriterT $ do
+ old <- get
+ (el, (a, new)) <- lift $ element elementTag cfg $ runStateT child old
+ put new
+ return (el, a)
+ inputElement = lift . inputElement
+ textAreaElement = lift . textAreaElement
+ selectElement cfg (EventWriterT child) = EventWriterT $ do
+ old <- get
+ (el, (a, new)) <- lift $ selectElement cfg $ runStateT child old
+ put new
+ return (el, a)
+ placeRawElement = lift . placeRawElement
+ wrapRawElement e = lift . wrapRawElement e
+
+instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive q) => DomBuilder t (QueryT t q m) where
+ type DomBuilderSpace (QueryT t q m) = DomBuilderSpace m
+ textNode = liftTextNode
+ element elementTag cfg (QueryT child) = QueryT $ do
+ s <- get
+ (e, (a, newS)) <- lift $ element elementTag cfg $ runStateT child s
+ put newS
+ return (e, a)
+ inputElement = lift . inputElement
+ textAreaElement = lift . textAreaElement
+ selectElement cfg (QueryT child) = QueryT $ do
+ s <- get
+ (e, (a, newS)) <- lift $ selectElement cfg $ runStateT child s
+ put newS
+ return (e, a)
+ placeRawElement = lift . placeRawElement
+ wrapRawElement e = lift . wrapRawElement e
+
+-- * Convenience functions
+
+class HasDomEvent t target eventName where
+ type DomEventType target eventName :: *
+ domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
+
+instance Reflex t => HasDomEvent t (Element EventResult d t) en where
+ type DomEventType (Element EventResult d t) en = EventResultType en
+ {-# INLINABLE domEvent #-}
+ domEvent en e = coerceEvent $ Reflex.select (_element_events e) (WrapArg en)
+
+instance Reflex t => HasDomEvent t (InputElement EventResult d t) en where
+ type DomEventType (InputElement EventResult d t) en = EventResultType en
+ {-# INLINABLE domEvent #-}
+ domEvent en = domEvent en . _inputElement_element
+
+instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where
+ type DomEventType (TextAreaElement EventResult d t) en = EventResultType en
+ {-# INLINABLE domEvent #-}
+ domEvent en = domEvent en . _textAreaElement_element
+
+instance DomBuilder t m => DomBuilder t (ReaderT r m) where
+ type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m
+
+type LiftDomBuilder t f m =
+ ( Reflex t
+ , MonadTransControlStateless f
+ , Monad m
+ , DomBuilder t m
+ , DomBuilderSpace (f m) ~ DomBuilderSpace m
+ )
+
+class MonadTransControl t => MonadTransControlStateless t where
+ stTCoercion :: proxy t -> Coercion (StT t a) a
+ default stTCoercion :: (a ~ StT t a) => proxy t -> Coercion (StT t a) a
+ stTCoercion _ = Control.Category.id
+
+toStT :: MonadTransControlStateless t => proxy t -> a -> StT t a
+toStT = coerceWith . sym . stTCoercion
+
+fromStT :: MonadTransControlStateless t => proxy t -> StT t a -> a
+fromStT = coerceWith . stTCoercion
+
+instance MonadTransControlStateless (ReaderT r)
+
+type RunStateless t = forall n b. Monad n => t n b -> n b
+
+liftWithStateless :: forall m t a. (Monad m, MonadTransControlStateless t) => (RunStateless t -> m a) -> t m a
+liftWithStateless a = liftWith $ \run -> a $ fmap (fromStT (Proxy :: Proxy t)) . run
+
+liftTextNode :: (MonadTrans f, DomBuilder t m) => TextNodeConfig t -> f m (TextNode (DomBuilderSpace m) t)
+liftTextNode = lift . textNode
+
+liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (DomBuilderSpace m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)
+liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag cfg $ run child
+
+class (Reflex t, Monad m) => DomRenderHook t m | m -> t where
+ withRenderHook :: (forall x. JSM x -> JSM x) -> m a -> m a
+ requestDomAction :: Event t (JSM a) -> m (Event t a)
+ requestDomAction_ :: Event t (JSM a) -> m ()
+
+instance DomRenderHook t m => DomRenderHook t (ReaderT e m) where
+ withRenderHook hook (ReaderT a) = ReaderT $ \e -> withRenderHook hook $ a e
+ requestDomAction = lift . requestDomAction
+ requestDomAction_ = lift . requestDomAction_
+
+instance DomRenderHook t m => DomRenderHook t (StateT e m) where
+ withRenderHook hook (StateT a) = StateT $ \s -> withRenderHook hook $ a s
+ requestDomAction = lift . requestDomAction
+ requestDomAction_ = lift . requestDomAction_
+
+instance DomRenderHook t m => DomRenderHook t (Lazy.StateT e m) where
+ withRenderHook hook (Lazy.StateT a) = Lazy.StateT $ \s -> withRenderHook hook $ a s
+ requestDomAction = lift . requestDomAction
+ requestDomAction_ = lift . requestDomAction_
+
+deriving instance DomRenderHook t m => DomRenderHook t (EventWriterT t w m)
+deriving instance DomRenderHook t m => DomRenderHook t (RequesterT t req rsp m)
+deriving instance DomRenderHook t m => DomRenderHook t (PostBuildT t m)
+deriving instance DomRenderHook t m => DomRenderHook t (QueryT t q m)
+
+{-# DEPRECATED liftElementConfig "Use 'id' instead; this function is no longer necessary" #-}
+liftElementConfig :: ElementConfig er t s -> ElementConfig er t s
+liftElementConfig = id
+
+class Monad m => HasDocument m where
+ askDocument :: m (RawDocument (DomBuilderSpace m))
+ default askDocument
+ :: ( m ~ f m'
+ , RawDocument (DomBuilderSpace m) ~ RawDocument (DomBuilderSpace m')
+ , MonadTrans f
+ , Monad m'
+ , HasDocument m'
+ )
+ => m (RawDocument (DomBuilderSpace m))
+ askDocument = lift askDocument
+
+instance HasDocument m => HasDocument (ReaderT r m)
+instance HasDocument m => HasDocument (EventWriterT t w m)
+instance HasDocument m => HasDocument (DynamicWriterT t w m)
+instance HasDocument m => HasDocument (PostBuildT t m)
+instance HasDocument m => HasDocument (RequesterT t request response m)
+instance HasDocument m => HasDocument (QueryT t q m)
diff --git a/src/Reflex/Dom/Builder/Class/Events.hs b/src/Reflex/Dom/Builder/Class/Events.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/Class/Events.hs
@@ -0,0 +1,377 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+{-# LANGUAGE TypeFamilies #-}
+module Reflex.Dom.Builder.Class.Events where
+
+#ifdef USE_TEMPLATE_HASKELL
+import Data.GADT.Compare.TH
+#else
+import Data.GADT.Compare
+ (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))
+#endif
+
+data EventTag
+ = AbortTag
+ | BlurTag
+ | ChangeTag
+ | ClickTag
+ | ContextmenuTag
+ | DblclickTag
+ | DragTag
+ | DragendTag
+ | DragenterTag
+ | DragleaveTag
+ | DragoverTag
+ | DragstartTag
+ | DropTag
+ | ErrorTag
+ | FocusTag
+ | InputTag
+ | InvalidTag
+ | KeydownTag
+ | KeypressTag
+ | KeyupTag
+ | LoadTag
+ | MousedownTag
+ | MouseenterTag
+ | MouseleaveTag
+ | MousemoveTag
+ | MouseoutTag
+ | MouseoverTag
+ | MouseupTag
+ | MousewheelTag
+ | ScrollTag
+ | SelectTag
+ | SubmitTag
+ | WheelTag
+ | BeforecutTag
+ | CutTag
+ | BeforecopyTag
+ | CopyTag
+ | BeforepasteTag
+ | PasteTag
+ | ResetTag
+ | SearchTag
+ | SelectstartTag
+ | TouchstartTag
+ | TouchmoveTag
+ | TouchendTag
+ | TouchcancelTag
+
+data EventName :: EventTag -> * where
+ Abort :: EventName 'AbortTag
+ Blur :: EventName 'BlurTag
+ Change :: EventName 'ChangeTag
+ Click :: EventName 'ClickTag
+ Contextmenu :: EventName 'ContextmenuTag
+ Dblclick :: EventName 'DblclickTag
+ Drag :: EventName 'DragTag
+ Dragend :: EventName 'DragendTag
+ Dragenter :: EventName 'DragenterTag
+ Dragleave :: EventName 'DragleaveTag
+ Dragover :: EventName 'DragoverTag
+ Dragstart :: EventName 'DragstartTag
+ Drop :: EventName 'DropTag
+ Error :: EventName 'ErrorTag
+ Focus :: EventName 'FocusTag
+ Input :: EventName 'InputTag
+ Invalid :: EventName 'InvalidTag
+ Keydown :: EventName 'KeydownTag
+ Keypress :: EventName 'KeypressTag
+ Keyup :: EventName 'KeyupTag
+ Load :: EventName 'LoadTag
+ Mousedown :: EventName 'MousedownTag
+ Mouseenter :: EventName 'MouseenterTag
+ Mouseleave :: EventName 'MouseleaveTag
+ Mousemove :: EventName 'MousemoveTag
+ Mouseout :: EventName 'MouseoutTag
+ Mouseover :: EventName 'MouseoverTag
+ Mouseup :: EventName 'MouseupTag
+ Mousewheel :: EventName 'MousewheelTag
+ Scroll :: EventName 'ScrollTag
+ Select :: EventName 'SelectTag
+ Submit :: EventName 'SubmitTag
+ Wheel :: EventName 'WheelTag
+ Beforecut :: EventName 'BeforecutTag
+ Cut :: EventName 'CutTag
+ Beforecopy :: EventName 'BeforecopyTag
+ Copy :: EventName 'CopyTag
+ Beforepaste :: EventName 'BeforepasteTag
+ Paste :: EventName 'PasteTag
+ Reset :: EventName 'ResetTag
+ Search :: EventName 'SearchTag
+ Selectstart :: EventName 'SelectstartTag
+ Touchstart :: EventName 'TouchstartTag
+ Touchmove :: EventName 'TouchmoveTag
+ Touchend :: EventName 'TouchendTag
+ Touchcancel :: EventName 'TouchcancelTag
+
+newtype EventResult en = EventResult { unEventResult :: EventResultType en }
+
+type family EventResultType (en :: EventTag) :: * where
+ EventResultType 'ClickTag = ()
+ EventResultType 'DblclickTag = (Int, Int)
+ EventResultType 'KeypressTag = Word
+ EventResultType 'KeydownTag = Word
+ EventResultType 'KeyupTag = Word
+ EventResultType 'ScrollTag = Double
+ EventResultType 'MousemoveTag = (Int, Int)
+ EventResultType 'MousedownTag = (Int, Int)
+ EventResultType 'MouseupTag = (Int, Int)
+ EventResultType 'MouseenterTag = ()
+ EventResultType 'MouseleaveTag = ()
+ EventResultType 'FocusTag = ()
+ EventResultType 'BlurTag = ()
+ EventResultType 'ChangeTag = ()
+ EventResultType 'DragTag = ()
+ EventResultType 'DragendTag = ()
+ EventResultType 'DragenterTag = ()
+ EventResultType 'DragleaveTag = ()
+ EventResultType 'DragoverTag = ()
+ EventResultType 'DragstartTag = ()
+ EventResultType 'DropTag = ()
+ EventResultType 'AbortTag = ()
+ EventResultType 'ContextmenuTag = ()
+ EventResultType 'ErrorTag = ()
+ EventResultType 'InputTag = ()
+ EventResultType 'InvalidTag = ()
+ EventResultType 'LoadTag = ()
+ EventResultType 'MouseoutTag = ()
+ EventResultType 'MouseoverTag = ()
+ EventResultType 'MousewheelTag = ()
+ EventResultType 'SelectTag = ()
+ EventResultType 'SubmitTag = ()
+ EventResultType 'BeforecutTag = ()
+ EventResultType 'CutTag = ()
+ EventResultType 'BeforecopyTag = ()
+ EventResultType 'CopyTag = ()
+ EventResultType 'BeforepasteTag = ()
+ EventResultType 'PasteTag = ()
+ EventResultType 'ResetTag = ()
+ EventResultType 'SearchTag = ()
+ EventResultType 'SelectstartTag = ()
+ EventResultType 'TouchstartTag = TouchEventResult
+ EventResultType 'TouchmoveTag = TouchEventResult
+ EventResultType 'TouchendTag = TouchEventResult
+ EventResultType 'TouchcancelTag = TouchEventResult
+ EventResultType 'WheelTag = ()
+
+data TouchEventResult = TouchEventResult
+ { _touchEventResult_altKey :: Bool
+ , _touchEventResult_changedTouches :: [TouchResult]
+ , _touchEventResult_ctrlKey :: Bool
+ , _touchEventResult_metaKey :: Bool
+ , _touchEventResult_shiftKey :: Bool
+ , _touchEventResult_targetTouches :: [TouchResult]
+ , _touchEventResult_touches :: [TouchResult]
+ }
+ deriving (Show, Read, Eq, Ord)
+
+data TouchResult = TouchResult
+ { _touchResult_identifier :: Word
+ , _touchResult_screenX :: Int
+ , _touchResult_screenY :: Int
+ , _touchResult_clientX :: Int
+ , _touchResult_clientY :: Int
+ , _touchResult_pageX :: Int
+ , _touchResult_pageY :: Int
+ }
+ deriving (Show, Read, Eq, Ord)
+
+#ifdef USE_TEMPLATE_HASKELL
+deriveGEq ''EventName
+deriveGCompare ''EventName
+#else
+instance GEq EventName
+ where geq Abort Abort = return Refl
+ geq Blur Blur = return Refl
+ geq Change Change = return Refl
+ geq Click Click = return Refl
+ geq Contextmenu Contextmenu = return Refl
+ geq Dblclick Dblclick = return Refl
+ geq Drag Drag = return Refl
+ geq Dragend Dragend = return Refl
+ geq Dragenter Dragenter = return Refl
+ geq Dragleave Dragleave = return Refl
+ geq Dragover Dragover = return Refl
+ geq Dragstart Dragstart = return Refl
+ geq Drop Drop = return Refl
+ geq Error Error = return Refl
+ geq Focus Focus = return Refl
+ geq Input Input = return Refl
+ geq Invalid Invalid = return Refl
+ geq Keydown Keydown = return Refl
+ geq Keypress Keypress = return Refl
+ geq Keyup Keyup = return Refl
+ geq Load Load = return Refl
+ geq Mousedown Mousedown = return Refl
+ geq Mouseenter Mouseenter = return Refl
+ geq Mouseleave Mouseleave = return Refl
+ geq Mousemove Mousemove = return Refl
+ geq Mouseout Mouseout = return Refl
+ geq Mouseover Mouseover = return Refl
+ geq Mouseup Mouseup = return Refl
+ geq Mousewheel Mousewheel = return Refl
+ geq Scroll Scroll = return Refl
+ geq Select Select = return Refl
+ geq Submit Submit = return Refl
+ geq Wheel Wheel = return Refl
+ geq Beforecut Beforecut = return Refl
+ geq Cut Cut = return Refl
+ geq Beforecopy Beforecopy = return Refl
+ geq Copy Copy = return Refl
+ geq Beforepaste Beforepaste = return Refl
+ geq Paste Paste = return Refl
+ geq Reset Reset = return Refl
+ geq Search Search = return Refl
+ geq Selectstart Selectstart = return Refl
+ geq Touchstart Touchstart = return Refl
+ geq Touchmove Touchmove = return Refl
+ geq Touchend Touchend = return Refl
+ geq Touchcancel Touchcancel = return Refl
+ geq _ _ = Nothing
+
+instance GCompare EventName
+ where gcompare Abort Abort = GEQ
+ gcompare Abort _ = GLT
+ gcompare _ Abort = GGT
+ gcompare Blur Blur = GEQ
+ gcompare Blur _ = GLT
+ gcompare _ Blur = GGT
+ gcompare Change Change = GEQ
+ gcompare Change _ = GLT
+ gcompare _ Change = GGT
+ gcompare Click Click = GEQ
+ gcompare Click _ = GLT
+ gcompare _ Click = GGT
+ gcompare Contextmenu Contextmenu = GEQ
+ gcompare Contextmenu _ = GLT
+ gcompare _ Contextmenu = GGT
+ gcompare Dblclick Dblclick = GEQ
+ gcompare Dblclick _ = GLT
+ gcompare _ Dblclick = GGT
+ gcompare Drag Drag = GEQ
+ gcompare Drag _ = GLT
+ gcompare _ Drag = GGT
+ gcompare Dragend Dragend = GEQ
+ gcompare Dragend _ = GLT
+ gcompare _ Dragend = GGT
+ gcompare Dragenter Dragenter = GEQ
+ gcompare Dragenter _ = GLT
+ gcompare _ Dragenter = GGT
+ gcompare Dragleave Dragleave = GEQ
+ gcompare Dragleave _ = GLT
+ gcompare _ Dragleave = GGT
+ gcompare Dragover Dragover = GEQ
+ gcompare Dragover _ = GLT
+ gcompare _ Dragover = GGT
+ gcompare Dragstart Dragstart = GEQ
+ gcompare Dragstart _ = GLT
+ gcompare _ Dragstart = GGT
+ gcompare Drop Drop = GEQ
+ gcompare Drop _ = GLT
+ gcompare _ Drop = GGT
+ gcompare Error Error = GEQ
+ gcompare Error _ = GLT
+ gcompare _ Error = GGT
+ gcompare Focus Focus = GEQ
+ gcompare Focus _ = GLT
+ gcompare _ Focus = GGT
+ gcompare Input Input = GEQ
+ gcompare Input _ = GLT
+ gcompare _ Input = GGT
+ gcompare Invalid Invalid = GEQ
+ gcompare Invalid _ = GLT
+ gcompare _ Invalid = GGT
+ gcompare Keydown Keydown = GEQ
+ gcompare Keydown _ = GLT
+ gcompare _ Keydown = GGT
+ gcompare Keypress Keypress = GEQ
+ gcompare Keypress _ = GLT
+ gcompare _ Keypress = GGT
+ gcompare Keyup Keyup = GEQ
+ gcompare Keyup _ = GLT
+ gcompare _ Keyup = GGT
+ gcompare Load Load = GEQ
+ gcompare Load _ = GLT
+ gcompare _ Load = GGT
+ gcompare Mousedown Mousedown = GEQ
+ gcompare Mousedown _ = GLT
+ gcompare _ Mousedown = GGT
+ gcompare Mouseenter Mouseenter = GEQ
+ gcompare Mouseenter _ = GLT
+ gcompare _ Mouseenter = GGT
+ gcompare Mouseleave Mouseleave = GEQ
+ gcompare Mouseleave _ = GLT
+ gcompare _ Mouseleave = GGT
+ gcompare Mousemove Mousemove = GEQ
+ gcompare Mousemove _ = GLT
+ gcompare _ Mousemove = GGT
+ gcompare Mouseout Mouseout = GEQ
+ gcompare Mouseout _ = GLT
+ gcompare _ Mouseout = GGT
+ gcompare Mouseover Mouseover = GEQ
+ gcompare Mouseover _ = GLT
+ gcompare _ Mouseover = GGT
+ gcompare Mouseup Mouseup = GEQ
+ gcompare Mouseup _ = GLT
+ gcompare _ Mouseup = GGT
+ gcompare Mousewheel Mousewheel = GEQ
+ gcompare Mousewheel _ = GLT
+ gcompare _ Mousewheel = GGT
+ gcompare Scroll Scroll = GEQ
+ gcompare Scroll _ = GLT
+ gcompare _ Scroll = GGT
+ gcompare Select Select = GEQ
+ gcompare Select _ = GLT
+ gcompare _ Select = GGT
+ gcompare Submit Submit = GEQ
+ gcompare Submit _ = GLT
+ gcompare _ Submit = GGT
+ gcompare Wheel Wheel = GEQ
+ gcompare Wheel _ = GLT
+ gcompare _ Wheel = GGT
+ gcompare Beforecut Beforecut = GEQ
+ gcompare Beforecut _ = GLT
+ gcompare _ Beforecut = GGT
+ gcompare Cut Cut = GEQ
+ gcompare Cut _ = GLT
+ gcompare _ Cut = GGT
+ gcompare Beforecopy Beforecopy = GEQ
+ gcompare Beforecopy _ = GLT
+ gcompare _ Beforecopy = GGT
+ gcompare Copy Copy = GEQ
+ gcompare Copy _ = GLT
+ gcompare _ Copy = GGT
+ gcompare Beforepaste Beforepaste = GEQ
+ gcompare Beforepaste _ = GLT
+ gcompare _ Beforepaste = GGT
+ gcompare Paste Paste = GEQ
+ gcompare Paste _ = GLT
+ gcompare _ Paste = GGT
+ gcompare Reset Reset = GEQ
+ gcompare Reset _ = GLT
+ gcompare _ Reset = GGT
+ gcompare Search Search = GEQ
+ gcompare Search _ = GLT
+ gcompare _ Search = GGT
+ gcompare Selectstart Selectstart = GEQ
+ gcompare Selectstart _ = GLT
+ gcompare _ Selectstart = GGT
+ gcompare Touchstart Touchstart = GEQ
+ gcompare Touchstart _ = GLT
+ gcompare _ Touchstart = GGT
+ gcompare Touchmove Touchmove = GEQ
+ gcompare Touchmove _ = GLT
+ gcompare _ Touchmove = GGT
+ gcompare Touchend Touchend = GEQ
+ gcompare Touchend _ = GLT
+ gcompare _ Touchend = GGT
+ gcompare Touchcancel Touchcancel = GEQ
+#endif
diff --git a/src/Reflex/Dom/Builder/Class/TH.hs b/src/Reflex/Dom/Builder/Class/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/Class/TH.hs
@@ -0,0 +1,12 @@
+module Reflex.Dom.Builder.Class.TH where
+
+import Control.Lens
+import Language.Haskell.TH.Lib (DecsQ)
+import Language.Haskell.TH.Syntax (Name, nameBase)
+
+namer :: [String] -> Name -> [Name] -> Name -> [DefName]
+namer s n ks t | nameBase t `elem` s = []
+ | otherwise = underscoreNoPrefixNamer n ks t
+
+makeLensesWithoutField :: [String] -> Name -> DecsQ
+makeLensesWithoutField s = makeLensesWith (lensRules & lensField .~ namer s)
diff --git a/src/Reflex/Dom/Builder/Immediate.hs b/src/Reflex/Dom/Builder/Immediate.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/Immediate.hs
@@ -0,0 +1,1558 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+#ifdef ghcjs_HOST_OS
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE JavaScriptFFI #-}
+#endif
+module Reflex.Dom.Builder.Immediate
+ ( EventTriggerRef (..)
+ , ImmediateDomBuilderEnv (..)
+ , ImmediateDomBuilderT (..)
+ , runImmediateDomBuilderT
+ , askParent
+ , askEvents
+ , append
+ , textNodeInternal
+ , deleteBetweenExclusive
+ , extractBetweenExclusive
+ , deleteUpTo
+ , extractUpTo
+ , SupportsImmediateDomBuilder
+ , collectUpTo
+ , collectUpToGivenParent
+ , EventFilterTriggerRef (..)
+ , wrap
+ , makeElement
+ , GhcjsDomHandler (..)
+ , GhcjsDomHandler1 (..)
+ , GhcjsDomEvent (..)
+ , GhcjsDomSpace
+ , GhcjsEventFilter (..)
+ , Pair1 (..)
+ , Maybe1 (..)
+ , GhcjsEventSpec (..)
+ , HasDocument (..)
+ , ghcjsEventSpec_filters
+ , ghcjsEventSpec_handler
+ , GhcjsEventHandler (..)
+#ifndef USE_TEMPLATE_HASKELL
+ , phantom2
+#endif
+ , drawChildUpdate
+ , ChildReadyState (..)
+ , ChildReadyStateInt (..)
+ , mkHasFocus
+ , insertBefore
+ , EventType
+ , defaultDomEventHandler
+ , defaultDomWindowEventHandler
+ , withIsEvent
+ , showEventName
+ , elementOnEventName
+ , windowOnEventName
+ , wrapDomEvent
+ , subscribeDomEvent
+ , wrapDomEventMaybe
+ , wrapDomEventsMaybe
+ , getKeyEvent
+ , getMouseEventCoords
+ , getTouchEvent
+ , WindowConfig (..)
+ , Window (..)
+ , wrapWindow
+ -- * Internal
+ , traverseDMapWithKeyWithAdjust'
+ , hoistTraverseWithKeyWithAdjust
+ , traverseIntMapWithKeyWithAdjust'
+ , hoistTraverseIntMapWithKeyWithAdjust
+ ) where
+
+import Foreign.JavaScript.TH
+import Reflex.Adjustable.Class
+import Reflex.Class as Reflex
+import Reflex.Dom.Builder.Class
+import Reflex.Dynamic
+import Reflex.Host.Class
+import qualified Reflex.Patch.DMap as PatchDMap
+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+import Reflex.TriggerEvent.Base hiding (askEvents)
+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
+import Reflex.TriggerEvent.Class
+
+import Control.Concurrent
+import Control.Lens hiding (element, ix)
+import Control.Monad.Exception
+import Control.Monad.Primitive
+import Control.Monad.Reader
+import Control.Monad.Ref
+#ifndef USE_TEMPLATE_HASKELL
+import Data.Functor.Contravariant (phantom)
+#endif
+import Data.Bitraversable
+import Data.Default
+import Data.Dependent.Map (DMap)
+import qualified Data.Dependent.Map as DMap
+import Data.Dependent.Sum
+import Data.Functor.Compose
+import Data.Functor.Constant
+import Data.Functor.Misc
+import Data.Functor.Product
+import Data.IORef
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Monoid hiding (Product)
+import Data.Some (Some)
+import qualified Data.Some as Some
+import Data.Text (Text)
+import qualified GHCJS.DOM as DOM
+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
+import qualified GHCJS.DOM.Element as Element
+import qualified GHCJS.DOM.Event as Event
+import qualified GHCJS.DOM.GlobalEventHandlers as Events
+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
+import GHCJS.DOM.EventM (EventM, event, on)
+import qualified GHCJS.DOM.EventM as DOM
+import qualified GHCJS.DOM.FileList as FileList
+import qualified GHCJS.DOM.HTMLInputElement as Input
+import qualified GHCJS.DOM.HTMLSelectElement as Select
+import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
+import GHCJS.DOM.MouseEvent
+import qualified GHCJS.DOM.Touch as Touch
+import qualified GHCJS.DOM.TouchEvent as TouchEvent
+import qualified GHCJS.DOM.TouchList as TouchList
+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
+import qualified GHCJS.DOM.Node as DOM (insertBefore_)
+import GHCJS.DOM.Types
+ (liftJSM, askJSM, runJSM, JSM, MonadJSM,
+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
+ ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
+import qualified GHCJS.DOM.Types as DOM
+import GHCJS.DOM.UIEvent
+import GHCJS.DOM.KeyboardEvent as KeyboardEvent
+import qualified GHCJS.DOM.Window as Window
+import Language.Javascript.JSaddle (call, eval)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+import Data.FastMutableIntMap (PatchIntMap (..))
+import qualified Data.FastMutableIntMap as FastMutableIntMap
+
+import Reflex.Requester.Base
+import Reflex.Requester.Class
+import Foreign.JavaScript.Internal.Utils
+
+#ifndef ghcjs_HOST_OS
+import GHCJS.DOM.Types (MonadJSM (..))
+
+instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
+ liftJSM' = ImmediateDomBuilderT . liftJSM'
+#endif
+
+data ImmediateDomBuilderEnv t
+ = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
+ , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
+ , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
+ , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
+ }
+
+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
+#if MIN_VERSION_base(4,9,1)
+ , MonadAsyncException
+#endif
+ )
+
+instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
+ type PrimState (ImmediateDomBuilderT x m) = PrimState m
+ primitive = lift . primitive
+
+instance MonadTrans (ImmediateDomBuilderT t) where
+ lift = ImmediateDomBuilderT . lift . lift . lift
+
+instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where
+ withRenderHook hook (ImmediateDomBuilderT a) = do
+ e <- ImmediateDomBuilderT ask
+ ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
+ (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp
+ return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
+ requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
+ requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
+
+{-# INLINABLE runImmediateDomBuilderT #-}
+runImmediateDomBuilderT
+ :: ( MonadFix m
+ , PerformEvent t m
+ , MonadReflexCreateTrigger t m
+ , MonadJSM m
+ , MonadJSM (Performable m)
+ , MonadRef m
+ , Ref m ~ IORef
+ )
+ => ImmediateDomBuilderT t m a
+ -> ImmediateDomBuilderEnv t
+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
+ -> m a
+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =
+ flip runTriggerEventT eventChan $ do
+ rec (x, req) <- runRequesterT (runReaderT a env) rsp
+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
+ traverseRequesterData (\r -> Identity <$> r) rm
+ return x
+ where
+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
+ v <- synchronously x
+ void . liftIO $ f v
+
+instance Monad m => HasDocument (ImmediateDomBuilderT t m) where
+ {-# INLINABLE askDocument #-}
+ askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document
+
+{-# INLINABLE askParent #-}
+askParent :: Monad m => ImmediateDomBuilderT t m Node
+askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
+
+{-# INLINABLE askEvents #-}
+askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
+askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents
+
+localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
+localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
+
+{-# INLINABLE append #-}
+append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
+append n = do
+ p <- askParent
+ liftJSM $ appendChild_ p n
+ return ()
+
+{-# INLINABLE textNodeInternal #-}
+textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
+textNodeInternal !t = do
+ doc <- askDocument
+ n <- liftJSM $ createTextNode doc t
+ append $ toNode n
+ return n
+
+-- | s and e must both be children of the same node and s must precede e;
+-- all nodes between s and e will be removed, but s and e will not be removed
+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
+deleteBetweenExclusive s e = liftJSM $ do
+ df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
+ extractBetweenExclusive df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
+
+-- | s and e must both be children of the same node and s must precede e; all
+-- nodes between s and e will be moved into the given DocumentFragment, but s
+-- and e will not be moved
+extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
+extractBetweenExclusive df s e = liftJSM $ do
+ f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)
+ void $ call f f (df, s, e)
+
+-- | s and e must both be children of the same node and s must precede e;
+-- s and all nodes between s and e will be removed, but e will not be removed
+{-# INLINABLE deleteUpTo #-}
+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
+deleteUpTo s e = do
+ df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
+ extractUpTo df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
+
+extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
+#ifdef ghcjs_HOST_OS
+--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)
+foreign import javascript unsafe
+ "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"
+ extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()
+extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)
+#else
+extractUpTo df s e = liftJSM $ do
+ f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)
+ void $ call f f (df, s, e)
+#endif
+
+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, Adjustable t m, PrimMonad m)
+
+{-# INLINABLE collectUpTo #-}
+collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
+collectUpTo s e = do
+ currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
+ collectUpToGivenParent currentParent s e
+
+{-# INLINABLE collectUpToGivenParent #-}
+collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment
+collectUpToGivenParent currentParent s e = do
+ doc <- getOwnerDocumentUnchecked currentParent
+ df <- createDocumentFragment doc
+ extractUpTo df s e
+ return df
+
+newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
+
+{-# INLINABLE wrap #-}
+wrap :: forall m er t. (Reflex t, MonadFix m, MonadJSM m, MonadReflexCreateTrigger t m) => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
+wrap e cfg = do
+ events <- askEvents
+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
+ Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
+ Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
+ triggerRef <- liftIO $ newIORef Nothing
+ _ <- elementOnEventName en e $ do --TODO: Something safer than this cast
+ evt <- DOM.event
+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt
+ when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
+ case _eventFlags_propagation flags of
+ Propagation_Continue -> return ()
+ Propagation_Stop -> withIsEvent en DOM.stopPropagation
+ Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
+ mv <- liftJSM k --TODO: Only do this when the event is subscribed
+ liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
+ return $ en :=> EventFilterTriggerRef triggerRef
+ es <- do
+ let h :: GhcjsEventHandler er
+ !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
+ ctx <- askJSM
+ newFanEventWithTrigger $ \(WrapArg en) t ->
+ case DMap.lookup en eventTriggerRefs of
+ Just (EventFilterTriggerRef r) -> do
+ writeIORef r $ Just t
+ return $ do
+ writeIORef r Nothing
+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
+ evt <- DOM.event
+ mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
+ case mv of
+ Nothing -> return ()
+ Just v -> liftIO $ do
+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
+ ref <- newIORef $ Just t
+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
+ return $ Element
+ { _element_events = es
+ , _element_raw = e
+ }
+
+{-# INLINABLE makeElement #-}
+makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
+makeElement elementTag cfg child = do
+ doc <- askDocument
+ e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
+ Nothing -> createElement doc elementTag
+ Just ens -> createElementNS doc (Just ens) elementTag
+ ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
+ Nothing -> lift $ setAttribute e n v
+ Just ans -> lift $ setAttributeNS e (Just ans) n v
+ result <- flip localEnv child $ \env -> env
+ { _immediateDomBuilderEnv_parent = toNode e
+ }
+ append $ toNode e
+ wrapped <- wrap e $ extractRawElementConfig cfg
+ return ((wrapped, result), e)
+
+newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
+
+newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> JSM (b x) }
+
+newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
+
+data GhcjsDomSpace
+
+instance DomSpace GhcjsDomSpace where
+ type EventSpec GhcjsDomSpace = GhcjsEventSpec
+ type RawDocument GhcjsDomSpace = DOM.Document
+ type RawTextNode GhcjsDomSpace = DOM.Text
+ type RawElement GhcjsDomSpace = DOM.Element
+ type RawFile GhcjsDomSpace = DOM.File
+ type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
+ type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
+ type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
+ addEventSpecFlags _ en f es = es
+ { _ghcjsEventSpec_filters =
+ let f' = Just . GhcjsEventFilter . \case
+ Nothing -> \evt -> do
+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
+ return (f mEventResult, return mEventResult)
+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
+ (oldFlags, oldContinuation) <- oldFilter evt
+ mEventResult <- oldContinuation
+ let newFlags = oldFlags <> f mEventResult
+ return (newFlags, return mEventResult)
+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
+ }
+
+newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en))))
+
+data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
+
+data Maybe1 f a = Nothing1 | Just1 (f a)
+
+data GhcjsEventSpec er = GhcjsEventSpec
+ { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)
+ , _ghcjsEventSpec_handler :: GhcjsEventHandler er
+ }
+
+newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
+
+#ifndef USE_TEMPLATE_HASKELL
+phantom2 :: (Functor f, Contravariant f) => f a -> f b
+phantom2 = phantom
+{-# INLINE phantom2 #-}
+
+ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))
+ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
+{-# INLINE ghcjsEventSpec_filters #-}
+ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))
+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)
+{-# INLINE ghcjsEventSpec_handler #-}
+#endif
+
+instance er ~ EventResult => Default (GhcjsEventSpec er) where
+ def = GhcjsEventSpec
+ { _ghcjsEventSpec_filters = mempty
+ , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> do
+ t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
+ let e = uncheckedCastTo DOM.Element t
+ runReaderT (defaultDomEventHandler e en) evt
+ }
+
+instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where
+ notReadyUntil e = do
+ eOnce <- headE e
+ env <- ImmediateDomBuilderT ask
+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
+ liftIO $ modifyIORef' unreadyChildren succ
+ let ready = do
+ old <- liftIO $ readIORef unreadyChildren
+ let new = pred old
+ liftIO $ writeIORef unreadyChildren $! new
+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env
+ requestDomAction_ $ ready <$ eOnce
+ notReady = do
+ env <- ImmediateDomBuilderT ask
+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
+ liftIO $ modifyIORef' unreadyChildren succ
+
+instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
+ type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
+ {-# INLINABLE textNode #-}
+ textNode (TextNodeConfig initialContents mSetContents) = do
+ n <- textNodeInternal initialContents
+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
+ return $ TextNode n
+ {-# INLINABLE element #-}
+ element elementTag cfg child = fst <$> makeElement elementTag cfg child
+ {-# INLINABLE inputElement #-}
+ inputElement cfg = do
+ ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
+ v0 <- Input.getValue domInputElement
+ let getMyValue = Input.getValue domInputElement
+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
+ Nothing -> return never
+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
+ Input.setValue domInputElement v'
+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
+ v <- holdDyn v0 $ leftmost
+ [ valueChangedBySetValue
+ , valueChangedByUI
+ ]
+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
+ Input.getChecked domInputElement
+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
+ Nothing -> return never
+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
+ oldChecked <- Input.getChecked domInputElement
+ Input.setChecked domInputElement newChecked
+ return $ if newChecked /= oldChecked
+ then Just newChecked
+ else Nothing
+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
+ [ fmapMaybe id checkedChangedBySetChecked
+ , checkedChangedByUI
+ ]
+ let initialFocus = False --TODO: Is this correct?
+ hasFocus <- holdDyn initialFocus $ leftmost
+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
+ ]
+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
+ mfiles <- Input.getFiles domInputElement
+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
+ maybe (return []) getMyFiles mfiles
+ checked <- holdUniqDyn c
+ return $ InputElement
+ { _inputElement_value = v
+ , _inputElement_checked = checked
+ , _inputElement_checkedChange = checkedChangedByUI
+ , _inputElement_input = valueChangedByUI
+ , _inputElement_hasFocus = hasFocus
+ , _inputElement_element = e
+ , _inputElement_raw = domInputElement
+ , _inputElement_files = files
+ }
+ {-# INLINABLE textAreaElement #-}
+ textAreaElement cfg = do --TODO
+ ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
+ v0 <- TextArea.getValue domTextAreaElement
+ let getMyValue = TextArea.getValue domTextAreaElement
+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
+ Nothing -> return never
+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
+ TextArea.setValue domTextAreaElement v'
+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
+ v <- holdDyn v0 $ leftmost
+ [ valueChangedBySetValue
+ , valueChangedByUI
+ ]
+ hasFocus <- mkHasFocus e
+ return $ TextAreaElement
+ { _textAreaElement_value = v
+ , _textAreaElement_input = valueChangedByUI
+ , _textAreaElement_hasFocus = hasFocus
+ , _textAreaElement_element = e
+ , _textAreaElement_raw = domTextAreaElement
+ }
+ {-# INLINABLE selectElement #-}
+ selectElement cfg child = do
+ ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
+ v0 <- Select.getValue domSelectElement
+ let getMyValue = Select.getValue domSelectElement
+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
+ Nothing -> return never
+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
+ Select.setValue domSelectElement v'
+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
+ v <- holdDyn v0 $ leftmost
+ [ valueChangedBySetValue
+ , valueChangedByUI
+ ]
+ hasFocus <- mkHasFocus e
+ let wrapped = SelectElement
+ { _selectElement_value = v
+ , _selectElement_change = valueChangedByUI
+ , _selectElement_hasFocus = hasFocus
+ , _selectElement_element = e
+ , _selectElement_raw = domSelectElement
+ }
+ return (wrapped, result)
+ placeRawElement = append . toNode
+ wrapRawElement = wrap
+
+data FragmentState
+ = FragmentState_Unmounted
+ | FragmentState_Mounted (DOM.Text, DOM.Text)
+
+data ImmediateDomFragment = ImmediateDomFragment
+ { _immediateDomFragment_document :: DOM.DocumentFragment
+ , _immediateDomFragment_state :: IORef FragmentState
+ }
+
+extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()
+extractFragment fragment = do
+ state <- liftIO $ readIORef $ _immediateDomFragment_state fragment
+ case state of
+ FragmentState_Unmounted -> return ()
+ FragmentState_Mounted (before, after) -> do
+ extractBetweenExclusive (_immediateDomFragment_document fragment) before after
+ liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
+
+instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
+ type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
+ buildDomFragment w = do
+ df <- createDocumentFragment =<< askDocument
+ result <- flip localEnv w $ \env -> env
+ { _immediateDomBuilderEnv_parent = toNode df
+ }
+ state <- liftIO $ newIORef FragmentState_Unmounted
+ return (ImmediateDomFragment df state, result)
+ mountDomFragment fragment setFragment = do
+ parent <- askParent
+ extractFragment fragment
+ before <- textNodeInternal ("" :: Text)
+ appendChild_ parent $ _immediateDomFragment_document fragment
+ after <- textNodeInternal ("" :: Text)
+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
+ requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
+ extractFragment previousFragment
+ extractFragment childFragment
+ insertBefore (_immediateDomFragment_document childFragment) after
+ liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
+ liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
+
+instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE runWithReplace #-}
+ runWithReplace a0 a' = do
+ initialEnv <- ImmediateDomBuilderT ask
+ before <- textNodeInternal ("" :: Text)
+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
+ haveEverBeenReady <- liftIO $ newIORef False
+ currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
+ let myCommitAction = do
+ liftIO (readIORef haveEverBeenReady) >>= \case
+ True -> return ()
+ False -> do
+ liftIO $ writeIORef haveEverBeenReady True
+ old <- liftIO $ readIORef parentUnreadyChildren
+ let new = pred old
+ liftIO $ writeIORef parentUnreadyChildren $! new
+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
+ -- We draw 'after' in this roundabout way to avoid using MonadFix
+ doc <- askDocument
+ after <- createTextNode doc ("" :: Text)
+ let drawInitialChild = do
+ unreadyChildren <- liftIO $ newIORef 0
+ let f = do
+ result <- a0
+ append $ toNode after
+ return result
+ result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
+ { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = myCommitAction
+ }
+ liftIO $ readIORef unreadyChildren >>= \case
+ 0 -> writeIORef haveEverBeenReady True
+ _ -> modifyIORef' parentUnreadyChildren succ
+ return result
+ a'' <- numberOccurrences a'
+ (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
+ df <- createDocumentFragment doc
+ unreadyChildren <- liftIO $ newIORef 0
+ let commitAction = do
+ c <- liftIO $ readIORef currentCohort
+ when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
+ deleteBetweenExclusive before after
+ insertBefore df after
+ liftIO $ writeIORef currentCohort cohortId
+ myCommitAction
+ result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
+ { _immediateDomBuilderEnv_parent = toNode df
+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = commitAction
+ }
+ uc <- liftIO $ readIORef unreadyChildren
+ let commitActionToRunNow = if uc == 0
+ then Just commitAction
+ else Nothing -- A child will run it when unreadyChildren is decremented to 0
+ return (commitActionToRunNow, result)
+ requestDomAction_ $ fmapMaybe fst child'
+ return (result0, snd <$> child')
+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
+ traverseDMapWithKeyWithAdjustWithMove = do
+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
+ new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
+ PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
+ readIORef sRef >>= \case
+ ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
+ ChildReadyState_Unready _ -> do
+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
+ return $ PatchDMapWithMove.From_Insert $ Constant sRef
+ PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
+ PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
+ deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
+ writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
+ return $ Constant ()
+ p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
+ _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
+ return $ applyAlways p' old
+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
+ let p = unPatchDMapWithMove p_
+ phsBefore <- liftIO $ readIORef placeholders
+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
+ collectIfMoved k e = do
+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
+ False -> do
+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
+ return $ Constant Nothing
+ True -> do
+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
+ collected <- DMap.traverseWithKey collectIfMoved p
+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
+ placeFragment k e = do
+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
+ case PatchDMapWithMove._nodeInfo_from e of
+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
+ df `insertBefore` nextPlaceholder
+ PatchDMapWithMove.From_Delete -> do
+ return ()
+ PatchDMapWithMove.From_Move fromKey -> do
+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected
+ mapM_ (`insertBefore` nextPlaceholder) mdf
+ return $ Constant ()
+ mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
+ liftIO $ writeIORef placeholders $! phsAfter
+
+{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
+traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
+traverseDMapWithKeyWithAdjust' = do
+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of
+ Nothing -> return Nothing
+ Just (Compose (_, _, sRef, _)) -> do
+ readIORef sRef >>= \case
+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
+ ChildReadyState_Unready _ -> do
+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
+ return $ Just $ Constant sRef
+ delete _ (Constant sRef) = do
+ writeIORef sRef $ ChildReadyState_Unready Nothing
+ return $ Constant ()
+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
+ return $ applyAlways p' old
+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
+ phs <- liftIO $ readIORef placeholders
+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
+
+{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
+traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))
+traverseIntMapWithKeyWithAdjust' = do
+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
+ let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
+ new k m = case m of
+ Nothing -> return Nothing
+ Just (_, _, sRef, _) -> do
+ readIORef sRef >>= \case
+ ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
+ ChildReadyStateInt_Unready _ -> do
+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
+ return $ Just sRef
+ delete _ sRef = do
+ writeIORef sRef $ ChildReadyStateInt_Unready Nothing
+ return ()
+ p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
+ _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
+ return $ applyAlways p' old
+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
+ phs <- liftIO $ readIORef placeholders
+ forM_ (IntMap.toList p) $ \(k, mv) -> do
+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
+ let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
+ forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
+ forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
+
+#if MIN_VERSION_base(4,9,0)
+data ChildReadyState k
+#else
+data ChildReadyState (k :: * -> *)
+#endif
+ = ChildReadyState_Ready
+ | ChildReadyState_Unready !(Maybe (Some k))
+ deriving (Show, Read, Eq, Ord)
+
+data ChildReadyStateInt
+ = ChildReadyStateInt_Ready
+ | ChildReadyStateInt_Unready !(Maybe Int)
+ deriving (Show, Read, Eq, Ord)
+
+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
+hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
+ ( Adjustable t m
+ , MonadIO m
+ , MonadJSM m
+ , MonadFix m
+ , PrimMonad m
+ , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
+ , Functor p
+ )
+ => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
+ -> IntMap v
+ -> Event t (p v)
+ -> RequesterT t JSM Identity (TriggerEventT t m) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
+ ) -- ^ The base monad's traversal
+ -> (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
+ -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')
+ -> IntMap v
+ -> Event t (p v)
+ -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))
+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
+ initialEnv <- ImmediateDomBuilderT ask
+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
+ pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
+ haveEverBeenReady <- liftIO $ newIORef False
+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
+ let applyDomUpdate p = do
+ applyDomUpdate_ placeholders lastPlaceholderRef p
+ markSelfReady
+ liftIO $ writeIORef pendingChange $! mempty
+ markSelfReady = do
+ liftIO (readIORef haveEverBeenReady) >>= \case
+ True -> return ()
+ False -> do
+ liftIO $ writeIORef haveEverBeenReady True
+ old <- liftIO $ readIORef parentUnreadyChildren
+ let new = pred old
+ liftIO $ writeIORef parentUnreadyChildren $! new
+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
+ markChildReady :: IORef ChildReadyStateInt -> JSM ()
+ markChildReady childReadyState = do
+ liftIO (readIORef childReadyState) >>= \case
+ ChildReadyStateInt_Ready -> return ()
+ ChildReadyStateInt_Unready countedAt -> do
+ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
+ case countedAt of
+ Nothing -> return ()
+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
+ (oldUnready, p) <- liftIO $ readIORef pendingChange
+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
+ let newUnready = IntMap.delete k oldUnready
+ liftIO $ writeIORef pendingChange (newUnready, p)
+ when (IntMap.null newUnready) $ do
+ applyDomUpdate p
+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
+ let processChild k (_, _, sRef, _) = do
+ readIORef sRef >>= \case
+ ChildReadyStateInt_Ready -> return Nothing
+ ChildReadyStateInt_Unready _ -> do
+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
+ return $ Just sRef
+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
+ liftIO $ if IntMap.null initialUnready
+ then writeIORef haveEverBeenReady True
+ else do
+ modifyIORef' parentUnreadyChildren succ
+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
+ let result0 = IntMap.map (\(_, _, _, v) -> v) children0
+ placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
+ result' = ffor children' $ fmap $ \(_, _, _, r) -> r
+ liftIO $ writeIORef placeholders $! placeholders0
+ _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
+ requestDomAction_ $ ffor children' $ \p -> do
+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
+ let !newP = p <> oldP
+ liftIO $ writeIORef pendingChange (newUnready, newP)
+ when (IntMap.null newUnready) $ do
+ applyDomUpdate newP
+ return (result0, result')
+
+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
+ ( Adjustable t m
+ , MonadHold t m
+ , DMap.GCompare k
+ , MonadIO m
+ , MonadJSM m
+ , PrimMonad m
+ , MonadFix m
+ , Patch (p k v)
+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
+ , Patch (p k (Constant Int))
+ )
+ => (forall vv vv'.
+ (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
+ -> DMap k vv
+ -> Event t (p k vv)
+ -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
+ ) -- ^ The base monad's traversal
+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
+ -> (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
+ -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
+ -> DMap k v
+ -> Event t (p k v)
+ -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
+ initialEnv <- ImmediateDomBuilderT ask
+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
+ haveEverBeenReady <- liftIO $ newIORef False
+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
+ let applyDomUpdate p = do
+ applyDomUpdate_ placeholders lastPlaceholderRef p
+ markSelfReady
+ liftIO $ writeIORef pendingChange $! mempty
+ markSelfReady = do
+ liftIO (readIORef haveEverBeenReady) >>= \case
+ True -> return ()
+ False -> do
+ liftIO $ writeIORef haveEverBeenReady True
+ old <- liftIO $ readIORef parentUnreadyChildren
+ let new = pred old
+ liftIO $ writeIORef parentUnreadyChildren $! new
+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
+ markChildReady :: IORef (ChildReadyState k) -> JSM ()
+ markChildReady childReadyState = do
+ liftIO (readIORef childReadyState) >>= \case
+ ChildReadyState_Ready -> return ()
+ ChildReadyState_Unready countedAt -> do
+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
+ case countedAt of
+ Nothing -> return ()
+ Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
+ (oldUnready, p) <- liftIO $ readIORef pendingChange
+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
+ let newUnready = DMap.delete k oldUnready
+ liftIO $ writeIORef pendingChange (newUnready, p)
+ when (DMap.null newUnready) $ do
+ applyDomUpdate p
+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
+ let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
+ readIORef sRef >>= \case
+ ChildReadyState_Ready -> return Nothing
+ ChildReadyState_Unready _ -> do
+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
+ return $ Just $ Constant sRef
+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
+ liftIO $ if DMap.null initialUnready
+ then writeIORef haveEverBeenReady True
+ else do
+ modifyIORef' parentUnreadyChildren succ
+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
+ liftIO $ writeIORef placeholders $! placeholders0
+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
+ requestDomAction_ $ ffor children' $ \p -> do
+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
+ let !newP = p <> oldP
+ liftIO $ writeIORef pendingChange (newUnready, newP)
+ when (DMap.null newUnready) $ do
+ applyDomUpdate newP
+ return (result0, result')
+
+{-# INLINABLE drawChildUpdate #-}
+drawChildUpdate :: (MonadIO m, MonadJSM m)
+ => ImmediateDomBuilderEnv t
+ -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
+ -> ImmediateDomBuilderT t m (v' a)
+ -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
+drawChildUpdate initialEnv markReady child = do
+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
+ unreadyChildren <- liftIO $ newIORef 0
+ df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
+ { _immediateDomBuilderEnv_parent = toNode df
+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState
+ }
+ u <- liftIO $ readIORef unreadyChildren
+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
+ return $ Compose (df, placeholder, childReadyState, result)
+
+{-# INLINABLE drawChildUpdateInt #-}
+drawChildUpdateInt :: (MonadIO m, MonadJSM m)
+ => ImmediateDomBuilderEnv t
+ -> (IORef ChildReadyStateInt -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
+ -> ImmediateDomBuilderT t m v'
+ -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
+drawChildUpdateInt initialEnv markReady child = do
+ childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
+ unreadyChildren <- liftIO $ newIORef 0
+ df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
+ { _immediateDomBuilderEnv_parent = toNode df
+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState
+ }
+ u <- liftIO $ readIORef unreadyChildren
+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
+ return (df, placeholder, childReadyState, result)
+
+mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
+mkHasFocus e = do
+ let initialFocus = False --TODO: Actually get the initial focus of the element
+ holdDyn initialFocus $ leftmost
+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
+ ]
+
+insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
+insertBefore new existing = do
+ p <- getParentNodeUnchecked existing
+ DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
+
+instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
+ type Performable (ImmediateDomBuilderT t m) = Performable m
+ {-# INLINABLE performEvent_ #-}
+ performEvent_ e = lift $ performEvent_ e
+ {-# INLINABLE performEvent #-}
+ performEvent e = lift $ performEvent e
+
+instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE getPostBuild #-}
+ getPostBuild = lift getPostBuild
+
+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE newEventWithTrigger #-}
+ newEventWithTrigger = lift . newEventWithTrigger
+ {-# INLINABLE newFanEventWithTrigger #-}
+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
+
+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE newTriggerEvent #-}
+ newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
+ {-# INLINABLE newTriggerEventWithOnComplete #-}
+ newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
+ newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
+
+instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
+ type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
+ type Ref (ImmediateDomBuilderT t m) = Ref m
+ {-# INLINABLE newRef #-}
+ newRef = lift . newRef
+ {-# INLINABLE readRef #-}
+ readRef = lift . readRef
+ {-# INLINABLE writeRef #-}
+ writeRef r = lift . writeRef r
+
+instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
+ {-# INLINABLE atomicModifyRef #-}
+ atomicModifyRef r = lift . atomicModifyRef r
+
+instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
+ type JSX (ImmediateDomBuilderT t m) = JSX m
+ liftJS = lift . liftJS
+
+type family EventType en where
+ EventType 'AbortTag = UIEvent
+ EventType 'BlurTag = FocusEvent
+ EventType 'ChangeTag = DOM.Event
+ EventType 'ClickTag = MouseEvent
+ EventType 'ContextmenuTag = MouseEvent
+ EventType 'DblclickTag = MouseEvent
+ EventType 'DragTag = MouseEvent
+ EventType 'DragendTag = MouseEvent
+ EventType 'DragenterTag = MouseEvent
+ EventType 'DragleaveTag = MouseEvent
+ EventType 'DragoverTag = MouseEvent
+ EventType 'DragstartTag = MouseEvent
+ EventType 'DropTag = MouseEvent
+ EventType 'ErrorTag = UIEvent
+ EventType 'FocusTag = FocusEvent
+ EventType 'InputTag = DOM.Event
+ EventType 'InvalidTag = DOM.Event
+ EventType 'KeydownTag = KeyboardEvent
+ EventType 'KeypressTag = KeyboardEvent
+ EventType 'KeyupTag = KeyboardEvent
+ EventType 'LoadTag = UIEvent
+ EventType 'MousedownTag = MouseEvent
+ EventType 'MouseenterTag = MouseEvent
+ EventType 'MouseleaveTag = MouseEvent
+ EventType 'MousemoveTag = MouseEvent
+ EventType 'MouseoutTag = MouseEvent
+ EventType 'MouseoverTag = MouseEvent
+ EventType 'MouseupTag = MouseEvent
+ EventType 'MousewheelTag = MouseEvent
+ EventType 'ScrollTag = UIEvent
+ EventType 'SelectTag = UIEvent
+ EventType 'SubmitTag = DOM.Event
+ EventType 'WheelTag = WheelEvent
+ EventType 'BeforecutTag = ClipboardEvent
+ EventType 'CutTag = ClipboardEvent
+ EventType 'BeforecopyTag = ClipboardEvent
+ EventType 'CopyTag = ClipboardEvent
+ EventType 'BeforepasteTag = ClipboardEvent
+ EventType 'PasteTag = ClipboardEvent
+ EventType 'ResetTag = DOM.Event
+ EventType 'SearchTag = DOM.Event
+ EventType 'SelectstartTag = DOM.Event
+ EventType 'TouchstartTag = TouchEvent
+ EventType 'TouchmoveTag = TouchEvent
+ EventType 'TouchendTag = TouchEvent
+ EventType 'TouchcancelTag = TouchEvent
+
+{-# INLINABLE defaultDomEventHandler #-}
+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
+defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
+ Click -> return ()
+ Dblclick -> getMouseEventCoords
+ Keypress -> getKeyEvent
+ Scroll -> fromIntegral <$> getScrollTop e
+ Keydown -> getKeyEvent
+ Keyup -> getKeyEvent
+ Mousemove -> getMouseEventCoords
+ Mouseup -> getMouseEventCoords
+ Mousedown -> getMouseEventCoords
+ Mouseenter -> return ()
+ Mouseleave -> return ()
+ Focus -> return ()
+ Blur -> return ()
+ Change -> return ()
+ Drag -> return ()
+ Dragend -> return ()
+ Dragenter -> return ()
+ Dragleave -> return ()
+ Dragover -> return ()
+ Dragstart -> return ()
+ Drop -> return ()
+ Abort -> return ()
+ Contextmenu -> return ()
+ Error -> return ()
+ Input -> return ()
+ Invalid -> return ()
+ Load -> return ()
+ Mouseout -> return ()
+ Mouseover -> return ()
+ Select -> return ()
+ Submit -> return ()
+ Beforecut -> return ()
+ Cut -> return ()
+ Beforecopy -> return ()
+ Copy -> return ()
+ Beforepaste -> return ()
+ Paste -> return ()
+ Reset -> return ()
+ Search -> return ()
+ Selectstart -> return ()
+ Touchstart -> getTouchEvent
+ Touchmove -> getTouchEvent
+ Touchend -> getTouchEvent
+ Touchcancel -> getTouchEvent
+ Mousewheel -> return ()
+ Wheel -> return ()
+
+{-# INLINABLE defaultDomWindowEventHandler #-}
+defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
+defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
+ Click -> return ()
+ Dblclick -> getMouseEventCoords
+ Keypress -> getKeyEvent
+ Scroll -> Window.getScrollY w
+ Keydown -> getKeyEvent
+ Keyup -> getKeyEvent
+ Mousemove -> getMouseEventCoords
+ Mouseup -> getMouseEventCoords
+ Mousedown -> getMouseEventCoords
+ Mouseenter -> return ()
+ Mouseleave -> return ()
+ Focus -> return ()
+ Blur -> return ()
+ Change -> return ()
+ Drag -> return ()
+ Dragend -> return ()
+ Dragenter -> return ()
+ Dragleave -> return ()
+ Dragover -> return ()
+ Dragstart -> return ()
+ Drop -> return ()
+ Abort -> return ()
+ Contextmenu -> return ()
+ Error -> return ()
+ Input -> return ()
+ Invalid -> return ()
+ Load -> return ()
+ Mouseout -> return ()
+ Mouseover -> return ()
+ Select -> return ()
+ Submit -> return ()
+ Beforecut -> return ()
+ Cut -> return ()
+ Beforecopy -> return ()
+ Copy -> return ()
+ Beforepaste -> return ()
+ Paste -> return ()
+ Reset -> return ()
+ Search -> return ()
+ Selectstart -> return ()
+ Touchstart -> getTouchEvent
+ Touchmove -> getTouchEvent
+ Touchend -> getTouchEvent
+ Touchcancel -> getTouchEvent
+ Mousewheel -> return ()
+ Wheel -> return ()
+
+{-# INLINABLE withIsEvent #-}
+withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
+withIsEvent en r = case en of
+ Click -> r
+ Dblclick -> r
+ Keypress -> r
+ Scroll -> r
+ Keydown -> r
+ Keyup -> r
+ Mousemove -> r
+ Mouseup -> r
+ Mousedown -> r
+ Mouseenter -> r
+ Mouseleave -> r
+ Focus -> r
+ Blur -> r
+ Change -> r
+ Drag -> r
+ Dragend -> r
+ Dragenter -> r
+ Dragleave -> r
+ Dragover -> r
+ Dragstart -> r
+ Drop -> r
+ Abort -> r
+ Contextmenu -> r
+ Error -> r
+ Input -> r
+ Invalid -> r
+ Load -> r
+ Mouseout -> r
+ Mouseover -> r
+ Select -> r
+ Submit -> r
+ Beforecut -> r
+ Cut -> r
+ Beforecopy -> r
+ Copy -> r
+ Beforepaste -> r
+ Paste -> r
+ Reset -> r
+ Search -> r
+ Selectstart -> r
+ Touchstart -> r
+ Touchmove -> r
+ Touchend -> r
+ Touchcancel -> r
+ Mousewheel -> r
+ Wheel -> r
+
+showEventName :: EventName en -> String
+showEventName en = case en of
+ Abort -> "Abort"
+ Blur -> "Blur"
+ Change -> "Change"
+ Click -> "Click"
+ Contextmenu -> "Contextmenu"
+ Dblclick -> "Dblclick"
+ Drag -> "Drag"
+ Dragend -> "Dragend"
+ Dragenter -> "Dragenter"
+ Dragleave -> "Dragleave"
+ Dragover -> "Dragover"
+ Dragstart -> "Dragstart"
+ Drop -> "Drop"
+ Error -> "Error"
+ Focus -> "Focus"
+ Input -> "Input"
+ Invalid -> "Invalid"
+ Keydown -> "Keydown"
+ Keypress -> "Keypress"
+ Keyup -> "Keyup"
+ Load -> "Load"
+ Mousedown -> "Mousedown"
+ Mouseenter -> "Mouseenter"
+ Mouseleave -> "Mouseleave"
+ Mousemove -> "Mousemove"
+ Mouseout -> "Mouseout"
+ Mouseover -> "Mouseover"
+ Mouseup -> "Mouseup"
+ Mousewheel -> "Mousewheel"
+ Scroll -> "Scroll"
+ Select -> "Select"
+ Submit -> "Submit"
+ Wheel -> "Wheel"
+ Beforecut -> "Beforecut"
+ Cut -> "Cut"
+ Beforecopy -> "Beforecopy"
+ Copy -> "Copy"
+ Beforepaste -> "Beforepaste"
+ Paste -> "Paste"
+ Reset -> "Reset"
+ Search -> "Search"
+ Selectstart -> "Selectstart"
+ Touchstart -> "Touchstart"
+ Touchmove -> "Touchmove"
+ Touchend -> "Touchend"
+ Touchcancel -> "Touchcancel"
+
+--TODO: Get rid of this hack
+-- ElementEventTarget is here to allow us to treat SVG and HTML elements as the same thing; without it, we'll break any existing SVG code.
+newtype ElementEventTarget = ElementEventTarget DOM.Element deriving (DOM.IsGObject, DOM.ToJSVal, DOM.IsSlotable, DOM.IsParentNode, DOM.IsNonDocumentTypeChildNode, DOM.IsChildNode, DOM.IsAnimatable, IsNode, IsElement)
+instance DOM.FromJSVal ElementEventTarget where
+ fromJSVal = fmap (fmap ElementEventTarget) . DOM.fromJSVal
+instance DOM.IsEventTarget ElementEventTarget
+instance DOM.IsGlobalEventHandlers ElementEventTarget
+instance DOM.IsDocumentAndElementEventHandlers ElementEventTarget
+
+{-# INLINABLE elementOnEventName #-}
+elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
+elementOnEventName en e_ = let e = ElementEventTarget (DOM.toElement e_) in case en of
+ Abort -> on e Events.abort
+ Blur -> on e Events.blur
+ Change -> on e Events.change
+ Click -> on e Events.click
+ Contextmenu -> on e Events.contextMenu
+ Dblclick -> on e Events.dblClick
+ Drag -> on e Events.drag
+ Dragend -> on e Events.dragEnd
+ Dragenter -> on e Events.dragEnter
+ Dragleave -> on e Events.dragLeave
+ Dragover -> on e Events.dragOver
+ Dragstart -> on e Events.dragStart
+ Drop -> on e Events.drop
+ Error -> on e Events.error
+ Focus -> on e Events.focus
+ Input -> on e Events.input
+ Invalid -> on e Events.invalid
+ Keydown -> on e Events.keyDown
+ Keypress -> on e Events.keyPress
+ Keyup -> on e Events.keyUp
+ Load -> on e Events.load
+ Mousedown -> on e Events.mouseDown
+ Mouseenter -> on e Events.mouseEnter
+ Mouseleave -> on e Events.mouseLeave
+ Mousemove -> on e Events.mouseMove
+ Mouseout -> on e Events.mouseOut
+ Mouseover -> on e Events.mouseOver
+ Mouseup -> on e Events.mouseUp
+ Mousewheel -> on e Events.mouseWheel
+ Scroll -> on e Events.scroll
+ Select -> on e Events.select
+ Submit -> on e Events.submit
+ Wheel -> on e Events.wheel
+ Beforecut -> on e Events.beforeCut
+ Cut -> on e Events.cut
+ Beforecopy -> on e Events.beforeCopy
+ Copy -> on e Events.copy
+ Beforepaste -> on e Events.beforePaste
+ Paste -> on e Events.paste
+ Reset -> on e Events.reset
+ Search -> on e Events.search
+ Selectstart -> on e Element.selectStart
+ Touchstart -> on e Events.touchStart
+ Touchmove -> on e Events.touchMove
+ Touchend -> on e Events.touchEnd
+ Touchcancel -> on e Events.touchCancel
+
+{-# INLINABLE windowOnEventName #-}
+windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())
+windowOnEventName en e = case en of
+ Abort -> on e Events.abort
+ Blur -> on e Events.blur
+ Change -> on e Events.change
+ Click -> on e Events.click
+ Contextmenu -> on e Events.contextMenu
+ Dblclick -> on e Events.dblClick
+ Drag -> on e Events.drag
+ Dragend -> on e Events.dragEnd
+ Dragenter -> on e Events.dragEnter
+ Dragleave -> on e Events.dragLeave
+ Dragover -> on e Events.dragOver
+ Dragstart -> on e Events.dragStart
+ Drop -> on e Events.drop
+ Error -> on e Events.error
+ Focus -> on e Events.focus
+ Input -> on e Events.input
+ Invalid -> on e Events.invalid
+ Keydown -> on e Events.keyDown
+ Keypress -> on e Events.keyPress
+ Keyup -> on e Events.keyUp
+ Load -> on e Events.load
+ Mousedown -> on e Events.mouseDown
+ Mouseenter -> on e Events.mouseEnter
+ Mouseleave -> on e Events.mouseLeave
+ Mousemove -> on e Events.mouseMove
+ Mouseout -> on e Events.mouseOut
+ Mouseover -> on e Events.mouseOver
+ Mouseup -> on e Events.mouseUp
+ Mousewheel -> on e Events.mouseWheel
+ Scroll -> on e Events.scroll
+ Select -> on e Events.select
+ Submit -> on e Events.submit
+ Wheel -> on e Events.wheel
+ Beforecut -> const $ return $ return () --TODO
+ Cut -> const $ return $ return () --TODO
+ Beforecopy -> const $ return $ return () --TODO
+ Copy -> const $ return $ return () --TODO
+ Beforepaste -> const $ return $ return () --TODO
+ Paste -> const $ return $ return () --TODO
+ Reset -> on e Events.reset
+ Search -> on e Events.search
+ Selectstart -> const $ return $ return () --TODO
+ Touchstart -> on e Events.touchStart
+ Touchmove -> on e Events.touchMove
+ Touchend -> on e Events.touchEnd
+ Touchcancel -> on e Events.touchCancel
+
+{-# INLINABLE wrapDomEvent #-}
+wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)
+wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
+
+{-# INLINABLE subscribeDomEvent #-}
+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
+ -> EventM e event (Maybe a)
+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
+ -> EventTrigger t a
+ -> JSM (JSM ())
+subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
+ mv <- getValue
+ forM_ mv $ \v -> liftIO $ do
+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
+ etr <- newIORef $ Just et
+ writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
+
+{-# INLINABLE wrapDomEventMaybe #-}
+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)
+ => e
+ -> (e -> EventM e event () -> JSM (JSM ()))
+ -> EventM e event (Maybe a)
+ -> m (Event t a)
+wrapDomEventMaybe el elementOnevent getValue = do
+ ctx <- askJSM
+ newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do
+ mv <- getValue
+ forM_ mv $ \v -> liftIO $ trigger v $ return ())
+
+{-# INLINABLE wrapDomEventsMaybe #-}
+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)
+ => e
+ -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))
+ -> (forall en. EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ()))
+ -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
+wrapDomEventsMaybe target handlers onEventName = do
+ ctx <- askJSM
+ eventChan <- askEvents
+ e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en
+ (((`runJSM` ctx) <$>) . (`runJSM` ctx) . subscribeDomEvent (onEventName en target) (handlers en) eventChan)
+ return $! e
+
+{-# INLINABLE getKeyEvent #-}
+getKeyEvent :: EventM e KeyboardEvent Word
+getKeyEvent = do
+ e <- event
+ which <- KeyboardEvent.getWhich e
+ if which /= 0 then return which else do
+ charCode <- getCharCode e
+ if charCode /= 0 then return charCode else
+ getKeyCode e
+
+{-# INLINABLE getMouseEventCoords #-}
+getMouseEventCoords :: EventM e MouseEvent (Int, Int)
+getMouseEventCoords = do
+ e <- event
+ bisequence (getClientX e, getClientY e)
+
+{-# INLINABLE getTouchEvent #-}
+getTouchEvent :: EventM e TouchEvent TouchEventResult
+getTouchEvent = do
+ let touchResults ts = do
+ n <- TouchList.getLength ts
+ forM (takeWhile (< n) [0..]) $ \ix -> do
+ t <- TouchList.item ts ix
+ identifier <- Touch.getIdentifier t
+ screenX <- Touch.getScreenX t
+ screenY <- Touch.getScreenY t
+ clientX <- Touch.getClientX t
+ clientY <- Touch.getClientY t
+ pageX <- Touch.getPageX t
+ pageY <- Touch.getPageY t
+ return TouchResult
+ { _touchResult_identifier = identifier
+ , _touchResult_screenX = screenX
+ , _touchResult_screenY = screenY
+ , _touchResult_clientX = clientX
+ , _touchResult_clientY = clientY
+ , _touchResult_pageX = pageX
+ , _touchResult_pageY = pageY
+ }
+ e <- event
+ altKey <- TouchEvent.getAltKey e
+ ctrlKey <- TouchEvent.getCtrlKey e
+ shiftKey <- TouchEvent.getShiftKey e
+ metaKey <- TouchEvent.getMetaKey e
+ changedTouches <- touchResults =<< TouchEvent.getChangedTouches e
+ targetTouches <- touchResults =<< TouchEvent.getTargetTouches e
+ touches <- touchResults =<< TouchEvent.getTouches e
+ return $ TouchEventResult
+ { _touchEventResult_altKey = altKey
+ , _touchEventResult_changedTouches = changedTouches
+ , _touchEventResult_ctrlKey = ctrlKey
+ , _touchEventResult_metaKey = metaKey
+ , _touchEventResult_shiftKey = shiftKey
+ , _touchEventResult_targetTouches = targetTouches
+ , _touchEventResult_touches = touches
+ }
+
+instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE sample #-}
+ sample = lift . sample
+
+instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
+ {-# INLINABLE hold #-}
+ hold v0 v' = lift $ hold v0 v'
+ {-# INLINABLE holdDyn #-}
+ holdDyn v0 v' = lift $ holdDyn v0 v'
+ {-# INLINABLE holdIncremental #-}
+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
+ {-# INLINABLE buildDynamic #-}
+ buildDynamic a0 = lift . buildDynamic a0
+ {-# INLINABLE headE #-}
+ headE = lift . headE
+
+data WindowConfig t = WindowConfig -- No config options yet
+
+instance Default (WindowConfig t) where
+ def = WindowConfig
+
+data Window t = Window
+ { _window_events :: EventSelector t (WrapArg EventResult EventName)
+ , _window_raw :: DOM.Window
+ }
+
+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
+wrapWindow wv _ = do
+ events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
+ return $ Window
+ { _window_events = events
+ , _window_raw = wv
+ }
+
+#ifdef USE_TEMPLATE_HASKELL
+makeLenses ''GhcjsEventSpec
+#endif
diff --git a/src/Reflex/Dom/Builder/InputDisabled.hs b/src/Reflex/Dom/Builder/InputDisabled.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/InputDisabled.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Dom.Builder.InputDisabled where
+
+import Control.Monad.Fix
+import Control.Monad.Primitive
+import Control.Monad.Ref
+import Control.Monad.Trans
+import Control.Monad.Trans.Control
+import Data.Coerce
+import qualified Data.Map as Map
+import Foreign.JavaScript.TH
+#ifndef ghcjs_HOST_OS
+import GHCJS.DOM.Types (MonadJSM (..))
+#endif
+import Reflex
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate (HasDocument (..))
+import Reflex.Host.Class
+
+-- | A DomBuilder transformer that disables all 'inputElement's,
+-- 'textAreaElement's, and 'selectElement's by adding the "disabled" HTML
+-- attribute. Note that 'element's that happen to have "input", "textarea", or
+-- "select" as their tag will NOT be disabled.
+newtype InputDisabledT m a = InputDisabledT { runInputDisabledT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
+
+#ifndef ghcjs_HOST_OS
+instance MonadJSM m => MonadJSM (InputDisabledT m) where
+ liftJSM' = InputDisabledT . liftJSM'
+#endif
+
+deriving instance MonadSample t m => MonadSample t (InputDisabledT m)
+deriving instance MonadHold t m => MonadHold t (InputDisabledT m)
+
+instance MonadTrans InputDisabledT where
+ lift = InputDisabledT
+
+instance MonadTransControl InputDisabledT where
+ type StT InputDisabledT a = a
+ liftWith f = InputDisabledT $ f runInputDisabledT
+ restoreT = InputDisabledT
+
+instance MonadRef m => MonadRef (InputDisabledT m) where
+ type Ref (InputDisabledT m) = Ref m
+ newRef = lift . newRef
+ readRef = lift . readRef
+ writeRef ref = lift . writeRef ref
+
+instance PerformEvent t m => PerformEvent t (InputDisabledT m) where
+ type Performable (InputDisabledT m) = Performable m
+ performEvent_ = lift . performEvent_
+ performEvent = lift . performEvent
+
+instance PrimMonad m => PrimMonad (InputDisabledT m) where
+ type PrimState (InputDisabledT m) = PrimState m
+ primitive = lift . primitive
+
+disableElementConfig :: Reflex t => ElementConfig er t m -> ElementConfig er t m
+disableElementConfig cfg = cfg
+ { _elementConfig_initialAttributes = Map.insert "disabled" "disabled" $ _elementConfig_initialAttributes cfg
+ , _elementConfig_modifyAttributes = fmap (Map.delete "disabled") <$> _elementConfig_modifyAttributes cfg
+ }
+
+instance PostBuild t m => PostBuild t (InputDisabledT m) where
+ getPostBuild = lift getPostBuild
+
+deriving instance TriggerEvent t m => TriggerEvent t (InputDisabledT m)
+
+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabledT m) where
+ newEventWithTrigger = lift . newEventWithTrigger
+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
+
+instance Adjustable t m => Adjustable t (InputDisabledT m) where
+ runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a')
+ traverseDMapWithKeyWithAdjust f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')
+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')
+
+instance NotReady t m => NotReady t (InputDisabledT m) where
+ notReadyUntil = lift . notReadyUntil
+ notReady = lift notReady
+
+instance DomBuilder t m => DomBuilder t (InputDisabledT m) where
+ type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m
+ inputElement cfg = lift $ inputElement $ cfg
+ { _inputElementConfig_elementConfig = disableElementConfig $ _inputElementConfig_elementConfig cfg
+ }
+ textAreaElement cfg = lift $ textAreaElement $ cfg
+ { _textAreaElementConfig_elementConfig = disableElementConfig $ _textAreaElementConfig_elementConfig cfg
+ }
+ selectElement cfg child = do
+ let cfg' = cfg
+ { _selectElementConfig_elementConfig = disableElementConfig $ _selectElementConfig_elementConfig cfg
+ }
+ lift $ selectElement cfg' $ runInputDisabledT child
+
+instance HasDocument m => HasDocument (InputDisabledT m)
+
+instance HasJSContext m => HasJSContext (InputDisabledT m) where
+ type JSContextPhantom (InputDisabledT m) = JSContextPhantom m
+ askJSContext = lift askJSContext
+
+instance HasJS js m => HasJS js (InputDisabledT m) where
+ type JSX (InputDisabledT m) = JSX m
+ liftJS = lift . liftJS
diff --git a/src/Reflex/Dom/Builder/Static.hs b/src/Reflex/Dom/Builder/Static.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Builder/Static.hs
@@ -0,0 +1,303 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Dom.Builder.Static where
+
+import Blaze.ByteString.Builder.Html.Utf8
+import Control.Lens hiding (element)
+import Control.Monad.Exception
+import Control.Monad.Identity
+import Control.Monad.Primitive
+import Control.Monad.Ref
+import Control.Monad.State.Strict
+import Control.Monad.Trans.Reader
+import Data.ByteString (ByteString)
+import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
+import qualified Data.ByteString.Lazy as LBS
+import Data.Default
+import Data.Dependent.Map (DMap)
+import qualified Data.Dependent.Map as DMap
+import Data.Dependent.Sum (DSum (..))
+import Data.Functor.Compose
+import Data.Functor.Constant
+import qualified Data.Map as Map
+import Data.Map.Misc (applyMap)
+import Data.Monoid
+import qualified Data.Set as Set
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Tuple
+import GHC.Generics
+import Reflex.Adjustable.Class
+import Reflex.Class
+import Reflex.Dom.Main (DomHost, DomTimeline, runDomHost)
+import Reflex.Dom.Builder.Class
+import Reflex.Dynamic
+import Reflex.Host.Class
+import Reflex.PerformEvent.Base
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Base
+import Reflex.TriggerEvent.Class
+
+data StaticDomBuilderEnv t = StaticDomBuilderEnv
+ { _staticDomBuilderEnv_shouldEscape :: Bool
+ , _staticDomBuilderEnv_selectValue :: Maybe (Behavior t Text)
+ -- ^ When the parent element is a "select" whose value has been set, this value tells us the current value.
+ -- We use this to add a "selected" attribute to the appropriate "option" child element.
+ -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
+ -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
+ }
+
+newtype StaticDomBuilderT t m a = StaticDomBuilderT
+ { unStaticDomBuilderT :: ReaderT (StaticDomBuilderEnv t) (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
+ }
+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
+
+instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
+ type PrimState (StaticDomBuilderT x m) = PrimState m
+ primitive = lift . primitive
+
+instance MonadTrans (StaticDomBuilderT t) where
+ lift = StaticDomBuilderT . lift . lift
+
+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv t -> m (a, Behavior t Builder)
+runStaticDomBuilderT (StaticDomBuilderT a) e = do
+ (result, a') <- runStateT (runReaderT a e) []
+ return (result, mconcat $ reverse a')
+
+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
+ {-# INLINABLE newEventWithTrigger #-}
+ newEventWithTrigger = lift . newEventWithTrigger
+ {-# INLINABLE newFanEventWithTrigger #-}
+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
+
+instance PerformEvent t m => PerformEvent t (StaticDomBuilderT t m) where
+ type Performable (StaticDomBuilderT t m) = Performable m
+ {-# INLINABLE performEvent_ #-}
+ performEvent_ e = lift $ performEvent_ e
+ {-# INLINABLE performEvent #-}
+ performEvent e = lift $ performEvent e
+
+instance MonadSample t m => MonadSample t (StaticDomBuilderT t m) where
+ {-# INLINABLE sample #-}
+ sample = lift . sample
+
+instance MonadHold t m => MonadHold t (StaticDomBuilderT t m) where
+ {-# INLINABLE hold #-}
+ hold v0 v' = lift $ hold v0 v'
+ {-# INLINABLE holdDyn #-}
+ holdDyn v0 v' = lift $ holdDyn v0 v'
+ {-# INLINABLE holdIncremental #-}
+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
+ {-# INLINABLE buildDynamic #-}
+ buildDynamic a0 = lift . buildDynamic a0
+ {-# INLINABLE headE #-}
+ headE = lift . headE
+
+instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilderT t m) where
+ {-# INLINABLE newTriggerEvent #-}
+ newTriggerEvent = return (never, const $ return ())
+ {-# INLINABLE newTriggerEventWithOnComplete #-}
+ newTriggerEventWithOnComplete = return (never, \_ _ -> return ())
+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
+ newEventWithLazyTriggerWithOnComplete _ = return never
+
+instance MonadRef m => MonadRef (StaticDomBuilderT t m) where
+ type Ref (StaticDomBuilderT t m) = Ref m
+ newRef = lift . newRef
+ readRef = lift . readRef
+ writeRef r = lift . writeRef r
+
+instance MonadAtomicRef m => MonadAtomicRef (StaticDomBuilderT t m) where
+ atomicModifyRef r = lift . atomicModifyRef r
+
+type SupportsStaticDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO, Adjustable t m)
+
+data StaticDomSpace
+
+-- | Static documents never produce any events, so this type has no inhabitants
+data StaticDomEvent (a :: k)
+
+-- | Static documents don't process events, so all handlers are equivalent
+data StaticDomHandler (a :: k) (b :: k) = StaticDomHandler
+
+data StaticEventSpec (er :: EventTag -> *) = StaticEventSpec deriving (Generic)
+
+instance Default (StaticEventSpec er)
+
+instance DomSpace StaticDomSpace where
+ type EventSpec StaticDomSpace = StaticEventSpec
+ type RawDocument StaticDomSpace = ()
+ type RawTextNode StaticDomSpace = ()
+ type RawElement StaticDomSpace = ()
+ type RawFile StaticDomSpace = ()
+ type RawInputElement StaticDomSpace = ()
+ type RawTextAreaElement StaticDomSpace = ()
+ type RawSelectElement StaticDomSpace = ()
+ addEventSpecFlags _ _ _ _ = StaticEventSpec
+
+instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilderT t m) where
+ askDocument = pure ()
+
+instance (Reflex t, Adjustable t m, MonadHold t m) => Adjustable t (StaticDomBuilderT t m) where
+ runWithReplace a0 a' = do
+ e <- StaticDomBuilderT ask
+ (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
+ o <- hold (snd result0) $ fmapCheap snd result'
+ StaticDomBuilderT $ modify $ (:) $ join o
+ return (fst result0, fmapCheap fst result')
+ traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
+ traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
+
+hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
+ ( Adjustable t m
+ , MonadHold t m
+ , PatchTarget (p k (Constant (Behavior t Builder))) ~ DMap k (Constant (Behavior t Builder))
+ , Patch (p k (Constant (Behavior t Builder)))
+ )
+ => (forall vv vv'.
+ (forall a. k a -> vv a -> m (vv' a))
+ -> DMap k vv
+ -> Event t (p k vv)
+ -> m (DMap k vv', Event t (p k vv'))
+ ) -- ^ The base monad's traversal
+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
+ -> (forall a. k a -> v a -> StaticDomBuilderT t m (v' a))
+ -> DMap k v
+ -> Event t (p k v)
+ -> StaticDomBuilderT t m (DMap k v', Event t (p k v'))
+hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do
+ e <- StaticDomBuilderT ask
+ (children0, children') <- lift $ base (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'
+ let result0 = DMap.map (snd . getCompose) children0
+ result' = ffor children' $ mapPatch $ snd . getCompose
+ outputs0 :: DMap k (Constant (Behavior t Builder))
+ outputs0 = DMap.map (Constant . fst . getCompose) children0
+ outputs' :: Event t (p k (Constant (Behavior t Builder)))
+ outputs' = ffor children' $ mapPatch $ Constant . fst . getCompose
+ outputs <- holdIncremental outputs0 outputs'
+ StaticDomBuilderT $ modify $ (:) $ pull $ do
+ os <- sample $ currentIncremental outputs
+ fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do
+ sample o
+ return (result0, result')
+
+instance SupportsStaticDomBuilder t m => NotReady t (StaticDomBuilderT t m) where
+ notReadyUntil _ = pure ()
+ notReady = pure ()
+
+-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.
+instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
+ type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace
+ {-# INLINABLE textNode #-}
+ textNode (TextNodeConfig initialContents mSetContents) = StaticDomBuilderT $ do
+ --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
+ modify . (:) =<< case mSetContents of
+ Nothing -> return (pure (escape initialContents))
+ Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
+ return $ TextNode ()
+ {-# INLINABLE element #-}
+ element elementTag cfg child = do
+ -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
+ let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]
+ let noEscapeElements = Set.fromList ["style", "script"]
+ let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
+ es <- newFanEventWithTrigger $ \_ _ -> return (return ())
+ StaticDomBuilderT $ do
+ let shouldEscape = elementTag `Set.notMember` noEscapeElements
+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
+ attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
+ selectValue <- asks _staticDomBuilderEnv_selectValue
+ let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
+ Just v | v == sel -> attrs <> Map.singleton "selected" ""
+ _ -> Map.delete "selected" attrs
+ let attrs1 = case (elementTag, selectValue) of
+ ("option", Just sv) -> pull $ addSelectedAttr <$> sample (current attrs0) <*> sample sv
+ _ -> current attrs0
+ let attrs2 = ffor attrs1 $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
+ let tagBS = encodeUtf8 elementTag
+ if Set.member elementTag voidElements
+ then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString " />")]
+ else do
+ let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]
+ let close = constant $ byteString $ " tagBS <> ">"
+ modify $ (:) $ mconcat [open, innerHtml, close]
+ let e = Element
+ { _element_events = es
+ , _element_raw = ()
+ }
+ return (e, result)
+ {-# INLINABLE inputElement #-}
+ inputElement cfg = do
+ (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
+ let v0 = constDyn $ cfg ^. inputElementConfig_initialValue
+ let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked
+ let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
+ return $ InputElement
+ { _inputElement_value = v0
+ , _inputElement_checked = c0
+ , _inputElement_checkedChange = never
+ , _inputElement_input = never
+ , _inputElement_hasFocus = hasFocus
+ , _inputElement_element = e
+ , _inputElement_raw = ()
+ , _inputElement_files = constDyn mempty
+ }
+ {-# INLINABLE textAreaElement #-}
+ textAreaElement cfg = do
+ --TODO: Support setValue event
+ (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
+ let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
+ let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
+ return $ TextAreaElement
+ { _textAreaElement_value = v0
+ , _textAreaElement_input = never
+ , _textAreaElement_hasFocus = hasFocus
+ , _textAreaElement_element = e
+ , _textAreaElement_raw = ()
+ }
+ selectElement cfg child = do
+ v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
+ (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)
+ StaticDomBuilderT $ lift $ modify $ (:) innerHtml
+ return a
+ let wrapped = SelectElement
+ { _selectElement_value = v
+ , _selectElement_change = never
+ , _selectElement_hasFocus = constDyn False --TODO: How do we make sure this is correct?
+ , _selectElement_element = e
+ , _selectElement_raw = ()
+ }
+ return (wrapped, result)
+ placeRawElement () = return ()
+ wrapRawElement () _ = return $ Element (EventSelector $ const never) ()
+
+--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
+type StaticWidget x = PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))
+
+{-# INLINE renderStatic #-}
+renderStatic :: StaticWidget x a -> IO (a, ByteString)
+renderStatic w = do
+ runDomHost $ do
+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
+ let env0 = StaticDomBuilderEnv True Nothing
+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
+ mPostBuildTrigger <- readRef postBuildTriggerRef
+ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
+ bs' <- sample bs
+ return (res, LBS.toStrict $ toLazyByteString bs')
diff --git a/src/Reflex/Dom/Class.hs b/src/Reflex/Dom/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Class.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Reflex.Dom.Class ( module Reflex.Dom.Class
+ , module Foreign.JavaScript.TH
+ , module Web.KeyCode
+ ) where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Reflex.Class
+import Web.KeyCode
+
+import Foreign.JavaScript.TH
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+
+import Prelude hiding (concat, mapM, mapM_, sequence)
+
+-- | Alias for Data.Map.singleton
+(=:) :: k -> a -> Map k a
+(=:) = Map.singleton
+infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
+
+{-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
+keycodeEnter :: Int
+keycodeEnter = 13
+
+{-# DEPRECATED keycodeEscape "Instead of `x == keycodeEscape`, use `keyCodeLookup x == Escape`" #-}
+keycodeEscape :: Int
+keycodeEscape = 27
+
+{-# INLINABLE holdOnStartup #-}
+holdOnStartup :: (PostBuild t m, PerformEvent t m, MonadHold t m) => a -> Performable m a -> m (Behavior t a)
+holdOnStartup a0 ma = do
+ hold a0 =<< performEvent . (ma <$) =<< getPostBuild
diff --git a/src/Reflex/Dom/Core.hs b/src/Reflex/Dom/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Core.hs
@@ -0,0 +1,20 @@
+-- Disable haddocks on this module due to a bug on haddocks when selectively
+-- reexporting on ghc > 8.2.
+-- https://github.com/haskell/haddock/issues/979
+{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}
+module Reflex.Dom.Core (module X) where
+
+import Reflex as X hiding (askEvents)
+import Reflex.Dom.Builder.Class as X
+import Reflex.Dom.Builder.Immediate as X
+import Reflex.Dom.Builder.InputDisabled as X
+import Reflex.Dom.Builder.Static as X
+import Reflex.Dom.Class as X
+import Reflex.Dom.Location as X
+import Reflex.Dom.Main as X
+import Reflex.Dom.Modals.Class as X
+import Reflex.Dom.Old as X
+import Reflex.Dom.Prerender as X
+import Reflex.Dom.WebSocket as X
+import Reflex.Dom.Widget as X
+import Reflex.Dom.Xhr as X
diff --git a/src/Reflex/Dom/Location.hs b/src/Reflex/Dom/Location.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Location.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module Reflex.Dom.Location
+ ( browserHistoryWith
+ , getLocationAfterHost
+ , getLocationFragment
+ , getLocationHost
+ , getLocationPath
+ , getLocationProtocol
+ , getLocationUrl
+ , manageHistory
+ , HistoryCommand (..)
+ , HistoryStateUpdate (..)
+ , HistoryItem (..)
+ , getLocationUri
+ ) where
+
+import Reflex
+import Reflex.Dom.Builder.Immediate (wrapDomEvent)
+
+import Control.Lens ((^.))
+import Control.Monad ((>=>))
+import Data.Monoid
+import Data.Text (Text)
+import qualified GHCJS.DOM as DOM
+import qualified GHCJS.DOM.EventM as DOM
+import qualified GHCJS.DOM.Location as Location
+import qualified GHCJS.DOM.History as History
+import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
+import GHCJS.DOM.Types (Location, History, SerializedScriptValue (..), liftJSM)
+import qualified GHCJS.DOM.Types as DOM
+import qualified GHCJS.DOM.Window as Window
+import qualified GHCJS.DOM.WindowEventHandlers as DOM
+import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, ToJSVal (..), FromJSVal (..))
+import Network.URI
+
+withLocation :: (MonadJSM m) => (Location -> m a) -> m a
+withLocation f = DOM.currentWindowUnchecked >>= Window.getLocation >>= f
+
+-- | Returns the full URI-decoded URL of the current window location.
+getLocationUrl :: (MonadJSM m) => m Text
+getLocationUrl = withLocation (Location.getHref >=> decodeURIText)
+
+-- | Returns the host of the current window location
+getLocationHost :: (MonadJSM m) => m Text
+getLocationHost = withLocation Location.getHost
+
+-- | Returns the protocol/scheme (e.g. @http:@ or @https:@) of the current window location
+getLocationProtocol :: (MonadJSM m) => m Text
+getLocationProtocol = withLocation Location.getProtocol
+
+-- | Returns the URI-decoded location after the host and port; i.e. returns the path, query, and fragment of the location.
+getLocationAfterHost :: (MonadJSM m) => m Text
+getLocationAfterHost = withLocation $ \loc -> do
+ pathname <- Location.getPathname loc
+ search <- Location.getSearch loc
+ hash <- Location.getHash loc
+ decodeURI (mconcat [pathname, search, hash] :: Text)
+
+-- | Returns the URI-decoded path of the current window location.
+getLocationPath :: (MonadJSM m) => m Text
+getLocationPath = withLocation (Location.getPathname >=> decodeURIText)
+
+-- | Returns the URI-decoded fragment/hash of the current window location.
+getLocationFragment :: (MonadJSM m) => m Text
+getLocationFragment = withLocation (Location.getHash >=> decodeURIText)
+
+
+-- | Decodes a URI with JavaScript's @decodeURI@ function.
+--
+-- FIXME: @decodeURI@ will throw when URI is malformed
+decodeURI :: (MonadJSM m, ToJSString a, FromJSString b) => a -> m b
+decodeURI input = do
+ window <- DOM.currentWindowUnchecked
+ window' <- DOM.liftJSM $ toJSVal window
+ DOM.liftJSM $ window' ^. js1 ("decodeURI"::Text) input >>= fromJSValUnchecked
+
+decodeURIText :: (MonadJSM m) => Text -> m Text
+decodeURIText = decodeURI
+
+-- | Builds a Dynamic carrying the current window location.
+browserHistoryWith :: (MonadJSM m, TriggerEvent t m, MonadHold t m)
+ => (forall jsm. MonadJSM jsm => Location -> jsm a)
+ -- ^ A function to encode the window location in a more useful form (e.g. @getLocationAfterHost@).
+ -> m (Dynamic t a)
+browserHistoryWith f = do
+ window <- DOM.currentWindowUnchecked
+ location <- Window.getLocation window
+ loc0 <- f location
+ locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
+ holdDyn loc0 locEv
+
+--TODO: Pending https://github.com/haskell/network-uri/issues/39, ensure that
+--we're handling escaping of URIs correctly
+data HistoryItem = HistoryItem
+ { _historyItem_state :: SerializedScriptValue
+ , _historyItem_uri :: URI
+ -- ^ NOTE: All URIs in this module are assumed to be already percent-escaped
+ }
+
+data HistoryStateUpdate = HistoryStateUpdate
+ { _historyStateUpdate_state :: SerializedScriptValue
+ , _historyStateUpdate_title :: Text
+ , _historyStateUpdate_uri :: Maybe URI
+ -- ^ If Just, update the URI; otherwise leave it unchanged
+ -- NOTE: All URIs in this module are assumed to be already percent-escaped
+ }
+
+data HistoryCommand
+ = HistoryCommand_PushState HistoryStateUpdate
+ | HistoryCommand_ReplaceState HistoryStateUpdate
+
+runHistoryCommand :: MonadJSM m => History -> HistoryCommand -> m ()
+runHistoryCommand history = \case
+ HistoryCommand_PushState su -> History.pushState history
+ (_historyStateUpdate_state su)
+ (_historyStateUpdate_title su)
+ (show <$> _historyStateUpdate_uri su)
+ HistoryCommand_ReplaceState su -> History.replaceState history
+ (_historyStateUpdate_state su)
+ (_historyStateUpdate_title su)
+ (show <$> _historyStateUpdate_uri su)
+
+getLocationUriAuth :: MonadJSM m => Location -> m URIAuth
+getLocationUriAuth location = URIAuth "" -- Username and password don't seem to be available in most browsers
+ <$> Location.getHostname location
+ <*> (appendColonIfNotEmpty <$> Location.getPort location)
+ where appendColonIfNotEmpty = \case
+ "" -> ""
+ x -> ":" <> x
+
+getLocationUri :: MonadJSM m => Location -> m URI
+getLocationUri location = URI
+ <$> Location.getProtocol location
+ <*> (Just <$> getLocationUriAuth location)
+ <*> Location.getPathname location
+ <*> Location.getSearch location
+ <*> Location.getHash location
+
+manageHistory :: (MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => Event t HistoryCommand -> m (Dynamic t HistoryItem)
+manageHistory runCmd = do
+ window <- DOM.currentWindowUnchecked
+ location <- Window.getLocation window
+ history <- Window.getHistory window
+ let getCurrentHistoryItem = HistoryItem
+ <$> History.getState history
+ <*> getLocationUri location
+ item0 <- liftJSM getCurrentHistoryItem
+ itemSetInternal <- performEvent $ ffor runCmd $ \cmd -> liftJSM $ do
+ runHistoryCommand history cmd
+ getCurrentHistoryItem
+ itemSetExternal <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
+ e <- DOM.event
+ HistoryItem
+ <$> (SerializedScriptValue <$> PopStateEvent.getState e)
+ <*> getLocationUri location
+ holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
+--TODO: Handle title setting better
diff --git a/src/Reflex/Dom/Main.hs b/src/Reflex/Dom/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Main.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fspecialise-aggressively #-}
+module Reflex.Dom.Main where
+
+import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
+
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Class
+import Reflex.Host.Class
+import Reflex.PerformEvent.Base
+import Reflex.PostBuild.Base
+import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
+import Reflex.TriggerEvent.Base
+
+import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported
+
+import Control.Concurrent
+import Control.Lens
+import Control.Monad
+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
+import Control.Monad.Ref
+import Data.ByteString (ByteString)
+import Data.Dependent.Sum (DSum (..))
+import Data.IORef
+import Data.Maybe
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import GHCJS.DOM
+import GHCJS.DOM.Document
+import GHCJS.DOM.Element
+import GHCJS.DOM.Node
+import GHCJS.DOM.NonElementParentNode
+import GHCJS.DOM.Types (JSM)
+import qualified GHCJS.DOM.Types as DOM
+
+#ifdef PROFILE_REFLEX
+import Reflex.Profiled
+#endif
+
+{-# INLINE mainWidget #-}
+mainWidget :: (forall x. Widget x ()) -> JSM ()
+mainWidget = mainWidget'
+
+{-# INLINABLE mainWidget' #-}
+-- | Warning: `mainWidget'` is provided only as performance tweak. It is expected to disappear in future releases.
+mainWidget' :: Widget () () -> JSM ()
+mainWidget' w = withJSContextSingletonMono $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ body <- getBodyUnchecked doc
+ attachWidget body jsSing w
+
+--TODO: The x's should be unified here
+{-# INLINABLE mainWidgetWithHead #-}
+mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> JSM ()
+mainWidgetWithHead h b = withJSContextSingletonMono $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ headElement <- getHeadUnchecked doc
+ attachWidget headElement jsSing h
+ body <- getBodyUnchecked doc
+ attachWidget body jsSing b
+
+{-# INLINABLE mainWidgetWithCss #-}
+mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> JSM ()
+mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ headElement <- getHeadUnchecked doc
+ setInnerHTML headElement $ "" --TODO: Fix this
+ body <- getBodyUnchecked doc
+ attachWidget body jsSing w
+
+-- | The Reflex timeline for interacting with the DOM
+type DomTimeline =
+#ifdef PROFILE_REFLEX
+ ProfiledTimeline
+#endif
+ Spider
+
+-- | The ReflexHost the DOM lives in
+type DomHost =
+#ifdef PROFILE_REFLEX
+ ProfiledM
+#endif
+ (SpiderHost Global)
+
+runDomHost :: DomHost a -> IO a
+runDomHost = runSpiderHost
+#ifdef PROFILE_REFLEX
+ . runProfiledM
+#endif
+
+type Widget x = PostBuildT DomTimeline (ImmediateDomBuilderT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better because it could avoid fmapping over every performEvent
+
+{-# INLINABLE attachWidget #-}
+attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a
+attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
+
+-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
+mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> JSM ()
+mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ headElement <- getHeadUnchecked doc
+ headFragment <- createDocumentFragment doc
+ bodyElement <- getBodyUnchecked doc
+ bodyFragment <- createDocumentFragment doc
+ (events, fc) <- liftIO . attachWidget'' $ \events -> do
+ let (headWidget, bodyWidget) = widgets
+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
+ let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c
+ go w df = do
+ unreadyChildren <- liftIO $ newIORef 0
+ let builderEnv = ImmediateDomBuilderEnv
+ { _immediateDomBuilderEnv_document = toDocument doc
+ , _immediateDomBuilderEnv_parent = toNode df
+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = return () --TODO
+ }
+ runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
+ rec b <- go (headWidget a) headFragment
+ a <- go (bodyWidget b) bodyFragment
+ return (events, postBuildTriggerRef)
+ replaceElementContents headElement headFragment
+ replaceElementContents bodyElement bodyFragment
+ liftIO $ processAsyncEvents events fc
+
+replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM ()
+replaceElementContents e df = do
+ setInnerHTML e ("" :: String)
+ _ <- appendChild e df
+ return ()
+
+{-# INLINABLE attachWidget' #-}
+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM (a, FireCommand DomTimeline DomHost)
+attachWidget' rootElement jsSing w = do
+ doc <- getOwnerDocumentUnchecked rootElement
+ df <- createDocumentFragment doc
+ ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
+ unreadyChildren <- liftIO $ newIORef 0
+ let builderEnv = ImmediateDomBuilderEnv
+ { _immediateDomBuilderEnv_document = toDocument doc
+ , _immediateDomBuilderEnv_parent = toNode df
+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
+ , _immediateDomBuilderEnv_commitAction = return () --TODO
+ }
+ a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
+ return ((a, events), postBuildTriggerRef)
+ replaceElementContents rootElement df
+ liftIO $ processAsyncEvents events fc
+ return (a, fc)
+
+type EventChannel = Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
+
+{-# INLINABLE attachWidget'' #-}
+attachWidget'' :: (EventChannel -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))) -> IO (a, FireCommand DomTimeline DomHost)
+attachWidget'' w = do
+ events <- newChan
+ runDomHost $ do
+ ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
+ mPostBuildTrigger <- readRef postBuildTriggerRef
+ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
+ return (result, fc)
+
+processAsyncEvents :: EventChannel -> FireCommand DomTimeline DomHost -> IO ()
+processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
+ ers <- readChan events
+ _ <- runDomHost $ do
+ mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
+ me <- readIORef er
+ return $ fmap (\e -> e :=> Identity a) me
+ _ <- fire (catMaybes mes) $ return ()
+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
+ return ()
+
+
+-- | Run a reflex-dom application inside of an existing DOM element with the given ID
+mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()
+mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ root <- getElementByIdUnchecked doc eid
+ attachWidget root jsSing w
+
+newtype AppInput t = AppInput
+ { _appInput_window :: Window t
+ }
+
+newtype AppOutput t = AppOutput --TODO: Add quit event
+ { _appOutput_windowConfig :: WindowConfig t
+ }
+
+runApp' :: (t ~ DomTimeline) => (forall x. AppInput t -> Widget x (AppOutput t)) -> JSM ()
+runApp' app = withJSContextSingleton $ \jsSing -> do
+ doc <- currentDocumentUnchecked
+ body <- getBodyUnchecked doc
+ win <- getDefaultViewUnchecked doc
+ rec o <- attachWidget body jsSing $ do
+ w <- lift $ wrapWindow win $ _appOutput_windowConfig o
+ app $ AppInput
+ { _appInput_window = w
+ }
+ return ()
diff --git a/src/Reflex/Dom/Modals/Class.hs b/src/Reflex/Dom/Modals/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Modals/Class.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Reflex.Dom.Modals.Class where
+
+import Reflex
+
+class ModalOpener t m where
+ requestingModal :: Event t (m (Event t a)) -> m (Event t (Maybe a))
diff --git a/src/Reflex/Dom/Old.hs b/src/Reflex/Dom/Old.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Old.hs
@@ -0,0 +1,280 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+module Reflex.Dom.Old
+ ( MonadWidget
+ , El
+ , ElConfig (..)
+ , elConfig_namespace
+ , elConfig_attributes
+ , _el_clicked
+ , _el_element
+ , _el_events
+ , addVoidAction
+ , AttributeMap
+ , Attributes (..)
+ , buildElement
+ , buildElementNS
+ , buildEmptyElement
+ , buildEmptyElementNS
+ , elDynHtml'
+ , elDynHtmlAttr'
+ , elStopPropagationNS
+ , elWith
+ , elWith'
+ , emptyElWith
+ , emptyElWith'
+ , namedNodeMapGetNames
+ , nodeClear
+ , onEventName
+ , schedulePostBuild
+ , text'
+ , unsafePlaceElement
+ , WidgetHost
+ , wrapElement
+ ) where
+
+import Control.Arrow (first)
+#ifdef USE_TEMPLATE_HASKELL
+import Control.Lens (makeLenses, (%~), (&), (.~), (^.))
+#else
+import Control.Lens (Lens, Lens', (%~), (&), (.~), (^.))
+#endif
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.Ref
+import Data.Default
+import Data.Dependent.Map as DMap
+import Data.Functor.Misc
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import Foreign.JavaScript.TH
+import qualified GHCJS.DOM.Element as Element
+import GHCJS.DOM.EventM (EventM)
+import GHCJS.DOM.NamedNodeMap as NNM
+import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)
+import GHCJS.DOM.Types
+ (liftJSM, JSM, IsHTMLElement, IsNode)
+import qualified GHCJS.DOM.Types as DOM
+import Reflex.Class
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Widget.Basic
+import Reflex.Host.Class
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+import Reflex.TriggerEvent.Class
+
+data ElConfig attrs = ElConfig
+ { _elConfig_namespace :: Maybe Text
+ , _elConfig_attributes :: attrs
+ }
+
+instance attrs ~ Map Text Text => Default (ElConfig attrs) where
+ def = ElConfig
+ { _elConfig_namespace = Nothing
+ , _elConfig_attributes = mempty
+ }
+
+#ifdef USE_TEMPLATE_HASKELL
+makeLenses ''ElConfig
+#else
+elConfig_namespace :: Lens' (ElConfig attrs1) (Maybe Text)
+elConfig_namespace f (ElConfig a b) = (\a' -> ElConfig a' b) <$> f a
+{-# INLINE elConfig_namespace #-}
+elConfig_attributes :: Lens (ElConfig attrs1) (ElConfig attrs2) attrs1 attrs2
+elConfig_attributes f (ElConfig a b) = (\b' -> ElConfig a b') <$> f b
+{-# INLINE elConfig_attributes #-}
+#endif
+
+type MonadWidgetConstraints t m =
+ ( DomBuilder t m
+ , DomBuilderSpace m ~ GhcjsDomSpace
+ , MonadFix m
+ , MonadHold t m
+ , MonadSample t (Performable m)
+ , MonadReflexCreateTrigger t m
+ , PostBuild t m
+ , PerformEvent t m
+ , MonadIO m
+ , MonadIO (Performable m)
+#ifndef ghcjs_HOST_OS
+ , DOM.MonadJSM m
+ , DOM.MonadJSM (Performable m)
+#endif
+ , TriggerEvent t m
+ , HasJSContext m
+ , HasJSContext (Performable m)
+ , HasDocument m
+ , MonadRef m
+ , Ref m ~ Ref IO
+ , MonadRef (Performable m)
+ , Ref (Performable m) ~ Ref IO
+ )
+
+class MonadWidgetConstraints t m => MonadWidget t m
+instance MonadWidgetConstraints t m => MonadWidget t m
+
+type WidgetHost m = Performable m
+
+type El = Element EventResult GhcjsDomSpace
+
+addVoidAction :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()
+addVoidAction = performEvent_
+
+type AttributeMap = Map Text Text
+
+buildElement :: (MonadWidget t m, Attributes m attrs t) => Text -> attrs -> m a -> m (RawElement (DomBuilderSpace m), a)
+buildElement = buildElementNS Nothing
+
+buildEmptyElement :: (MonadWidget t m, Attributes m attrs t) => Text -> attrs -> m (RawElement (DomBuilderSpace m))
+buildEmptyElement elementTag attrs = fst <$> buildElementNS Nothing elementTag attrs blank
+
+buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs t) => Maybe Text -> Text -> attrs -> m (RawElement (DomBuilderSpace m))
+buildEmptyElementNS ns elementTag attrs = fst <$> buildElementNS ns elementTag attrs blank
+
+buildElementNS :: (MonadWidget t m, Attributes m attrs t) => Maybe Text -> Text -> attrs -> m a -> m (RawElement (DomBuilderSpace m), a)
+buildElementNS ns elementTag attrs child = first _element_raw <$> buildElementInternal ns elementTag attrs child
+
+class Attributes m attrs t where
+ buildElementInternal :: MonadWidget t m => Maybe Text -> Text -> attrs -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+
+instance Attributes m (Map Text Text) t where
+ buildElementInternal ns elementTag attrs child = do
+ let cfg = def & elementConfig_namespace .~ ns
+ buildElementCommon elementTag child =<< addStaticAttributes attrs cfg
+
+addStaticAttributes :: Applicative m => Map Text Text -> ElementConfig er t (DomBuilderSpace m) -> m (ElementConfig er t (DomBuilderSpace m))
+addStaticAttributes attrs cfg = do
+ let initialAttrs = Map.fromList $ first (AttributeName Nothing) <$> Map.toList attrs
+ pure $ cfg & elementConfig_initialAttributes .~ initialAttrs
+
+instance PostBuild t m => Attributes m (Dynamic t (Map Text Text)) t where
+ buildElementInternal ns elementTag attrs child = do
+ let cfg = def & elementConfig_namespace .~ ns
+ buildElementCommon elementTag child =<< addDynamicAttributes attrs cfg
+
+addDynamicAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> ElementConfig er t (DomBuilderSpace m) -> m (ElementConfig er t (DomBuilderSpace m))
+addDynamicAttributes attrs cfg = do
+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
+ return $ cfg & elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+
+buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t, a)
+buildElementCommon elementTag child cfg = element elementTag cfg child
+
+
+onEventName :: IsHTMLElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
+onEventName = elementOnEventName
+
+schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
+schedulePostBuild w = do
+ postBuild <- getPostBuild
+ performEvent_ $ w <$ postBuild
+
+text' :: MonadWidget t m => Text -> m DOM.Text
+text' s = _textNode_raw <$> textNode (def & textNodeConfig_initialContents .~ s)
+
+instance HasAttributes (ElConfig attrs) where
+ type Attrs (ElConfig attrs) = attrs
+ attributes = elConfig_attributes
+
+instance HasNamespace (ElConfig attrs) where
+ namespace = elConfig_namespace
+
+elWith :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m a -> m a
+elWith elementTag cfg child = snd <$> elWith' elementTag cfg child
+
+elWith' :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elWith' elementTag cfg = buildElementInternal (cfg ^. namespace) elementTag $ cfg ^. attributes
+
+emptyElWith :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m ()
+emptyElWith elementTag cfg = void $ emptyElWith' elementTag cfg
+
+emptyElWith' :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m (Element EventResult (DomBuilderSpace m) t)
+emptyElWith' elementTag cfg = fmap fst $ elWith' elementTag cfg $ return ()
+
+{-# DEPRECATED _el_clicked "Use 'domEvent Click' instead" #-}
+_el_clicked :: Reflex t => Element EventResult d t -> Event t ()
+_el_clicked = domEvent Click
+
+{-# DEPRECATED _el_element "Use '_element_raw' instead" #-}
+_el_element :: El t -> RawElement GhcjsDomSpace
+_el_element = _element_raw
+
+{-# DEPRECATED _el_events "Use '_element_events' instead; or, if possible, use 'domEvent' instead to retrieve a particular event" #-}
+_el_events :: Element er d t -> EventSelector t (WrapArg er EventName)
+_el_events = _element_events
+
+{-# DEPRECATED _el_keypress "Use 'domEvent Keypress' instead" #-}
+_el_keypress :: Reflex t => El t -> Event t Word
+_el_keypress = domEvent Keypress
+
+{-# DEPRECATED _el_scrolled "Use 'domEvent Scroll' instead" #-}
+_el_scrolled :: Reflex t => El t -> Event t Double
+_el_scrolled = domEvent Scroll
+
+wrapElement :: forall t m. MonadWidget t m => (forall en. DOM.HTMLElement -> EventName en -> EventM DOM.Element (EventType en) (Maybe (EventResult en))) -> DOM.HTMLElement -> m (El t)
+wrapElement eh e = do
+ let h :: (EventName en, GhcjsDomEvent en) -> JSM (Maybe (EventResult en))
+ h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
+ wrapRawElement (DOM.toElement e) $ (def :: RawElementConfig EventResult t (DomBuilderSpace m))
+ { _rawElementConfig_eventSpec = def
+ { _ghcjsEventSpec_handler = GhcjsEventHandler h
+ }
+ }
+
+unsafePlaceElement :: MonadWidget t m => DOM.HTMLElement -> m (Element EventResult (DomBuilderSpace m) t)
+unsafePlaceElement e = do
+ placeRawElement $ DOM.toElement e
+ wrapRawElement (DOM.toElement e) def
+
+namedNodeMapGetNames :: DOM.NamedNodeMap -> JSM (Set Text)
+namedNodeMapGetNames self = do
+ l <- NNM.getLength self
+ Set.fromList <$> forM (take (fromIntegral l) [0..]) (
+ NNM.itemUnchecked self >=> getNodeName)
+
+nodeClear :: IsNode self => self -> JSM ()
+nodeClear n = do
+ mfc <- getFirstChild n
+ case mfc of
+ Nothing -> return ()
+ Just fc -> do
+ _ <- removeChild n fc
+ nodeClear n
+
+elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a
+elStopPropagationNS ns elementTag en child = do
+ let f = GhcjsEventFilter $ \_ -> do
+ return (stopPropagation, return Nothing)
+ cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
+ & namespace .~ ns
+ & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
+ snd <$> element elementTag cfg child
+
+elDynHtmlAttr' :: (DOM.MonadJSM m, MonadWidget t m) => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
+elDynHtmlAttr' elementTag attrs html = do
+ let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
+ (e, _) <- element elementTag cfg $ return ()
+ postBuild <- getPostBuild
+ performEvent_ $ liftJSM . Element.setInnerHTML (_element_raw e) <$> leftmost [updated html, tag (current html) postBuild]
+ return e
+
+elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
+elDynHtml' elementTag = elDynHtmlAttr' elementTag mempty
diff --git a/src/Reflex/Dom/Prerender.hs b/src/Reflex/Dom/Prerender.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Prerender.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Dom.Prerender
+ ( Prerender (..)
+ , prerender
+ , PrerenderClientConstraint
+ ) where
+
+import Control.Monad.Reader
+import Data.Constraint
+import Foreign.JavaScript.TH
+import GHCJS.DOM.Types (MonadJSM)
+import Reflex
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.InputDisabled
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Builder.Static
+import Reflex.Host.Class
+
+type PrerenderClientConstraint js m =
+ ( HasJS js m
+ , HasJS js (Performable m)
+ , MonadJSM m
+ , MonadJSM (Performable m)
+ , HasJSContext m
+ , HasJSContext (Performable m)
+ , MonadFix m
+ , MonadFix (Performable m)
+ , DomBuilderSpace m ~ GhcjsDomSpace
+ )
+
+class Prerender js m | m -> js where
+ prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))
+
+-- | Draw one widget when prerendering (e.g. server-side) and another when the
+-- widget is fully instantiated. In a given execution of this function, there
+-- will be exactly one invocation of exactly one of the arguments.
+prerender :: forall js m a. Prerender js m => m a -> (PrerenderClientConstraint js m => m a) -> m a
+prerender server client = case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
+ Nothing -> server
+ Just Dict -> client
+
+instance ( HasJS js m
+ , HasJS js (Performable m)
+ , HasJSContext m
+ , HasJSContext (Performable m)
+ , MonadJSM m
+ , MonadJSM (Performable m)
+ , MonadFix m
+ , MonadFix (Performable m)
+ , ReflexHost t
+ ) => Prerender js (ImmediateDomBuilderT t m) where
+ prerenderClientDict = Just Dict
+
+data NoJavaScript -- This type should never have a HasJS instance
+
+instance js ~ NoJavaScript => Prerender js (StaticDomBuilderT t m) where
+ prerenderClientDict = Nothing
+
+instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (DynamicWriterT t w m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (EventWriterT t w m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (ReaderT w m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (RequesterT t request response m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (QueryT t q m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
+
+instance Prerender js m => Prerender js (InputDisabledT m) where
+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
diff --git a/src/Reflex/Dom/Specializations.hs b/src/Reflex/Dom/Specializations.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Specializations.hs
@@ -0,0 +1,62 @@
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Reflex.Dom.Specializations where
+
+import Data.Text (Text)
+import Reflex.Spider
+import Reflex.Class
+import Foreign.JavaScript.TH
+import Reflex.PerformEvent.Base
+import Reflex.PostBuild.Base
+import Reflex.Requester.Base
+import Reflex.TriggerEvent.Base
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate
+import Data.Functor.Identity
+import Data.Functor.Compose
+import Data.IORef
+import GHCJS.DOM.Types (JSM)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+
+import qualified GHCJS.DOM.Element as DOM
+import qualified GHCJS.DOM.Types as DOM
+
+{-# SPECIALIZE makeElement :: forall er a. Text -> ElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) ((Element er GhcjsDomSpace (SpiderTimeline Global), a), DOM.Element) #-}
+
+{-# SPECIALIZE wrap :: forall er. RawElement GhcjsDomSpace -> RawElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (Element er GhcjsDomSpace (SpiderTimeline Global)) #-}
+
+{-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'.
+ ( (IntMap.Key -> (Event (SpiderTimeline Global) (), v) -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
+ -> IntMap (Event (SpiderTimeline Global) (), v)
+ -> Event (SpiderTimeline Global) (PatchIntMap (Event (SpiderTimeline Global) (), v))
+ -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
+ )
+ -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
+ -> IntMap v
+ -> Event (SpiderTimeline Global) (PatchIntMap v)
+ -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
+ #-}
+
+{-# SPECIALIZE append :: DOM.Node -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) () #-}
+
+{-# SPECIALIZE drawChildUpdate :: forall k v' a. ImmediateDomBuilderEnv (SpiderTimeline Global) -> (IORef (ChildReadyState k) -> JSM ()) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a) -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a) #-}
+
+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust' :: forall v v'. (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v') -> IntMap v -> Event (SpiderTimeline Global) (PatchIntMap v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) #-}
+
+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust :: forall v v'.
+ ( (IntMap.Key -> v -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
+ -> IntMap v
+ -> Event (SpiderTimeline Global) (PatchIntMap v)
+ -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event (SpiderTimeline Global) (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
+ )
+ -> (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt)))
+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ())
+ -> (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v')
+ -> IntMap v
+ -> Event (SpiderTimeline Global) (PatchIntMap v)
+ -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
+ #-}
diff --git a/src/Reflex/Dom/Time.hs b/src/Reflex/Dom/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Time.hs
@@ -0,0 +1,3 @@
+module Reflex.Dom.Time {-# DEPRECATED "Use Reflex.Time instead" #-} (module Reflex.Time) where
+
+import Reflex.Time
diff --git a/src/Reflex/Dom/WebSocket.hs b/src/Reflex/Dom/WebSocket.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/WebSocket.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE JavaScriptFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Reflex.Dom.WebSocket
+ ( module Reflex.Dom.WebSocket
+ , jsonDecode
+ ) where
+
+import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
+
+import Reflex.Class
+import Reflex.Dom.Class
+import Reflex.Dom.WebSocket.Foreign
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+import Reflex.TriggerEvent.Class
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Lens
+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
+import Control.Monad.IO.Class
+import Control.Monad.State
+import Data.Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (toStrict)
+import Data.Default
+import Data.IORef
+import Data.JSString.Text
+import Data.Maybe (isJust)
+import Data.Text
+import Data.Text.Encoding
+import Foreign.JavaScript.Utils (jsonDecode)
+import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
+import GHCJS.DOM.WebSocket (getReadyState)
+import GHCJS.Marshal
+import qualified Language.Javascript.JSaddle.Monad as JS (catch)
+
+data WebSocketConfig t a
+ = WebSocketConfig { _webSocketConfig_send :: Event t [a]
+ , _webSocketConfig_close :: Event t (Word, Text)
+ , _webSocketConfig_reconnect :: Bool
+ , _webSocketConfig_protocols :: [Text]
+ }
+
+instance Reflex t => Default (WebSocketConfig t a) where
+ def = WebSocketConfig never never True []
+
+type WebSocket t = RawWebSocket t ByteString
+
+data RawWebSocket t a
+ = RawWebSocket { _webSocket_recv :: Event t a
+ , _webSocket_open :: Event t ()
+ , _webSocket_error :: Event t () -- eror event does not carry any data and is always
+ -- followed by termination of the connection
+ -- for details see the close event
+ , _webSocket_close :: Event t ( Bool -- wasClean
+ , Word -- code
+ , Text -- reason
+ )
+ }
+
+webSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
+webSocket url config = webSocket' url config onBSMessage
+
+webSocket' :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b)
+webSocket' url config onRawMessage = do
+ wv <- fmap unJSContextSingleton askJSContext
+ (eRecv, onMessage) <- newTriggerEvent
+ currentSocketRef <- liftIO $ newIORef Nothing
+ (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
+ (eError, triggerEError) <- newTriggerEvent
+ (eClose, triggerEClose) <- newTriggerEvent
+ payloadQueue <- liftIO newTQueueIO
+ isOpen <- liftIO newEmptyTMVarIO
+ let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()
+ onError = triggerEError ()
+ onClose args = do
+ liftIO $ triggerEClose args
+ _ <- liftIO $ atomically $ tryTakeTMVar isOpen
+ liftIO $ writeIORef currentSocketRef Nothing
+ when (_webSocketConfig_reconnect config) $ forkJSM $ do
+ liftIO $ threadDelay 1000000
+ start
+ start = do
+ ws <- newWebSocket wv url (_webSocketConfig_protocols config) (onRawMessage >=> liftIO . onMessage) (liftIO onOpen) (liftIO onError) onClose
+ liftIO $ writeIORef currentSocketRef $ Just ws
+ return ()
+ performEvent_ . (liftJSM start <$) =<< getPostBuild
+ performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
+ liftIO $ atomically $ writeTQueue payloadQueue payload
+ performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftJSM $ do
+ mws <- liftIO $ readIORef currentSocketRef
+ case mws of
+ Nothing -> return ()
+ Just ws -> closeWebSocket ws (fromIntegral code) reason
+
+ ctx <- askJSM
+ _ <- liftIO $ forkIO $ forever $ do
+ payload <- atomically $ do
+ pl <- readTQueue payloadQueue
+ open <- tryReadTMVar isOpen
+ if isJust open then return pl else retry
+
+ mws <- liftIO $ readIORef currentSocketRef
+ success <- case mws of
+ Nothing -> return False
+ Just ws -> flip runJSM ctx $ do
+ rs <- getReadyState $ unWebSocket ws
+ if rs == 1
+ then (webSocketSend ws payload >> return True) `JS.catch` (\(_ :: SomeException) -> return False)
+ else return False
+ unless success $ atomically $ unGetTQueue payloadQueue payload
+ return $ RawWebSocket eRecv eOpen eError eClose
+
+textWebSocket :: (IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
+textWebSocket url cfg = webSocket' url cfg (either (return . decodeUtf8) fromJSValUnchecked)
+
+jsonWebSocket :: (ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
+jsonWebSocket url cfg = do
+ ws <- textWebSocket url $ cfg { _webSocketConfig_send = fmap (decodeUtf8 . toStrict . encode) <$> _webSocketConfig_send cfg }
+ return ws { _webSocket_recv = jsonDecode . textToJSString <$> _webSocket_recv ws }
+
+forkJSM :: JSM () -> JSM ()
+forkJSM a = do
+ jsm <- askJSM
+ void $ liftIO $ forkIO $ runJSM a jsm
+
+#ifdef USE_TEMPLATE_HASKELL
+makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
+makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket
+#else
+
+webSocketConfig_send :: Lens' (WebSocketConfig t a) (Event t [a])
+webSocketConfig_send f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig y x2 x3 x4) <$> f x1
+{-# INLINE webSocketConfig_send #-}
+
+webSocketConfig_close :: Lens' (WebSocketConfig t a) (Event t (Word, Text))
+webSocketConfig_close f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 y x3 x4) <$> f x2
+{-# INLINE webSocketConfig_close #-}
+
+webSocketConfig_reconnect :: Lens' (WebSocketConfig t a) Bool
+webSocketConfig_reconnect f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 y x4) <$> f x3
+{-# INLINE webSocketConfig_reconnect #-}
+
+webSocketConfig_protocols :: Lens' (WebSocketConfig t a) [Text]
+webSocketConfig_protocols f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 x3 y) <$> f x4
+{-# INLINE webSocketConfig_protocols #-}
+
+webSocket_recv :: Lens' (RawWebSocket t a) (Event t a)
+webSocket_recv f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket y x2 x3 x4) <$> f x1
+{-# INLINE webSocket_recv #-}
+
+webSocket_open :: Lens' (RawWebSocket t a) (Event t ())
+webSocket_open f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 y x3 x4) <$> f x2
+{-# INLINE webSocket_open #-}
+
+webSocket_error :: Lens' (RawWebSocket t a) (Event t ())
+webSocket_error f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 y x4) <$> f x3
+{-# INLINE webSocket_error #-}
+
+webSocket_close :: Lens' (RawWebSocket t a) (Event t (Bool, Word, Text))
+webSocket_close f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 x3 y) <$> f x4
+{-# INLINE webSocket_close #-}
+
+#endif
diff --git a/src/Reflex/Dom/WebSocket/Foreign.hs b/src/Reflex/Dom/WebSocket/Foreign.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/WebSocket/Foreign.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP #-}
+#ifdef ghcjs_HOST_OS
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE JavaScriptFFI #-}
+#endif
+{-# LANGUAGE LambdaCase #-}
+
+module Reflex.Dom.WebSocket.Foreign
+ ( module Reflex.Dom.WebSocket.Foreign
+ , JSVal
+ ) where
+
+import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
+
+import Data.Bifoldable
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text (Text)
+import Data.Text.Encoding
+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
+import GHCJS.DOM.CloseEvent
+import GHCJS.DOM.MessageEvent
+import GHCJS.DOM.Types (JSM, JSVal, liftJSM, fromJSValUnchecked, WebSocket(..))
+import qualified GHCJS.DOM.WebSocket as DOM
+import GHCJS.Foreign (JSType(..), jsTypeOf)
+import Language.Javascript.JSaddle (fun, eval, toJSVal, call)
+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)
+import Language.Javascript.JSaddle.Types (ghcjsPure)
+
+newtype JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
+
+class IsWebSocketMessage a where
+ webSocketSend :: JSWebSocket -> a -> JSM ()
+
+instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
+ webSocketSend jws = bitraverse_ (webSocketSend jws) (webSocketSend jws)
+
+-- Use binary websocket communication for ByteString
+-- Note: Binary websockets may not work correctly in IE 11 and below
+instance IsWebSocketMessage ByteString where
+ webSocketSend (JSWebSocket ws) bs = do
+ ab <- bsToArrayBuffer bs
+ DOM.send ws ab
+
+instance IsWebSocketMessage LBS.ByteString where
+ webSocketSend ws = webSocketSend ws . LBS.toStrict
+
+-- Use plaintext websocket communication for Text, and String
+instance IsWebSocketMessage Text where
+ webSocketSend (JSWebSocket ws) = DOM.sendString ws
+
+closeWebSocket :: JSWebSocket -> Word -> Text -> JSM ()
+closeWebSocket (JSWebSocket ws) code reason = DOM.close ws (Just code) (Just reason)
+
+newWebSocket
+ :: a
+ -> Text -- url
+ -> [Text] -- protocols
+ -> (Either ByteString JSVal -> JSM ()) -- onmessage
+ -> JSM () -- onopen
+ -> JSM () -- onerror
+ -> ((Bool, Word, Text) -> JSM ()) -- onclose
+ -> JSM JSWebSocket
+newWebSocket _ url protocols onMessage onOpen onError onClose = do
+ let onOpenWrapped = fun $ \_ _ _ -> onOpen
+ onErrorWrapped = fun $ \_ _ _ -> onError
+ onCloseWrapped = fun $ \_ _ (e:_) -> do
+ let e' = CloseEvent e
+ wasClean <- getWasClean e'
+ code <- getCode e'
+ reason <- getReason e'
+ liftJSM $ onClose (wasClean, code, reason)
+ onMessageWrapped = fun $ \_ _ (e:_) -> do
+ let e' = MessageEvent e
+ d <- getData e'
+ liftJSM $ ghcjsPure (jsTypeOf d) >>= \case
+ String -> onMessage $ Right d
+ _ -> do
+ ab <- mutableArrayBufferFromJSVal d
+ bsFromMutableArrayBuffer ab >>= onMessage . Left
+ newWS <- eval $ unlines
+ [ "(function(url, protos, open, error, close, message) {"
+ , " var ws = new window['WebSocket'](url, protos);"
+ , " ws['binaryType'] = 'arraybuffer';"
+ , " ws['addEventListener']('open', open);"
+ , " ws['addEventListener']('error', error);"
+ , " ws['addEventListener']('close', close);"
+ , " ws['addEventListener']('message', message);"
+ , " return ws;"
+ , "})"
+ ]
+ url' <- toJSVal url
+ protocols' <- toJSVal protocols
+ onOpen' <- toJSVal onOpenWrapped
+ onError' <- toJSVal onErrorWrapped
+ onClose' <- toJSVal onCloseWrapped
+ onMessage' <- toJSVal onMessageWrapped
+ ws <- call newWS newWS [url', protocols', onOpen', onError', onClose', onMessage']
+ return $ JSWebSocket $ WebSocket ws
+
+onBSMessage :: Either ByteString JSVal -> JSM ByteString
+onBSMessage = either return $ fmap encodeUtf8 . fromJSValUnchecked
diff --git a/src/Reflex/Dom/WebSocket/Query.hs b/src/Reflex/Dom/WebSocket/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/WebSocket/Query.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecursiveDo #-}
+module Reflex.Dom.WebSocket.Query (cropQueryT, runWebSocketQuery) where
+
+import Data.Default
+import Control.Monad.Fix
+import Data.Text (Text)
+import Data.Aeson
+import Reflex
+import Reflex.Dom.WebSocket
+import Foreign.JavaScript.TH
+import Data.Maybe
+import Language.Javascript.JSaddle.Types (MonadJSM)
+
+runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Additive q, Group q, Eq q)
+ => QueryT t q m a
+ -> Text -- ^ WebSocket url
+ -> m a
+runWebSocketQuery app url = do
+ postBuild <- getPostBuild
+ rec ws <- jsonWebSocket url $ def { _webSocketConfig_send = pure <$> updatedRequest }
+ (a, request) <- cropQueryT app $ fromMaybe mempty <$> _webSocket_recv ws
+ let updatedRequest = leftmost [updated request, tag (current request) postBuild]
+ return a
+
+cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Additive q, Group q, Eq q)
+ => QueryT t q m a
+ -> Event t (QueryResult q)
+ -> m (a, Dynamic t q)
+cropQueryT app result = do
+ rec (a, requestPatch) <- runQueryT app croppedResult
+ requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
+ croppedResult <- cropDyn requestUniq result
+ return (a, requestUniq)
+
+cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
+cropDyn q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)
diff --git a/src/Reflex/Dom/Widget.hs b/src/Reflex/Dom/Widget.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Widget.hs
@@ -0,0 +1,6 @@
+module Reflex.Dom.Widget (module X) where
+
+import Reflex.Dom.Widget.Basic as X
+import Reflex.Dom.Widget.Input as X
+import Reflex.Dom.Widget.Lazy as X
+import Reflex.Dom.Widget.Resize as X
diff --git a/src/Reflex/Dom/Widget/Basic.hs b/src/Reflex/Dom/Widget/Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Widget/Basic.hs
@@ -0,0 +1,349 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Reflex.Dom.Widget.Basic
+ (
+ -- * Displaying Values
+ text
+ , dynText
+ , display
+ , button
+ , dyn
+ , dyn_
+ , widgetHold
+ , widgetHold_
+
+ -- * Creating DOM Elements
+ , el
+ , elAttr
+ , elClass
+ , elDynAttr
+ , elDynClass
+ , elDynAttrNS
+
+ -- ** With Element Results
+ , el'
+ , elAttr'
+ , elClass'
+ , elDynAttr'
+ , elDynClass'
+ , elDynAttrNS'
+ , dynamicAttributesToModifyAttributes
+ , dynamicAttributesToModifyAttributesWithInitial
+
+ -- * Specific DOM Elements
+ , Link (..)
+ , linkClass
+ , link
+ , divClass
+ , dtdd
+ , blank
+
+ -- * Tables and Lists
+ , tableDynAttr
+ , tabDisplay
+
+ , HasAttributes (..)
+ , module Data.Map.Misc
+ , module Reflex.Collection
+ , module Reflex.Workflow
+ , partitionMapBySetLT
+ ) where
+
+import Reflex.Class
+import Reflex.Collection
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Class
+import Reflex.Dynamic
+import Reflex.Network
+import Reflex.PostBuild.Class
+import Reflex.Workflow
+
+import Control.Arrow
+import Control.Lens hiding (children, element)
+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
+import Data.Align
+import Data.Default
+import Data.Either
+import Data.Foldable
+import Data.Functor (void)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Map.Misc
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.These
+import Data.Traversable
+import Prelude hiding (mapM, mapM_, sequence, sequence_)
+
+-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.
+-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.
+-- No empty pieces will be included in the output.
+
+--TODO: This can probably be done more efficiently by dividing and conquering, re-using the structure of the Set instead of going through the Set linearally
+{-# DEPRECATED partitionMapBySetLT "This will be removed in future releases." #-}
+partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
+partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
+ where go :: [k] -> Map k v -> [(Either k (), Map k v)]
+ go [] m = if Map.null m
+ then []
+ else [(Right (), m)]
+ go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
+ geq = maybe id (Map.insert h) eq gt
+ in if Map.null lt
+ then go t geq
+ else (Left h, lt) : go t geq
+
+{-# INLINABLE text #-}
+text :: DomBuilder t m => Text -> m ()
+text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
+
+{-# INLINABLE dynText #-}
+dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
+dynText t = do
+ postBuild <- getPostBuild
+ void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
+ [ updated t
+ , tag (current t) postBuild
+ ]
+ notReadyUntil postBuild
+
+display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
+display = dynText . fmap (T.pack . show)
+
+button :: DomBuilder t m => Text -> m (Event t ())
+button t = do
+ (e, _) <- element "button" def $ text t
+ return $ domEvent Click e
+
+--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
+-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
+-- The returned Event of widget results occurs when the Dynamic does.
+-- Note: Often, the type @a@ is an 'Event', in which case the return value is an Event-of-Events that would typically be flattened (via 'switchHold').
+dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
+dyn = networkView
+
+-- | Like 'dyn' but discards result.
+dyn_ :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m ()
+dyn_ = void . dyn
+
+-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
+-- The returned Dynamic of widget results occurs when the Event does.
+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened (via 'switchDyn').
+widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
+widgetHold = networkHold
+
+-- | Like 'widgetHold' but discards result.
+widgetHold_ :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m ()
+widgetHold_ z = void . widgetHold z
+
+-- | Create a DOM element
+--
+-- >>> el "div" (text "Hello World")
+-- Hello World
+{-# INLINABLE el #-}
+el :: forall t m a. DomBuilder t m => Text -> m a -> m a
+el elementTag child = snd <$> el' elementTag child
+
+-- | Create a DOM element with attributes
+--
+-- >>> elAttr "a" ("href" =: "https://reflex-frp.org") (text "Reflex-FRP!")
+-- Reflex-FRP!
+{-# INLINABLE elAttr #-}
+elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
+elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
+
+-- | Create a DOM element with classes
+--
+-- >>> elClass "div" "row" (return ())
+--
+{-# INLINABLE elClass #-}
+elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
+elClass elementTag c child = snd <$> elClass' elementTag c child
+
+-- | Create a DOM element with Dynamic Attributes
+--
+-- >>> elClass "div" (constDyn ("class" =: "row")) (return ())
+--
+{-# INLINABLE elDynAttr #-}
+elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
+elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
+
+-- | Create a DOM element with a Dynamic Class
+--
+-- >>> elDynClass "div" (constDyn "row") (return ())
+--
+{-# INLINABLE elDynClass #-}
+elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
+elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
+
+-- | Create a DOM element and return the element
+--
+-- @
+-- do (e, _) <- el' "div" (text "Click")
+-- return $ domEvent Click e
+-- @
+{-# INLINABLE el' #-}
+el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+el' elementTag = element elementTag def
+
+-- | Create a DOM element with attributes and return the element
+{-# INLINABLE elAttr' #-}
+elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elAttr' elementTag attrs = element elementTag $ def
+ & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
+
+-- | Create a DOM element with a class and return the element
+{-# INLINABLE elClass' #-}
+elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elClass' elementTag c = elAttr' elementTag ("class" =: c)
+
+-- | Create a DOM element with Dynamic Attributes and return the element
+{-# INLINABLE elDynAttr' #-}
+elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynAttr' = elDynAttrNS' Nothing
+
+-- | Create a DOM element with a Dynamic class and return the element
+{-# INLINABLE elDynClass' #-}
+elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
+
+{-# INLINABLE elDynAttrNS' #-}
+elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynAttrNS' mns elementTag attrs child = do
+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
+ let cfg = def
+ & elementConfig_namespace .~ mns
+ & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs
+ result <- element elementTag cfg child
+ postBuild <- getPostBuild
+ notReadyUntil postBuild
+ return result
+
+{-# INLINABLE elDynAttrNS #-}
+elDynAttrNS :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m a
+elDynAttrNS mns elementTag attrs child = fmap snd $ elDynAttrNS' mns elementTag attrs child
+
+dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
+dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
+
+dynamicAttributesToModifyAttributesWithInitial :: (Ord k, PostBuild t m) => Map k Text -> Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
+dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
+ postBuild <- getPostBuild
+ let modificationsNeeded = flip push (align postBuild $ updated d) $ \x -> do
+ p <- case x of
+ This () -> do
+ new <- sample $ current d
+ return $ diffMap attrs0 new
+ These () new -> return $ diffMap attrs0 new
+ That new -> do
+ old <- sample $ current d
+ return $ diffMap old new
+ return $ if Map.null p then Nothing else Just p
+ return modificationsNeeded
+
+--------------------------------------------------------------------------------
+-- Copied and pasted from Reflex.Widget.Class
+--------------------------------------------------------------------------------
+
+{-
+schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
+
+elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
+elDynHtml' elementTag html = do
+ e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
+ wrapElement defaultDomEventHandler e
+
+elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
+elDynHtmlAttr' elementTag attrs html = do
+ e <- buildEmptyElement elementTag attrs
+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
+ wrapElement defaultDomEventHandler e
+-}
+
+newtype Link t
+ = Link { _link_clicked :: Event t ()
+ }
+
+-- | >>> linkClass "Click here" "link-class"
+-- > Click here
+linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
+linkClass s c = do
+ (l,_) <- elAttr' "a" ("class" =: c) $ text s
+ return $ Link $ domEvent Click l
+
+link :: DomBuilder t m => Text -> m (Link t)
+link s = linkClass s ""
+
+divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
+divClass = elClass "div"
+
+dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
+dtdd h w = do
+ el "dt" $ text h
+ el "dd" w
+
+blank :: forall m. Monad m => m ()
+blank = return ()
+
+-- | A widget to display a table with static columns and dynamic rows.
+tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
+ => Text -- ^ Class applied to element
+ -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
+ -> Dynamic t (Map k r) -- ^ Map from row key to row value
+ -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute element attributes from row key
+ -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
+tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $
+ elAttr "table" (Map.singleton "class" klass) $ do
+ el "thead" $ el "tr" $
+ mapM_ (\(h, _) -> el "th" $ text h) cols
+ el "tbody" $
+ listWithKey dRows (\k r -> do
+ dAttrs <- rowAttrs k
+ elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
+
+-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
+-- Creates a header bar containing a with one - per child; clicking a
- displays
+-- the corresponding child and hides all others.
+tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
+ => Text -- ^ Class applied to
element
+ -> Text -- ^ Class applied to currently active - element
+ -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
+ -> m ()
+tabDisplay ulClass activeClass tabItems = do
+ let t0 = listToMaybe $ Map.keys tabItems
+ rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
+ tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems
+ let eTabClicks :: Event t k = leftmost tabClicksList
+ fmap demux $ holdDyn t0 $ fmap Just eTabClicks
+ el "div" $ do
+ iforM_ tabItems $ \k (_, w) -> do
+ let isSelected = demuxed currentTab $ Just k
+ attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"
+ elDynAttr "div" attrs w
+ return ()
+ where
+ headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
+ headerBarLink x k isSelected = do
+ let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
+ elDynAttr "li" attrs $ do
+ a <- link x
+ return $ fmap (const k) (_link_clicked a)
+
+class HasAttributes a where
+ type Attrs a :: *
+ attributes :: Lens' a (Attrs a)
diff --git a/src/Reflex/Dom/Widget/Input.hs b/src/Reflex/Dom/Widget/Input.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Widget/Input.hs
@@ -0,0 +1,721 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where
+
+import Prelude
+
+import Control.Lens hiding (element, ix)
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import qualified Data.Bimap as Bimap
+import Data.Default
+import Data.Dependent.Map (DMap)
+import qualified Data.Dependent.Map as DMap
+import Data.Functor.Misc
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Semigroup
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified GHCJS.DOM.GlobalEventHandlers as Events
+import GHCJS.DOM.EventM (on)
+import qualified GHCJS.DOM.FileList as FileList
+import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
+import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
+import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)
+import qualified GHCJS.DOM.Types as DOM (HTMLElement(..), EventTarget(..))
+import Reflex.Class
+import Reflex.Collection
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Class
+import Reflex.Dom.Widget.Basic
+import Reflex.Dynamic
+import Reflex.PostBuild.Class
+import Reflex.TriggerEvent.Class
+import qualified Text.Read as T
+
+import qualified GHCJS.DOM.Event as Event
+import qualified GHCJS.DOM.HTMLInputElement as Input
+
+data TextInput t
+ = TextInput { _textInput_value :: Dynamic t Text
+ , _textInput_input :: Event t Text
+ , _textInput_keypress :: Event t Word
+ , _textInput_keydown :: Event t Word
+ , _textInput_keyup :: Event t Word
+ , _textInput_hasFocus :: Dynamic t Bool
+ , _textInput_builderElement :: InputElement EventResult GhcjsDomSpace t
+ }
+
+_textInput_element :: TextInput t -> HTMLInputElement
+_textInput_element = _inputElement_raw . _textInput_builderElement
+
+instance Reflex t => HasDomEvent t (TextInput t) en where
+ type DomEventType (TextInput t) en = DomEventType (InputElement EventResult GhcjsDomSpace t) en
+ domEvent en = domEvent en . _textInput_builderElement
+
+data TextInputConfig t
+ = TextInputConfig { _textInputConfig_inputType :: Text
+ , _textInputConfig_initialValue :: Text
+ , _textInputConfig_setValue :: Event t Text
+ , _textInputConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (TextInputConfig t) where
+ {-# INLINABLE def #-}
+ def = TextInputConfig { _textInputConfig_inputType = "text"
+ , _textInputConfig_initialValue = ""
+ , _textInputConfig_setValue = never
+ , _textInputConfig_attributes = constDyn mempty
+ }
+
+-- | Create an input whose value is a string. By default, the "type" attribute is set to "text", but it can be changed using the _textInputConfig_inputType field. Note that only types for which the value is always a string will work - types whose value may be null will not work properly with this widget.
+{-# INLINABLE textInput #-}
+textInput :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => TextInputConfig t -> m (TextInput t)
+textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
+ modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.insert "type" inputType) dAttrs
+ i <- inputElement $ def
+ & inputElementConfig_initialValue .~ initial
+ & inputElementConfig_setValue .~ eSetValue
+ & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ return $ TextInput
+ { _textInput_value = _inputElement_value i
+ , _textInput_input = _inputElement_input i
+ , _textInput_keypress = domEvent Keypress i
+ , _textInput_keydown = domEvent Keydown i
+ , _textInput_keyup = domEvent Keyup i
+ , _textInput_hasFocus = _inputElement_hasFocus i
+ , _textInput_builderElement = i
+ }
+
+{-# INLINE textInputGetEnter #-}
+{-# DEPRECATED textInputGetEnter "Use 'keypress Enter' instead" #-}
+textInputGetEnter :: Reflex t => TextInput t -> Event t ()
+textInputGetEnter = keypress Enter
+
+{-# INLINABLE keypress #-}
+keypress :: (Reflex t, HasDomEvent t e 'KeypressTag, DomEventType e 'KeypressTag ~ Word) => Key -> e -> Event t ()
+keypress key = fmapMaybe (\n -> guard $ keyCodeLookup (fromIntegral n) == key) . domEvent Keypress
+
+{-# INLINABLE keydown #-}
+keydown :: (Reflex t, HasDomEvent t e 'KeydownTag, DomEventType e 'KeydownTag ~ Word) => Key -> e -> Event t ()
+keydown key = fmapMaybe (\n -> guard $ keyCodeLookup (fromIntegral n) == key) . domEvent Keydown
+
+{-# INLINABLE keyup #-}
+keyup :: (Reflex t, HasDomEvent t e 'KeyupTag, DomEventType e 'KeyupTag ~ Word) => Key -> e -> Event t ()
+keyup key = fmapMaybe (\n -> guard $ keyCodeLookup (fromIntegral n) == key) . domEvent Keyup
+
+data RangeInputConfig t
+ = RangeInputConfig { _rangeInputConfig_initialValue :: Float
+ , _rangeInputConfig_setValue :: Event t Float
+ , _rangeInputConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (RangeInputConfig t) where
+ {-# INLINABLE def #-}
+ def = RangeInputConfig { _rangeInputConfig_initialValue = 0
+ , _rangeInputConfig_setValue = never
+ , _rangeInputConfig_attributes = constDyn mempty
+ }
+
+data RangeInput t
+ = RangeInput { _rangeInput_value :: Dynamic t Float
+ , _rangeInput_input :: Event t Float
+ , _rangeInput_mouseup :: Event t (Int, Int)
+ , _rangeInput_hasFocus :: Dynamic t Bool
+ , _rangeInput_element :: HTMLInputElement
+ }
+
+-- | Create an input whose value is a float.
+-- https://www.w3.org/wiki/HTML/Elements/input/range
+{-# INLINABLE rangeInput #-}
+rangeInput :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => RangeInputConfig t -> m (RangeInput t)
+rangeInput (RangeInputConfig initial eSetValue dAttrs) = do
+ modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.insert "type" "range") dAttrs
+ i <- inputElement $ def
+ & inputElementConfig_initialValue .~ (T.pack . show $ initial)
+ & inputElementConfig_setValue .~ (T.pack . show <$> eSetValue)
+ & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ return $ RangeInput
+ { _rangeInput_value = read . T.unpack <$> _inputElement_value i
+ , _rangeInput_input = read . T.unpack <$> _inputElement_input i
+ , _rangeInput_mouseup = domEvent Mouseup i
+ , _rangeInput_hasFocus = _inputElement_hasFocus i
+ , _rangeInput_element = _inputElement_raw i
+ }
+
+data TextAreaConfig t
+ = TextAreaConfig { _textAreaConfig_initialValue :: Text
+ , _textAreaConfig_setValue :: Event t Text
+ , _textAreaConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (TextAreaConfig t) where
+ {-# INLINABLE def #-}
+ def = TextAreaConfig { _textAreaConfig_initialValue = ""
+ , _textAreaConfig_setValue = never
+ , _textAreaConfig_attributes = constDyn mempty
+ }
+
+data TextArea t
+ = TextArea { _textArea_value :: Dynamic t Text
+ , _textArea_input :: Event t Text
+ , _textArea_hasFocus :: Dynamic t Bool
+ , _textArea_keypress :: Event t Word
+ , _textArea_element :: HTMLTextAreaElement
+ }
+
+{-# INLINABLE textArea #-}
+textArea :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => TextAreaConfig t -> m (TextArea t)
+textArea (TextAreaConfig initial eSet attrs) = do
+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
+ i <- textAreaElement $ def
+ & textAreaElementConfig_initialValue .~ initial
+ & textAreaElementConfig_setValue .~ eSet
+ & textAreaElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ return $ TextArea
+ { _textArea_value = _textAreaElement_value i
+ , _textArea_input = _textAreaElement_input i
+ , _textArea_keypress = domEvent Keypress i
+ , _textArea_hasFocus = _textAreaElement_hasFocus i
+ , _textArea_element = _textAreaElement_raw i
+ }
+
+data CheckboxConfig t
+ = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
+ , _checkboxConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (CheckboxConfig t) where
+ {-# INLINABLE def #-}
+ def = CheckboxConfig { _checkboxConfig_setValue = never
+ , _checkboxConfig_attributes = constDyn mempty
+ }
+
+data Checkbox t
+ = Checkbox { _checkbox_value :: Dynamic t Bool
+ , _checkbox_change :: Event t Bool
+ }
+
+-- | Create an editable checkbox
+-- Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored
+{-# INLINABLE checkbox #-}
+checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t)
+checkbox checked config = do
+ let permanentAttrs = "type" =: "checkbox"
+ dAttrs = Map.delete "checked" . Map.union permanentAttrs <$> _checkboxConfig_attributes config
+ modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs
+ i <- inputElement $ def
+ & inputElementConfig_initialChecked .~ checked
+ & inputElementConfig_setChecked .~ _checkboxConfig_setValue config
+ & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys (AttributeName Nothing) permanentAttrs
+ & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ return $ Checkbox
+ { _checkbox_value = _inputElement_checked i
+ , _checkbox_change = _inputElement_checkedChange i
+ }
+
+type family CheckboxViewEventResultType (en :: EventTag) :: * where
+ CheckboxViewEventResultType 'ClickTag = Bool
+ CheckboxViewEventResultType t = EventResultType t
+
+regularToCheckboxViewEventType :: EventName t -> EventResultType t -> CheckboxViewEventResultType t
+regularToCheckboxViewEventType en r = case en of
+ Click -> error "regularToCheckboxViewEventType: EventName Click should never be encountered"
+ Abort -> r
+ Blur -> r
+ Change -> r
+ Contextmenu -> r
+ Dblclick -> r
+ Drag -> r
+ Dragend -> r
+ Dragenter -> r
+ Dragleave -> r
+ Dragover -> r
+ Dragstart -> r
+ Drop -> r
+ Error -> r
+ Focus -> r
+ Input -> r
+ Invalid -> r
+ Keydown -> r
+ Keypress -> r
+ Keyup -> r
+ Load -> r
+ Mousedown -> r
+ Mouseenter -> r
+ Mouseleave -> r
+ Mousemove -> r
+ Mouseout -> r
+ Mouseover -> r
+ Mouseup -> r
+ Mousewheel -> r
+ Scroll -> r
+ Select -> r
+ Submit -> r
+ Wheel -> r
+ Beforecut -> r
+ Cut -> r
+ Beforecopy -> r
+ Copy -> r
+ Beforepaste -> r
+ Paste -> r
+ Reset -> r
+ Search -> r
+ Selectstart -> r
+ Touchstart -> r
+ Touchmove -> r
+ Touchend -> r
+ Touchcancel -> r
+
+newtype CheckboxViewEventResult en = CheckboxViewEventResult { unCheckboxViewEventResult :: CheckboxViewEventResultType en }
+
+--TODO
+{-# INLINABLE checkboxView #-}
+checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m, MonadHold t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool)
+checkboxView dAttrs dValue = do
+ let permanentAttrs = "type" =: "checkbox"
+ modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.union permanentAttrs) dAttrs
+ postBuild <- getPostBuild
+ let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
+ filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
+ t <- Event.getTargetUnchecked evt
+ b <- Input.getChecked $ uncheckedCastTo Input.HTMLInputElement t
+ return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
+ elementConfig :: ElementConfig CheckboxViewEventResult t (DomBuilderSpace m)
+ elementConfig = (def :: ElementConfig EventResult t (DomBuilderSpace m))
+ { _elementConfig_modifyAttributes = Just $ fmap mapKeysToAttributeName modifyAttrs
+ , _elementConfig_initialAttributes = Map.mapKeys (AttributeName Nothing) permanentAttrs
+ , _elementConfig_eventSpec = GhcjsEventSpec
+ { _ghcjsEventSpec_filters = filters
+ , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> case en of
+ Click -> error "impossible"
+ _ -> do
+ e :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt
+ let myElement = uncheckedCastTo DOM.HTMLElement e
+ mr <- runReaderT (defaultDomEventHandler myElement en) evt
+ return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
+ }
+ }
+ inputElementConfig :: InputElementConfig CheckboxViewEventResult t (DomBuilderSpace m)
+ inputElementConfig = (def :: InputElementConfig EventResult t (DomBuilderSpace m))
+ & inputElementConfig_setChecked .~ leftmost [updated dValue, tag (current dValue) postBuild]
+ & inputElementConfig_elementConfig .~ elementConfig
+ i <- inputElement inputElementConfig
+ return $ unCheckboxViewEventResult <$> select (_element_events $ _inputElement_element i) (WrapArg Click)
+
+data FileInput d t
+ = FileInput { _fileInput_value :: Dynamic t [File]
+ , _fileInput_element :: RawInputElement d
+ }
+
+newtype FileInputConfig t
+ = FileInputConfig { _fileInputConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (FileInputConfig t) where
+ def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
+ }
+
+fileInput :: forall t m. (MonadIO m, MonadJSM m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)
+ => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
+fileInput config = do
+ let insertType = Map.insert "type" "file"
+ dAttrs = insertType <$> _fileInputConfig_attributes config
+ modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs
+ let filters = DMap.singleton Change . GhcjsEventFilter $ \_ -> do
+ return . (,) mempty $ return . Just $ EventResult ()
+ elCfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
+ & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ & elementConfig_eventSpec . ghcjsEventSpec_filters .~ filters
+ cfg = (def :: InputElementConfig EventResult t (DomBuilderSpace m)) & inputElementConfig_elementConfig .~ elCfg
+ input <- inputElement cfg
+ return $ FileInput
+ { _fileInput_value = _inputElement_files input
+ , _fileInput_element = _inputElement_raw input
+ }
+
+data Dropdown t k
+ = Dropdown { _dropdown_value :: Dynamic t k
+ , _dropdown_change :: Event t k
+ }
+
+data DropdownConfig t k
+ = DropdownConfig { _dropdownConfig_setValue :: Event t k
+ , _dropdownConfig_attributes :: Dynamic t (Map Text Text)
+ }
+
+instance Reflex t => Default (DropdownConfig t k) where
+ def = DropdownConfig { _dropdownConfig_setValue = never
+ , _dropdownConfig_attributes = constDyn mempty
+ }
+
+type family DropdownViewEventResultType (en :: EventTag) :: * where
+ DropdownViewEventResultType 'ChangeTag = Text
+ DropdownViewEventResultType t = EventResultType t
+
+newtype DropdownViewEventResult en = DropdownViewEventResult { unDropdownViewEventResult :: DropdownViewEventResultType en }
+
+regularToDropdownViewEventType :: EventName t -> EventResultType t -> DropdownViewEventResultType t
+regularToDropdownViewEventType en r = case en of
+ Change -> error "regularToDropdownViewEventType: EventName Change should never be encountered"
+ Abort -> r
+ Blur -> r
+ Click -> r
+ Contextmenu -> r
+ Dblclick -> r
+ Drag -> r
+ Dragend -> r
+ Dragenter -> r
+ Dragleave -> r
+ Dragover -> r
+ Dragstart -> r
+ Drop -> r
+ Error -> r
+ Focus -> r
+ Input -> r
+ Invalid -> r
+ Keydown -> r
+ Keypress -> r
+ Keyup -> r
+ Load -> r
+ Mousedown -> r
+ Mouseenter -> r
+ Mouseleave -> r
+ Mousemove -> r
+ Mouseout -> r
+ Mouseover -> r
+ Mouseup -> r
+ Mousewheel -> r
+ Scroll -> r
+ Select -> r
+ Submit -> r
+ Wheel -> r
+ Beforecut -> r
+ Cut -> r
+ Beforecopy -> r
+ Copy -> r
+ Beforepaste -> r
+ Paste -> r
+ Reset -> r
+ Search -> r
+ Selectstart -> r
+ Touchstart -> r
+ Touchmove -> r
+ Touchend -> r
+ Touchcancel -> r
+
+--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
+-- | Create a dropdown box
+-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text
+dropdown :: forall k t m. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m, Ord k) => k -> Dynamic t (Map k Text) -> DropdownConfig t k -> m (Dropdown t k)
+dropdown k0 options (DropdownConfig setK attrs) = do
+ optionsWithAddedKeys <- fmap (zipDynWith Map.union options) $ foldDyn Map.union (k0 =: "") $ fmap (=: "") setK
+ defaultKey <- holdDyn k0 setK
+ let (indexedOptions, ixKeys) = splitDynPure $ ffor optionsWithAddedKeys $ \os ->
+ let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
+ in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)
+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
+ let cfg = def
+ & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
+ & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)
+ (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
+ let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
+ elDynAttr "option" optionAttrs $ dynText v
+ let lookupSelected ks v = do
+ key <- T.readMaybe $ T.unpack v
+ Bimap.lookup key ks
+ let eChange = attachPromptlyDynWith lookupSelected ixKeys $ _selectElement_change eRaw
+ let readKey keys mk = fromMaybe k0 $ do
+ k <- mk
+ guard $ Bimap.memberR k keys
+ return k
+ dValue <- fmap (zipDynWith readKey ixKeys) $ holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]
+ return $ Dropdown dValue (attachPromptlyDynWith readKey ixKeys eChange)
+
+#ifdef USE_TEMPLATE_HASKELL
+concat <$> mapM makeLenses
+ [ ''TextAreaConfig
+ , ''TextArea
+ , ''TextInputConfig
+ , ''TextInput
+ , ''RangeInputConfig
+ , ''RangeInput
+ , ''FileInputConfig
+ , ''FileInput
+ , ''DropdownConfig
+ , ''Dropdown
+ , ''CheckboxConfig
+ , ''Checkbox
+ ]
+#else
+textAreaConfig_attributes :: Lens' (TextAreaConfig t) (Dynamic t (Map Text Text))
+textAreaConfig_attributes f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig x1 x2 y) <$> f x3
+{-# INLINE textAreaConfig_attributes #-}
+textAreaConfig_initialValue :: Lens' (TextAreaConfig t) Text
+textAreaConfig_initialValue f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig y x2 x3) <$> f x1
+{-# INLINE textAreaConfig_initialValue #-}
+textAreaConfig_setValue :: Lens' (TextAreaConfig t) (Event t Text)
+textAreaConfig_setValue f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig x1 y x3) <$> f x2
+{-# INLINE textAreaConfig_setValue #-}
+textArea_element :: Lens' (TextArea t) HTMLTextAreaElement
+textArea_element f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 x3 x4 y) <$> f x5
+{-# INLINE textArea_element #-}
+textArea_hasFocus :: Lens' (TextArea t) (Dynamic t Bool)
+textArea_hasFocus f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 y x4 x5) <$> f x3
+{-# INLINE textArea_hasFocus #-}
+textArea_input :: Lens' (TextArea t) (Event t Text)
+textArea_input f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 y x3 x4 x5) <$> f x2
+{-# INLINE textArea_input #-}
+textArea_keypress :: Lens' (TextArea t) (Event t Word)
+textArea_keypress f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 x3 y x5) <$> f x4
+{-# INLINE textArea_keypress #-}
+textArea_value :: Lens' (TextArea t) (Dynamic t Text)
+textArea_value f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea y x2 x3 x4 x5) <$> f x1
+{-# INLINE textArea_value #-}
+textInputConfig_attributes :: Lens' (TextInputConfig t) (Dynamic t (Map Text Text))
+textInputConfig_attributes f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 x2 x3 y) <$> f x4
+{-# INLINE textInputConfig_attributes #-}
+textInputConfig_initialValue :: Lens' (TextInputConfig t) Text
+textInputConfig_initialValue f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 y x3 x4) <$> f x2
+{-# INLINE textInputConfig_initialValue #-}
+textInputConfig_inputType :: Lens' (TextInputConfig t) Text
+textInputConfig_inputType f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig y x2 x3 x4) <$> f x1
+{-# INLINE textInputConfig_inputType #-}
+textInputConfig_setValue :: Lens' (TextInputConfig t) (Event t Text)
+textInputConfig_setValue f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 x2 y x4) <$> f x3
+{-# INLINE textInputConfig_setValue #-}
+textInput_builderElement :: Lens' (TextInput t) (InputElement EventResult GhcjsDomSpace t)
+textInput_builderElement f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 x5 x6 y) <$> f x7
+{-# INLINE textInput_builderElement #-}
+textInput_hasFocus :: Lens' (TextInput t) (Dynamic t Bool)
+textInput_hasFocus f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 x5 y x7) <$> f x6
+{-# INLINE textInput_hasFocus #-}
+textInput_input :: Lens' (TextInput t) (Event t Text)
+textInput_input f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 y x3 x4 x5 x6 x7) <$> f x2
+{-# INLINE textInput_input #-}
+textInput_keydown :: Lens' (TextInput t) (Event t Word)
+textInput_keydown f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 y x5 x6 x7) <$> f x4
+{-# INLINE textInput_keydown #-}
+textInput_keypress :: Lens' (TextInput t) (Event t Word)
+textInput_keypress f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 y x4 x5 x6 x7) <$> f x3
+{-# INLINE textInput_keypress #-}
+textInput_keyup :: Lens' (TextInput t) (Event t Word)
+textInput_keyup f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 y x6 x7) <$> f x5
+{-# INLINE textInput_keyup #-}
+textInput_value :: Lens' (TextInput t) (Dynamic t Text)
+textInput_value f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput y x2 x3 x4 x5 x6 x7) <$> f x1
+{-# INLINE textInput_value #-}
+rangeInputConfig_attributes :: Lens' (RangeInputConfig t) (Dynamic t (Map Text Text))
+rangeInputConfig_attributes f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig x1 x2 y) <$> f x3
+{-# INLINE rangeInputConfig_attributes #-}
+rangeInputConfig_initialValue :: Lens' (RangeInputConfig t) Float
+rangeInputConfig_initialValue f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig y x2 x3) <$> f x1
+{-# INLINE rangeInputConfig_initialValue #-}
+rangeInputConfig_setValue :: Lens' (RangeInputConfig t) (Event t Float)
+rangeInputConfig_setValue f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig x1 y x3) <$> f x2
+{-# INLINE rangeInputConfig_setValue #-}
+rangeInput_element :: Lens' (RangeInput t) HTMLInputElement
+rangeInput_element f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 x3 x4 y) <$> f x5
+{-# INLINE rangeInput_element #-}
+rangeInput_hasFocus :: Lens' (RangeInput t) (Dynamic t Bool)
+rangeInput_hasFocus f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 x3 y x5) <$> f x4
+{-# INLINE rangeInput_hasFocus #-}
+rangeInput_input :: Lens' (RangeInput t) (Event t Float)
+rangeInput_input f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 y x3 x4 x5) <$> f x2
+{-# INLINE rangeInput_input #-}
+rangeInput_mouseup :: Lens' (RangeInput t) (Event t (Int, Int))
+rangeInput_mouseup f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 y x4 x5) <$> f x3
+{-# INLINE rangeInput_mouseup #-}
+rangeInput_value :: Lens' (RangeInput t) (Dynamic t Float)
+rangeInput_value f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput y x2 x3 x4 x5) <$> f x1
+{-# INLINE rangeInput_value #-}
+fileInputConfig_attributes :: Iso
+ (FileInputConfig t1)
+ (FileInputConfig t2)
+ (Dynamic t1 (Map Text Text))
+ (Dynamic t2 (Map Text Text))
+fileInputConfig_attributes = iso (\(FileInputConfig x) -> x) FileInputConfig
+{-# INLINE fileInputConfig_attributes #-}
+fileInput_element :: Lens
+ (FileInput d1 t)
+ (FileInput d2 t)
+ (RawInputElement d1)
+ (RawInputElement d2)
+fileInput_element f (FileInput x1 x2) = (\y -> FileInput x1 y) <$> f x2
+{-# INLINE fileInput_element #-}
+fileInput_value :: Lens
+ (FileInput d t1)
+ (FileInput d t2)
+ (Dynamic t1 [File])
+ (Dynamic t2 [File])
+fileInput_value f (FileInput x1 x2) = (\y -> FileInput y x2) <$> f x1
+{-# INLINE fileInput_value #-}
+dropdownConfig_attributes :: Lens' (DropdownConfig t k) (Dynamic t (Map Text Text))
+dropdownConfig_attributes f (DropdownConfig x1 x2) = (\y -> DropdownConfig x1 y) <$> f x2
+{-# INLINE dropdownConfig_attributes #-}
+dropdownConfig_setValue :: Lens
+ (DropdownConfig t k1)
+ (DropdownConfig t k2)
+ (Event t k1)
+ (Event t k2)
+dropdownConfig_setValue f (DropdownConfig x1 x2) = (\y -> DropdownConfig y x2) <$> f x1
+{-# INLINE dropdownConfig_setValue #-}
+dropdown_change :: Lens' (Dropdown t k) (Event t k)
+dropdown_change f (Dropdown x1 x2) = (\y -> Dropdown x1 y) <$> f x2
+{-# INLINE dropdown_change #-}
+dropdown_value :: Lens' (Dropdown t k) (Dynamic t k)
+dropdown_value f (Dropdown x1 x2) = (\y -> Dropdown y x2) <$> f x1
+{-# INLINE dropdown_value #-}
+checkboxConfig_attributes :: Lens' (CheckboxConfig t) (Dynamic t (Map Text Text))
+checkboxConfig_attributes f (CheckboxConfig x1 x2) = (\y -> CheckboxConfig x1 y) <$> f x2
+{-# INLINE checkboxConfig_attributes #-}
+checkboxConfig_setValue :: Lens' (CheckboxConfig t) (Event t Bool)
+checkboxConfig_setValue f (CheckboxConfig x1 x2) = (\y -> CheckboxConfig y x2) <$> f x1
+{-# INLINE checkboxConfig_setValue #-}
+checkbox_change :: Lens' (Checkbox t) (Event t Bool)
+checkbox_change f (Checkbox x1 x2) = (\y -> Checkbox x1 y) <$> f x2
+{-# INLINE checkbox_change #-}
+checkbox_value :: Lens' (Checkbox t) (Dynamic t Bool)
+checkbox_value f (Checkbox x1 x2) = (\y -> Checkbox y x2) <$> f x1
+{-# INLINE checkbox_value #-}
+#endif
+
+instance HasAttributes (TextAreaConfig t) where
+ type Attrs (TextAreaConfig t) = Dynamic t (Map Text Text)
+ attributes = textAreaConfig_attributes
+
+instance HasAttributes (TextInputConfig t) where
+ type Attrs (TextInputConfig t) = Dynamic t (Map Text Text)
+ attributes = textInputConfig_attributes
+
+instance HasAttributes (RangeInputConfig t) where
+ type Attrs (RangeInputConfig t) = Dynamic t (Map Text Text)
+ attributes = rangeInputConfig_attributes
+
+instance HasAttributes (DropdownConfig t k) where
+ type Attrs (DropdownConfig t k) = Dynamic t (Map Text Text)
+ attributes = dropdownConfig_attributes
+
+instance HasAttributes (CheckboxConfig t) where
+ type Attrs (CheckboxConfig t) = Dynamic t (Map Text Text)
+ attributes = checkboxConfig_attributes
+
+instance HasAttributes (FileInputConfig t) where
+ type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)
+ attributes = fileInputConfig_attributes
+
+class HasSetValue a where
+ type SetValue a :: *
+ setValue :: Lens' a (SetValue a)
+
+instance HasSetValue (TextAreaConfig t) where
+ type SetValue (TextAreaConfig t) = Event t Text
+ setValue = textAreaConfig_setValue
+
+instance HasSetValue (TextInputConfig t) where
+ type SetValue (TextInputConfig t) = Event t Text
+ setValue = textInputConfig_setValue
+
+instance HasSetValue (RangeInputConfig t) where
+ type SetValue (RangeInputConfig t) = Event t Float
+ setValue = rangeInputConfig_setValue
+
+instance HasSetValue (DropdownConfig t k) where
+ type SetValue (DropdownConfig t k) = Event t k
+ setValue = dropdownConfig_setValue
+
+instance HasSetValue (CheckboxConfig t) where
+ type SetValue (CheckboxConfig t) = Event t Bool
+ setValue = checkboxConfig_setValue
+
+class HasValue a where
+ type Value a :: *
+ value :: a -> Value a
+
+instance HasValue (InputElement er d t) where
+ type Value (InputElement er d t) = Dynamic t Text
+ value = _inputElement_value
+
+instance HasValue (TextAreaElement er d t) where
+ type Value (TextAreaElement er d t) = Dynamic t Text
+ value = _textAreaElement_value
+
+instance HasValue (TextArea t) where
+ type Value (TextArea t) = Dynamic t Text
+ value = _textArea_value
+
+instance HasValue (TextInput t) where
+ type Value (TextInput t) = Dynamic t Text
+ value = _textInput_value
+
+instance HasValue (RangeInput t) where
+ type Value (RangeInput t) = Dynamic t Float
+ value = _rangeInput_value
+
+instance HasValue (FileInput d t) where
+ type Value (FileInput d t) = Dynamic t [File]
+ value = _fileInput_value
+
+instance HasValue (Dropdown t k) where
+ type Value (Dropdown t k) = Dynamic t k
+ value = _dropdown_value
+
+instance HasValue (Checkbox t) where
+ type Value (Checkbox t) = Dynamic t Bool
+ value = _checkbox_value
+
+{-
+type family Controller sm t a where
+ Controller Edit t a = (a, Event t a) -- Initial value and setter
+ Controller View t a = Dynamic t a -- Value (always)
+
+type family Output sm t a where
+ Output Edit t a = Dynamic t a -- Value (always)
+ Output View t a = Event t a -- Requested changes
+
+data CheckboxConfig sm t
+ = CheckboxConfig { _checkbox_input :: Controller sm t Bool
+ , _checkbox_attributes :: Attributes
+ }
+
+instance Reflex t => Default (CheckboxConfig Edit t) where
+ def = CheckboxConfig (False, never) mempty
+
+data Checkbox sm t
+ = Checkbox { _checkbox_output :: Output sm t Bool
+ }
+
+data StateMode = Edit | View
+
+--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
+data StateModeWitness (sm :: StateMode) where
+ EditWitness :: StateModeWitness Edit
+ ViewWitness :: StateModeWitness View
+
+class HasStateModeWitness (sm :: StateMode) where
+ stateModeWitness :: StateModeWitness sm
+
+instance HasStateModeWitness Edit where
+ stateModeWitness = EditWitness
+
+instance HasStateModeWitness View where
+ stateModeWitness = ViewWitness
+-}
diff --git a/src/Reflex/Dom/Widget/Lazy.hs b/src/Reflex/Dom/Widget/Lazy.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Widget/Lazy.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Reflex.Dom.Widget.Lazy where
+
+import Reflex.Class
+import Reflex.Collection
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Class
+import Reflex.Dom.Widget.Basic
+import Reflex.Dynamic
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+
+import Control.Monad.Fix
+import Data.Fixed
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHCJS.DOM.Element
+import GHCJS.DOM.Types (MonadJSM)
+
+-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
+virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
+ => Dynamic t Int -- ^ The height of the visible region in pixels
+ -> Int -- ^ The height of each row in pixels
+ -> Dynamic t Int -- ^ The total number of items
+ -> Int -- ^ The index of the row to scroll to on initialization
+ -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index.
+ -> Text -- ^ The element tag for the list
+ -> Dynamic t (Map Text Text) -- ^ The attributes of the list
+ -> Text -- ^ The element tag for a row
+ -> Dynamic t (Map Text Text) -- ^ The attributes of each row
+ -> (k -> Dynamic t (Maybe v) -> Dynamic t Bool -> m ()) -- ^ The row child element builder
+ -> Dynamic t (Map k v) -- ^ The 'Map' of items
+ -> (Int -> k) -- ^ Index to Key function, used to determine position of Map elements
+ -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key
+virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items indexToKey = do
+ let totalHeightStyle = fmap (toHeightStyle . (*) rowPx) maxIndex
+ containerStyle = fmap toContainer heightPx
+ viewportStyle = fmap toViewport heightPx
+ rec (container, sel) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ do
+ let currentTop = fmap (listWrapperStyle . fst) window
+ (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ selectViewListWithKey_ selected itemsInWindow $ \k v s -> do
+ (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v s
+ return $ fmap (const k) (domEvent Click li)
+ return lis
+ selected <- holdDyn (indexToKey i0) sel
+ pb <- getPostBuild
+ scrollPosition <- holdDyn 0 $ leftmost [ round <$> domEvent Scroll container
+ , fmap (const (i0 * rowPx)) pb
+ ]
+ let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
+ itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
+ postBuild <- getPostBuild
+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i ->
+ setScrollTop (_element_raw container) (i * rowPx)
+ let indexAndLength = fmap snd window
+ return (indexAndLength, sel)
+ where
+ toStyleAttr m = "style" =: Map.foldrWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m
+ toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
+ "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")
+ toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")
+ listWrapperStyle t = toStyleAttr $ "position" =: "relative" <>
+ "top" =: (T.pack (show t) <> "px")
+ toHeightStyle h = toStyleAttr ("height" =: (T.pack (show h) <> "px") <> "overflow" =: "hidden")
+ tagWrapper elTag attrs attrsOverride c = do
+ let attrs' = zipDynWith Map.union attrsOverride attrs
+ elDynAttr' elTag attrs' c
+ findWindow sizeIncrement windowSize startingPosition =
+ let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement
+ topPx = startingPosition - topOffsetPx
+ numItems = windowSize `div` sizeIncrement + 1
+ preItems = min startingIndex numItems
+ in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
+
+virtualList :: forall t m k v a. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
+ => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
+ -> Int -- ^ The fixed height of each row in pixels
+ -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items
+ -> Int -- ^ The index of the row to scroll to on initialization
+ -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index.
+ -> (k -> Int) -- ^ Key to Index function, used to position items.
+ -> Map k v -- ^ The initial 'Map' of items
+ -> Event t (Map k (Maybe v)) -- ^ The update 'Event'. Nothing values are removed from the list and Just values are added or updated.
+ -> (k -> v -> Event t v -> m a) -- ^ The row child element builder.
+ -> m (Dynamic t (Int, Int), Dynamic t (Map k a)) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and the 'Dynamic' list result
+virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do
+ let virtualH = mkVirtualHeight <$> maxIndex
+ containerStyle = fmap mkContainer heightPx
+ viewportStyle = fmap mkViewport heightPx
+ pb <- getPostBuild
+ rec (viewport, result) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ elDynAttr "div" virtualH $
+ listWithKeyShallowDiff items0 itemsUpdate $ \k v e -> elAttr "div" (mkRow k) $ itemBuilder k v e
+ scrollPosition <- holdDyn 0 $ leftmost [ round <$> domEvent Scroll viewport
+ , fmap (const (i0 * rowPx)) pb
+ ]
+ let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i ->
+ setScrollTop (_element_raw viewport) (i * rowPx)
+ uniqWindow <- holdUniqDyn window
+ return (uniqWindow, result)
+ where
+ toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m
+ mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
+ "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")
+ mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")
+ mkVirtualHeight h = let h' = h * rowPx --TODO: test the use of this
+ in toStyleAttr $ "height" =: (T.pack (show h') <> "px") <>
+ "overflow" =: "hidden" <>
+ "position" =: "relative"
+ mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
+ "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
+ "position" =: "absolute" <>
+ "width" =: "100%"
+ findWindow sizeIncrement windowSize startingPosition =
+ let (startingIndex, _) = startingPosition `divMod'` sizeIncrement
+ numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement
+ in (startingIndex, numItems)
+
+virtualListBuffered
+ :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
+ => Int
+ -> Dynamic t Int
+ -> Int
+ -> Dynamic t Int
+ -> Int
+ -> Event t Int
+ -> (k -> Int)
+ -> Map k v
+ -> Event t (Map k (Maybe v))
+ -> (k -> v -> Event t v -> m a)
+ -> m (Event t (Int, Int), Dynamic t (Map k a))
+virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do
+ (win, m) <- virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder
+ pb <- getPostBuild
+ let extendWin o l = (max 0 (o - l * (buffer-1) `div` 2), l * buffer)
+ rec let winHitEdge = attachWithMaybe (\(oldOffset, oldLimit) (winOffset, winLimit) ->
+ if winOffset > oldOffset && winOffset + winLimit < oldOffset + oldLimit
+ then Nothing
+ else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)
+ winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge
+ , attachPromptlyDynWith (\(x, y) _ -> extendWin x y) win pb
+ ]
+ return (updated winBuffered, m)
diff --git a/src/Reflex/Dom/Widget/Resize.hs b/src/Reflex/Dom/Widget/Resize.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Widget/Resize.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Reflex.Dom.Widget.Resize where
+
+import Reflex.Class
+import Reflex.Time
+import Reflex.Dom.Builder.Class
+import Reflex.Dom.Builder.Immediate
+import Reflex.Dom.Class
+import Reflex.Dom.Widget.Basic
+import Reflex.PerformEvent.Class
+import Reflex.PostBuild.Class
+import Reflex.TriggerEvent.Class
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHCJS.DOM.Element
+import GHCJS.DOM.EventM (on)
+import qualified GHCJS.DOM.GlobalEventHandlers as Events (scroll)
+import GHCJS.DOM.Types (MonadJSM, liftJSM, uncheckedCastTo, HTMLElement(..))
+import GHCJS.DOM.HTMLElement (getOffsetWidth, getOffsetHeight)
+import qualified GHCJS.DOM.Types as DOM
+
+-- | A widget that wraps the given widget in a div and fires an event when resized.
+-- Adapted from @github.com\/marcj\/css-element-queries@
+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)
+resizeDetector = resizeDetectorWithStyle ""
+
+resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
+ => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
+ -> m a -- ^ The embedded widget
+ -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
+resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
+
+resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
+ => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
+ -> m a -- ^ The embedded widget
+ -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
+resizeDetectorWithAttrs attrs w = do
+ let childStyle = "position: absolute; left: 0; top: 0;"
+ containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
+ (parent, (expand, expandChild, shrink, w')) <- elAttr' "div" (Map.unionWith (<>) attrs ("style" =: "position: relative;")) $ do
+ w' <- w
+ elAttr "div" containerAttrs $ do
+ (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return ()
+ (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return ()
+ return (expand, expandChild, shrink, w')
+ let p = uncheckedCastTo HTMLElement $ _element_raw parent
+ reset = do
+ let e = uncheckedCastTo HTMLElement $ _element_raw expand
+ s = _element_raw shrink
+ eow <- getOffsetWidth e
+ eoh <- getOffsetHeight e
+ let ecw = eow + 10
+ ech = eoh + 10
+ setAttribute (_element_raw expandChild) ("style" :: Text) (childStyle <> "width: " <> T.pack (show ecw) <> "px;" <> "height: " <> T.pack (show ech) <> "px;")
+ esw <- getScrollWidth e
+ setScrollLeft e esw
+ esh <- getScrollHeight e
+ setScrollTop e esh
+ ssw <- getScrollWidth s
+ setScrollLeft s ssw
+ ssh <- getScrollHeight s
+ setScrollTop s ssh
+ lastWidth <- getOffsetWidth p
+ lastHeight <- getOffsetHeight p
+ return (Just lastWidth, Just lastHeight)
+ resetIfChanged ds = do
+ pow <- getOffsetWidth p
+ poh <- getOffsetHeight p
+ if ds == (Just pow, Just poh)
+ then return Nothing
+ else fmap Just reset
+ pb <- delay 0 =<< getPostBuild
+ expandScroll <- wrapDomEvent (DOM.uncheckedCastTo DOM.HTMLElement $ _element_raw expand) (`on` Events.scroll) $ return ()
+ shrinkScroll <- wrapDomEvent (DOM.uncheckedCastTo DOM.HTMLElement $ _element_raw shrink) (`on` Events.scroll) $ return ()
+ size0 <- performEvent $ fmap (const $ liftJSM reset) pb
+ rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
+ dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
+ return (fmapMaybe void resize, w')
diff --git a/src/Reflex/Dom/Xhr.hs b/src/Reflex/Dom/Xhr.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Xhr.hs
@@ -0,0 +1,451 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+#ifdef USE_TEMPLATE_HASKELL
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+
+-- | A module for performing asynchronous HTTP calls from JavaScript
+-- using the
+--
+-- API (essentially AJAX). Despite the name, there is nothing whatsoever specific to XML.
+--
+-- The API has two components:
+--
+-- * convenient functions for common usecases like GET and POST
+-- requests to APIs using JSON.
+--
+-- * a flexible set of functions for creating and executing arbitrary
+-- requests and handling responses.
+--
+module Reflex.Dom.Xhr
+ ( -- * Common Patterns
+
+ -- | Functions that conveniently expose common uses like GET and
+ -- POST to JSON APIs.
+ getAndDecode
+ , getMay
+ , postJson
+
+ , decodeXhrResponse
+ , decodeText
+
+ -- * General Request API
+
+ -- | This is the most general flow for sending XHR requests:
+ --
+ -- 1. Create an 'Event' stream of 'XhrRequest' records (ie
+ -- @Event t (XhrRequest a)@). The records configure the request,
+ -- and the 'Event' controls when the request or requests are
+ -- actually sent.
+ --
+ -- 2. Plug the @Event t (XhrRequest a)@ into one of the functions
+ -- for performing requests like 'performRequestAsync'.
+ --
+ -- 3. Consume the resulting stream of 'XhrResponse' events,
+ -- parsing the body of the response however appropriate. A really
+ -- common pattern is turning the 'Event' into a 'Dynamic' with
+ -- 'holdDyn' or a related function.
+ --
+ -- Here is an example of calling a search API whenever the user
+ -- types in a text input field and printing the result on the page:
+ --
+ -- @
+ -- url query = "http:\/\/example.com\/search?query=" \<> query
+ --
+ -- search queries = do
+ -- responses \<- performRequestAsync $ toRequest \<$> queries
+ -- return $ view xhrResponse_responseText \<$> responses
+ -- where toRequest query = XhrRequest \"GET" (url query) def
+ --
+ -- main = mainWidget $ do
+ -- input \<- textInput def
+ -- let queries = updated $ input ^. textInput_value
+ -- results \<- search queries
+ -- asText \<- holdDyn "No results." $ pack . show \<$> results
+ -- dynText asText
+ -- @
+
+ -- ** XHR Requests
+ , XhrRequest (..)
+ , XhrRequestConfig (..)
+
+ , xhrRequest
+ , xhrRequestConfig_headers
+ , xhrRequestConfig_password
+ , xhrRequestConfig_responseType
+ , xhrRequestConfig_sendData
+ , xhrRequestConfig_user
+ , xhrRequestConfig_withCredentials
+ , xhrRequestConfig_responseHeaders
+ , xhrRequest_config
+ , xhrRequest_method
+ , xhrRequest_url
+
+ -- ** Performing Requests
+ , performMkRequestAsync
+ , performMkRequestsAsync
+ , performRequestAsync
+ , performRequestAsyncWithError
+ , performRequestsAsync
+ , performRequestsAsyncWithError
+
+ -- ** XHR Responses
+ , XhrResponse (..)
+ , XhrResponseBody (..)
+ , XhrResponseHeaders (..)
+ , XhrResponseType (..)
+
+ , xhrResponse_response
+ , xhrResponse_responseText
+ , xhrResponse_status
+ , xhrResponse_statusText
+ , xhrResponse_headers
+
+ -- *** Deprecated
+ , xhrResponse_body
+ , _xhrResponse_body
+
+ -- ** Error Handling
+ , XhrException (..)
+ , IsXhrPayload (..)
+
+ -- * JavaScript XMLHttpRequest Objects
+
+ -- | 'XMLHttpRequest' is the type of JavaScript's underlying runtime
+ -- objects that represent XHR requests.
+ --
+ -- Chances are you shouldn't need these in day-to-day code.
+ , XMLHttpRequest
+
+ -- ** Constructors
+ , newXMLHttpRequest
+ , newXMLHttpRequestWithError
+
+ -- ** Fields
+ , xmlHttpRequestGetReadyState
+ , xmlHttpRequestGetResponseText
+ , xmlHttpRequestGetStatus
+ , xmlHttpRequestGetStatusText
+ , xmlHttpRequestNew
+ , xmlHttpRequestOnreadystatechange
+ , xmlHttpRequestOpen
+ , xmlHttpRequestSetRequestHeader
+ , xmlHttpRequestSetResponseType
+ )
+where
+
+import Reflex.Class
+import Reflex.Dom.Class
+import Reflex.PerformEvent.Class
+import Reflex.TriggerEvent.Class
+import Reflex.Dom.Xhr.Exception
+import Reflex.Dom.Xhr.Foreign
+import Reflex.Dom.Xhr.ResponseType
+
+import Control.Concurrent
+import Control.Exception (handle)
+import Control.Lens
+import Control.Monad hiding (forM)
+import Control.Monad.IO.Class
+import Data.Aeson
+#if MIN_VERSION_aeson(1,0,0)
+import Data.Aeson.Text
+#else
+import Data.Aeson.Encode
+#endif
+import qualified Data.ByteString.Lazy as BL
+import Data.Default
+import qualified Data.List as L
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as B
+import Data.Traversable
+import Data.Typeable
+
+import Language.Javascript.JSaddle.Monad (JSM, askJSM, runJSM, MonadJSM, liftJSM)
+
+data XhrRequest a
+ = XhrRequest { _xhrRequest_method :: Text
+ , _xhrRequest_url :: Text
+ , _xhrRequest_config :: XhrRequestConfig a
+ }
+ deriving (Show, Read, Eq, Ord, Typeable, Functor)
+
+data XhrRequestConfig a
+ = XhrRequestConfig { _xhrRequestConfig_headers :: Map Text Text
+ , _xhrRequestConfig_user :: Maybe Text
+ , _xhrRequestConfig_password :: Maybe Text
+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType
+ , _xhrRequestConfig_sendData :: a
+ , _xhrRequestConfig_withCredentials :: Bool
+ , _xhrRequestConfig_responseHeaders :: XhrResponseHeaders
+ }
+ deriving (Show, Read, Eq, Ord, Typeable, Functor)
+
+data XhrResponse
+ = XhrResponse { _xhrResponse_status :: Word
+ , _xhrResponse_statusText :: Text
+ , _xhrResponse_response :: Maybe XhrResponseBody
+ , _xhrResponse_responseText :: Maybe Text
+ , _xhrResponse_headers :: Map Text Text
+ }
+ deriving (Typeable)
+
+data XhrResponseHeaders =
+ OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response
+ | AllHeaders -- ^ Parse all headers from the XHR Response
+ deriving (Show, Read, Eq, Ord, Typeable)
+
+instance Default XhrResponseHeaders where
+ def = OnlyHeaders mempty
+
+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
+_xhrResponse_body :: XhrResponse -> Maybe Text
+_xhrResponse_body = _xhrResponse_responseText
+
+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}
+xhrResponse_body :: Lens' XhrResponse (Maybe Text)
+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })
+
+instance a ~ () => Default (XhrRequestConfig a) where
+ def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
+ , _xhrRequestConfig_user = Nothing
+ , _xhrRequestConfig_password = Nothing
+ , _xhrRequestConfig_responseType = Nothing
+ , _xhrRequestConfig_sendData = ()
+ , _xhrRequestConfig_withCredentials = False
+ , _xhrRequestConfig_responseHeaders = def
+ }
+
+-- | Construct a request object from method, URL, and config record.
+xhrRequest :: Text -> Text -> XhrRequestConfig a -> XhrRequest a
+xhrRequest = XhrRequest
+
+-- | Make a new asyncronous XHR request. This does not block (it forks),
+-- and returns an XHR object immediately (which you can use to abort
+-- the XHR connection), and will pass an exception ('XhrException') to the
+-- continuation if the connection cannot be made (or is aborted).
+newXMLHttpRequestWithError
+ :: (HasJSContext m, MonadJSM m, IsXhrPayload a)
+ => XhrRequest a
+ -- ^ The request to make.
+ -> (Either XhrException XhrResponse -> JSM ())
+ -- ^ A continuation to be called once a response comes back, or in
+ -- case of error.
+ -> m XMLHttpRequest
+ -- ^ The XHR request, which could for example be aborted.
+newXMLHttpRequestWithError req cb = do
+ xhr <- xmlHttpRequestNew
+ ctx <- askJSM
+ void $ liftIO $ forkIO $ handle ((`runJSM` ctx) . cb . Left) $ void . (`runJSM` ctx) $ do
+ let c = _xhrRequest_config req
+ rt = _xhrRequestConfig_responseType c
+ creds = _xhrRequestConfig_withCredentials c
+ xmlHttpRequestOpen
+ xhr
+ (_xhrRequest_method req)
+ (_xhrRequest_url req)
+ True
+ (fromMaybe "" $ _xhrRequestConfig_user c)
+ (fromMaybe "" $ _xhrRequestConfig_password c)
+ iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt
+ xmlHttpRequestSetWithCredentials xhr creds
+ _ <- xmlHttpRequestOnreadystatechange xhr $ do
+ readyState <- xmlHttpRequestGetReadyState xhr
+ status <- xmlHttpRequestGetStatus xhr
+ statusText <- xmlHttpRequestGetStatusText xhr
+ when (readyState == 4) $ do
+ t <- if rt == Just XhrResponseType_Text || isNothing rt
+ then xmlHttpRequestGetResponseText xhr
+ else return Nothing
+ r <- xmlHttpRequestGetResponse xhr
+ h <- case _xhrRequestConfig_responseHeaders c of
+ AllHeaders -> parseAllHeadersString <$>
+ xmlHttpRequestGetAllResponseHeaders xhr
+ OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
+ (Map.fromSet id xs)
+ _ <- liftJSM $ cb $ Right
+ XhrResponse { _xhrResponse_status = status
+ , _xhrResponse_statusText = statusText
+ , _xhrResponse_response = r
+ , _xhrResponse_responseText = t
+ , _xhrResponse_headers = h
+ }
+ return ()
+ _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
+ return ()
+ return xhr
+
+parseAllHeadersString :: Text -> Map Text Text
+parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
+ L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
+ where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
+
+newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
+
+-- | Given Event of requests, issue them when the Event fires.
+-- Returns Event of corresponding responses.
+--
+-- The request is processed asynchronously, therefore handling does
+-- not block or cause a delay while creating the connection.
+performRequestAsyncWithError
+ :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)
+ => Event t (XhrRequest a)
+ -> m (Event t (Either XhrException XhrResponse))
+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return
+
+-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.
+performRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
+performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return
+
+-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.
+performMkRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)
+performMkRequestAsync = performRequestAsync' newXMLHttpRequest
+
+performRequestAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)
+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
+ r <- hr
+ _ <- newXhr r $ liftIO . cb
+ return ()
+
+-- | Issues a collection of requests when the supplied Event fires.
+-- When ALL requests from a given firing complete, the results are
+-- collected and returned via the return Event.
+--
+-- The requests are processed asynchronously, therefore handling does
+-- not block or cause a delay while creating the connection.
+--
+-- Order of request execution and completion is not guaranteed, but
+-- order of creation and the collection result is preserved.
+performRequestsAsyncWithError
+ :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)
+ => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))
+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return
+
+-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
+performRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
+performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return
+
+-- | Builds and issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
+performMkRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))
+performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest
+
+performRequestsAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f) => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (f (XhrRequest b))) -> m (Event t (f a))
+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
+ rs <- hrs
+ resps <- forM rs $ \r -> do
+ resp <- liftIO newEmptyMVar
+ _ <- newXhr r $ liftIO . putMVar resp
+ return resp
+ _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
+ return ()
+
+-- | Simplified interface to "GET" URLs and return decoded results.
+getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, HasJSContext (Performable m), TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))
+getAndDecode url = do
+ r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
+ return $ fmap decodeXhrResponse r
+
+-- | Create a "POST" request from an URL and thing with a JSON representation
+postJson :: (ToJSON a) => Text -> a -> XhrRequest Text
+postJson url a =
+ XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
+ , _xhrRequestConfig_sendData = body
+ }
+ where headerUrlEnc = "Content-type" =: "application/json"
+ body = LT.toStrict $ B.toLazyText $ encodeToTextBuilder $ toJSON a
+
+getMay :: (Monad m, Reflex t) => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b))
+getMay f e = do
+ e' <- f (fmapMaybe id e)
+ return $ leftmost [fmap Just e', fmapMaybe (maybe (Just Nothing) (const Nothing)) e]
+
+decodeText :: FromJSON a => Text -> Maybe a
+decodeText = decode . BL.fromStrict . encodeUtf8
+
+-- | Convenience function to decode JSON-encoded responses.
+decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
+decodeXhrResponse = decodeText <=< _xhrResponse_responseText
+
+#ifdef USE_TEMPLATE_HASKELL
+concat <$> mapM makeLenses
+ [ ''XhrRequest
+ , ''XhrRequestConfig
+ , ''XhrResponse
+ ]
+#else
+
+xhrRequest_method :: Lens' (XhrRequest a) Text
+xhrRequest_method f (XhrRequest x1 x2 x3) = (\y -> XhrRequest y x2 x3) <$> f x1
+{-# INLINE xhrRequest_method #-}
+
+xhrRequest_url :: Lens' (XhrRequest a) Text
+xhrRequest_url f (XhrRequest x1 x2 x3) = (\y -> XhrRequest x1 y x3) <$> f x2
+{-# INLINE xhrRequest_url #-}
+
+xhrRequest_config :: Lens' (XhrRequest a) (XhrRequestConfig a)
+xhrRequest_config f (XhrRequest x1 x2 x3) = (\y -> XhrRequest x1 x2 y) <$> f x3
+{-# INLINE xhrRequest_config #-}
+
+xhrRequestConfig_headers :: Lens' (XhrRequestConfig a) (Map Text Text)
+xhrRequestConfig_headers f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig y x2 x3 x4 x5 x6 x7) <$> f x1
+{-# INLINE xhrRequestConfig_headers #-}
+
+xhrRequestConfig_user :: Lens' (XhrRequestConfig a) (Maybe Text)
+xhrRequestConfig_user f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 y x3 x4 x5 x6 x7) <$> f x2
+{-# INLINE xhrRequestConfig_user #-}
+
+xhrRequestConfig_password :: Lens' (XhrRequestConfig a) (Maybe Text)
+xhrRequestConfig_password f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 y x4 x5 x6 x7) <$> f x3
+{-# INLINE xhrRequestConfig_password #-}
+
+xhrRequestConfig_responseType :: Lens' (XhrRequestConfig a) (Maybe XhrResponseType)
+xhrRequestConfig_responseType f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 y x5 x6 x7) <$> f x4
+{-# INLINE xhrRequestConfig_responseType #-}
+
+xhrRequestConfig_sendData :: Lens (XhrRequestConfig a) (XhrRequestConfig b) a b
+xhrRequestConfig_sendData f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 y x6 x7) <$> f x5
+{-# INLINE xhrRequestConfig_sendData #-}
+
+xhrRequestConfig_withCredentials :: Lens' (XhrRequestConfig a) Bool
+xhrRequestConfig_withCredentials f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 x5 y x7) <$> f x6
+{-# INLINE xhrRequestConfig_withCredentials #-}
+
+xhrRequestConfig_responseHeaders :: Lens' (XhrRequestConfig a) XhrResponseHeaders
+xhrRequestConfig_responseHeaders f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 x5 x6 y) <$> f x7
+{-# INLINE xhrRequestConfig_responseHeaders #-}
+
+xhrResponse_status :: Lens' XhrResponse Word
+xhrResponse_status f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse y x2 x3 x4 x5) <$> f x1
+{-# INLINE xhrResponse_status #-}
+
+xhrResponse_statusText :: Lens' XhrResponse Text
+xhrResponse_statusText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 y x3 x4 x5) <$> f x2
+{-# INLINE xhrResponse_statusText #-}
+
+xhrResponse_response :: Lens' XhrResponse (Maybe XhrResponseBody)
+xhrResponse_response f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 y x4 x5) <$> f x3
+{-# INLINE xhrResponse_response #-}
+
+xhrResponse_responseText :: Lens' XhrResponse (Maybe Text)
+xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
+{-# INLINE xhrResponse_responseText #-}
+
+xhrResponse_headers :: Lens' XhrResponse (Map Text Text)
+xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
+{-# INLINE xhrResponse_headers #-}
+
+#endif
diff --git a/src/Reflex/Dom/Xhr/Exception.hs b/src/Reflex/Dom/Xhr/Exception.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Xhr/Exception.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Reflex.Dom.Xhr.Exception where
+
+import Control.Exception (Exception (..))
+import Data.Typeable
+
+data XhrException = XhrException_Error
+ | XhrException_Aborted
+ deriving (Show, Read, Eq, Ord, Typeable)
+
+instance Exception XhrException
diff --git a/src/Reflex/Dom/Xhr/Foreign.hs b/src/Reflex/Dom/Xhr/Foreign.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Xhr/Foreign.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE JavaScriptFFI #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Reflex.Dom.Xhr.Foreign (
+ XMLHttpRequest
+ , XMLHttpRequestResponseType(..)
+ , module Reflex.Dom.Xhr.Foreign
+) where
+
+import Control.Exception (throwIO)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.ByteString (ByteString)
+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
+import GHCJS.DOM.Enums
+import GHCJS.DOM.EventM (EventM, on)
+import GHCJS.DOM.EventTarget (dispatchEvent)
+import GHCJS.DOM.Types (MonadJSM, ToJSString, FormData, Document, Blob (..), ArrayBuffer (..), JSVal, JSM, IsEvent, XMLHttpRequestProgressEvent, ProgressEvent, Event, XMLHttpRequestUpload, FromJSString, ArrayBufferView (..), liftJSM, castTo)
+import GHCJS.DOM.XMLHttpRequest
+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)
+import qualified Language.Javascript.JSaddle.Monad as JS (catch)
+import Prelude hiding (error)
+import Reflex.Dom.Xhr.Exception
+import Reflex.Dom.Xhr.ResponseType
+
+xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest
+xmlHttpRequestNew = newXMLHttpRequest
+
+xmlHttpRequestOpen ::
+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password, MonadJSM m) =>
+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> m ()
+xmlHttpRequestOpen request method url async user password = open request method url async (Just user) (Just password)
+
+convertException :: XHRError -> XhrException
+convertException e = case e of
+ XHRError -> XhrException_Error
+ XHRAborted -> XhrException_Aborted
+
+class IsXhrPayload a where
+ sendXhrPayload :: MonadJSM m => XMLHttpRequest -> a -> m ()
+
+instance IsXhrPayload () where
+ sendXhrPayload xhr _ = send xhr
+
+instance IsXhrPayload String where
+ sendXhrPayload = sendString
+
+instance IsXhrPayload Text where
+ sendXhrPayload = sendString
+
+instance IsXhrPayload FormData where
+ sendXhrPayload = sendFormData
+
+instance IsXhrPayload Document where
+ sendXhrPayload = sendDocument
+
+instance IsXhrPayload Blob where
+ sendXhrPayload = sendBlob
+
+instance IsXhrPayload ArrayBuffer where
+ sendXhrPayload xhr ab = sendArrayBuffer xhr (ArrayBufferView $ unArrayBuffer ab)
+
+instance IsXhrPayload ByteString where
+ sendXhrPayload xhr bs = sendXhrPayload xhr =<< liftJSM (bsToArrayBuffer bs)
+
+newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }
+
+-- This used to be a non blocking call, but now it uses an interruptible ffi
+xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> JSM ()
+xmlHttpRequestSend self p = sendXhrPayload self p `JS.catch` (liftIO . throwIO . convertException)
+
+
+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value, MonadJSM m)
+ => XMLHttpRequest -> header -> value -> m ()
+xmlHttpRequestSetRequestHeader = setRequestHeader
+
+xmlHttpRequestAbort :: MonadJSM m => XMLHttpRequest -> m ()
+xmlHttpRequestAbort = abort
+
+xmlHttpRequestGetAllResponseHeaders :: MonadJSM m => XMLHttpRequest -> m Text
+xmlHttpRequestGetAllResponseHeaders = getAllResponseHeaders
+
+xmlHttpRequestGetResponseHeader :: (ToJSString header, MonadJSM m)
+ => XMLHttpRequest -> header -> m Text
+xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
+
+xmlHttpRequestOverrideMimeType :: (ToJSString override, MonadJSM m) => XMLHttpRequest -> override -> m ()
+xmlHttpRequestOverrideMimeType = overrideMimeType
+
+xmlHttpRequestDispatchEvent :: (IsEvent evt, MonadJSM m) => XMLHttpRequest -> evt -> m Bool
+xmlHttpRequestDispatchEvent = dispatchEvent
+
+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnabort = (`on` abortEvent)
+
+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnerror = (`on` error)
+
+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnload = (`on` load)
+
+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnloadend = (`on` loadEnd)
+
+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnloadstart = (`on` loadStart)
+
+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOnprogress = (`on` progress)
+
+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
+xmlHttpRequestOntimeout = (`on` timeout)
+
+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())
+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
+
+xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()
+xmlHttpRequestSetTimeout = setTimeout
+
+xmlHttpRequestGetTimeout :: MonadJSM m => XMLHttpRequest -> m Word
+xmlHttpRequestGetTimeout = getTimeout
+
+xmlHttpRequestGetReadyState :: MonadJSM m => XMLHttpRequest -> m Word
+xmlHttpRequestGetReadyState = getReadyState
+
+xmlHttpRequestSetWithCredentials :: MonadJSM m => XMLHttpRequest -> Bool -> m ()
+xmlHttpRequestSetWithCredentials = setWithCredentials
+
+xmlHttpRequestGetWithCredentials :: MonadJSM m => XMLHttpRequest -> m Bool
+xmlHttpRequestGetWithCredentials = getWithCredentials
+
+xmlHttpRequestGetUpload :: MonadJSM m => XMLHttpRequest -> m (Maybe XMLHttpRequestUpload)
+xmlHttpRequestGetUpload = fmap Just . getUpload
+
+xmlHttpRequestGetResponseText :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m (Maybe result)
+xmlHttpRequestGetResponseText = getResponseText
+
+xmlHttpRequestGetResponseXML :: MonadJSM m => XMLHttpRequest -> m (Maybe Document)
+xmlHttpRequestGetResponseXML = getResponseXML
+
+xmlHttpRequestSetResponseType :: MonadJSM m => XMLHttpRequest -> XMLHttpRequestResponseType -> m ()
+xmlHttpRequestSetResponseType = setResponseType
+
+fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType
+fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType
+fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer
+fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob
+fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText
+
+toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType
+toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default
+toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer
+toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob
+toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text
+toResponseType _ = Nothing
+
+xmlHttpRequestGetResponseType :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseType)
+xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType
+
+xmlHttpRequestGetStatus :: MonadJSM m => XMLHttpRequest -> m Word
+xmlHttpRequestGetStatus = getStatus
+
+xmlHttpRequestGetStatusText :: MonadJSM m => FromJSString result => XMLHttpRequest -> m result
+xmlHttpRequestGetStatusText = getStatusText
+
+xmlHttpRequestGetResponseURL :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m result
+xmlHttpRequestGetResponseURL = getResponseURL
+
+xmlHttpRequestGetResponse :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseBody)
+xmlHttpRequestGetResponse xhr = do
+ mr <- getResponse xhr
+ rt <- xmlHttpRequestGetResponseType xhr
+ case rt of
+ Just XhrResponseType_Blob -> fmap XhrResponseBody_Blob <$> castTo Blob mr
+ Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
+ Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
+ Just XhrResponseType_ArrayBuffer -> do
+ ab <- liftJSM $ mutableArrayBufferFromJSVal mr
+ Just . XhrResponseBody_ArrayBuffer <$> bsFromMutableArrayBuffer ab
+ _ -> return Nothing
diff --git a/src/Reflex/Dom/Xhr/ResponseType.hs b/src/Reflex/Dom/Xhr/ResponseType.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/Xhr/ResponseType.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Reflex.Dom.Xhr.ResponseType where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Typeable
+import GHCJS.DOM.Blob (Blob)
+
+data XhrResponseType
+ = XhrResponseType_Default
+ | XhrResponseType_ArrayBuffer
+ | XhrResponseType_Blob
+ | XhrResponseType_Text
+ deriving (Show, Read, Eq, Ord, Typeable)
+
+data XhrResponseBody
+ = XhrResponseBody_Default Text
+ | XhrResponseBody_Text Text
+ | XhrResponseBody_Blob Blob
+ | XhrResponseBody_ArrayBuffer ByteString
diff --git a/test/gc.hs b/test/gc.hs
new file mode 100644
--- /dev/null
+++ b/test/gc.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Int
+import Language.Javascript.JSaddle.Warp
+import Reflex.Dom.Core
+import Reflex.Time
+import System.Exit
+import System.IO.Temp
+import System.Linux.Namespaces
+import System.Mem
+import System.Posix
+import System.Process
+
+#if MIN_VERSION_base(4,11,0)
+import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
+currentBytesUsed :: RTSStats -> Int64
+currentBytesUsed = fromIntegral . gcdetails_live_bytes . gc
+#else
+import GHC.Stats (getGCStats, GCStats(..))
+getRTSStats = getGCStats
+#endif
+
+-- In initial testing, the minimum live bytes count was 233128 and maximum was
+-- 363712. Going over the maximum means the test has actually failed - we
+-- probably have a memory leak; going under the minimum doesn't indicate a
+-- memory leak, but may mean the test needs to be updated.
+minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64
+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 600000)
+
+-- Some times the memory usage might flair up and then then return to normal
+-- this probably indicates an issue, but if you are trying to fix a slow consistent
+-- leak it can confuse the results by making the tests fail when the slow leak is
+-- fixed.
+-- Set this limit to say how many failures (currentBytesUsed > maxBytesAllowed)
+-- want to ignore. If the memory usage goes back under resetThreshold
+-- the failure count is reset to 0.
+failureLimit :: Int
+failureLimit = 0
+
+main :: IO ()
+main = do
+ uid <- getEffectiveUserID
+ handle (\(_ :: IOError) -> return ()) $ do -- If we run into an exception with sandboxing, just don't bother
+ unshare [User, Network]
+ writeUserMappings Nothing [UserMapping 0 uid 1]
+ callCommand "ip link set lo up ; ip addr"
+ mainThread <- myThreadId
+ withSystemTempDirectory "reflex-dom-core_test_gc" $ \tmp -> do
+ browserProcess <- spawnCommand $ "echo 'Starting Chromium' ; chromium --headless --disable-gpu --no-sandbox --remote-debugging-port=9222 --user-data-dir=" ++ tmp ++ " http://localhost:3911 ; echo 'Chromium exited'"
+ let finishTest result = do
+ interruptProcessGroupOf browserProcess
+ throwTo mainThread result
+ putStrLn "About to start the server"
+ run 3911 $ do
+ -- enableLogging True
+ liftIO $ putStrLn "Running..."
+ mainWidget $ do
+ let w = do
+ rec let modifyAttrs = flip pushAlways (updated d) $ \_ -> sample $ current d
+ (e, _) <- element "button" (def & modifyAttributes .~ modifyAttrs) blank
+ d <- holdDyn mempty $ mempty <$ domEvent Click e
+ return ()
+ postBuild <- getPostBuild
+ let f (!failures, !n) = liftIO $ if n < 3000
+ then do performMajorGC
+ threadDelay 5000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined
+ gcStats <- getRTSStats
+ print $ currentBytesUsed gcStats
+ when (currentBytesUsed gcStats < minBytesAllowed) $ do
+ putStrLn "FAILED: currentBytesUsed < minBytesAllowed"
+ finishTest $ ExitFailure 2
+ let overMax = currentBytesUsed gcStats > maxBytesAllowed
+ underReset = currentBytesUsed gcStats < resetThreshold
+ when (overMax && failures >= failureLimit) $ do
+ putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
+ finishTest $ ExitFailure 1
+ return $ Just (
+ if overMax
+ then succ failures
+ else (if underReset then 0 else failures), succ n)
+ else do putStrLn "SUCCEEDED"
+ finishTest ExitSuccess
+ return Nothing
+ rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
+ [ (0 :: Int, 0 :: Int) <$ postBuild
+ , fmapMaybe id redraw
+ ]
+ _ <- widgetHold w $ w <$ redraw
+ return ()
+ liftIO $ forever $ threadDelay 1000000000
diff --git a/test/hlint.hs b/test/hlint.hs
new file mode 100644
--- /dev/null
+++ b/test/hlint.hs
@@ -0,0 +1,24 @@
+import Language.Haskell.HLint3 (hlint)
+import System.Exit (exitFailure, exitSuccess)
+
+main :: IO ()
+main = do
+ ideas <- hlint
+ [ "."
+ , "--ignore=Redundant do"
+ , "--ignore=Use camelCase"
+ , "--ignore=Redundant $"
+ , "--ignore=Use &&"
+ , "--ignore=Use &&&"
+ , "--ignore=Use const"
+ , "--ignore=Use >=>"
+ , "--ignore=Use ."
+ , "--ignore=Use unless"
+ , "--ignore=Use if"
+ , "--ignore=Use fewer imports"
+ , "--ignore=Unnecessary hiding" -- Interferes with cross-version compatibility
+ , "--ignore=Use <$>"
+ , "--ignore=Reduce duplication" --TODO: Re-enable this test
+ , "--cpp-define=USE_TEMPLATE_HASKELL"
+ ]
+ if null ideas then exitSuccess else exitFailure