mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-10-26 15:59:57 +03:00
Merge remote-tracking branch 'origin/placeholder-refactor' into develop
# Conflicts: # .gitignore # reflex-dom.cabal # src-ghc/Reflex/Dom/WebSocket/Foreign.hs # src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs # src/Reflex/Dom/WebSocket.hs
This commit is contained in:
Ryan Trinkle
commit
7b9f101573
2
.gitignore
vendored
2
.gitignore
vendored
@ -36,3 +36,5 @@ hsenv.log
|
||||
cabal.sandbox.config
|
||||
.stack-work
|
||||
codex.tags
|
||||
*.dump-*
|
||||
*.verbose-core2core
|
||||
|
||||
@ -20,39 +20,45 @@ extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs
|
||||
src/Reflex/Dom/Xhr/ResponseType.hs
|
||||
src/Reflex/Dom/Xhr/Exception.hs
|
||||
|
||||
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
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.10,
|
||||
template-haskell,
|
||||
stm == 2.4.*,
|
||||
reflex == 0.5.*,
|
||||
dependent-sum == 0.3.*,
|
||||
dependent-map == 0.2.*,
|
||||
semigroups >= 0.16 && < 0.19,
|
||||
mtl >= 2.1 && < 2.3,
|
||||
containers == 0.5.*,
|
||||
these >= 0.4 && < 0.8,
|
||||
ref-tf == 0.4.*,
|
||||
random == 1.1.*,
|
||||
ghcjs-dom >= 0.2.1 && < 0.3,
|
||||
transformers >= 0.3 && < 0.6,
|
||||
lens >= 4.7 && < 5,
|
||||
text == 1.2.*,
|
||||
blaze-builder,
|
||||
bytestring == 0.10.*,
|
||||
data-default >= 0.5 && < 0.8,
|
||||
aeson >= 0.8 && < 1.1,
|
||||
time >= 1.4 && < 1.7,
|
||||
exception-transformers == 0.4.*,
|
||||
directory == 1.2.*,
|
||||
dependent-sum-template >= 0.0.0.4 && < 0.1,
|
||||
zenc == 0.1.*,
|
||||
base >= 4.7 && < 4.10,
|
||||
bifunctors >= 4.2 && < 6,
|
||||
bimap >= 0.3 && < 0.4,
|
||||
monad-control >= 1.0.1 && < 1.1,
|
||||
blaze-builder,
|
||||
bytestring == 0.10.*,
|
||||
containers == 0.5.*,
|
||||
data-default >= 0.5 && < 0.8,
|
||||
dependent-map == 0.2.*,
|
||||
dependent-sum == 0.3.*,
|
||||
dependent-sum-template >= 0.0.0.4 && < 0.1,
|
||||
directory == 1.2.*,
|
||||
exception-transformers == 0.4.*,
|
||||
ghcjs-dom >= 0.2.1 && < 0.3,
|
||||
keycode == 0.2.*,
|
||||
unbounded-delays >= 0.1.0.9 && < 0.2
|
||||
lens >= 4.7 && < 5,
|
||||
monad-control >= 1.0.1 && < 1.1,
|
||||
mtl >= 2.1 && < 2.3,
|
||||
primitive >= 0.5 && < 0.7,
|
||||
random == 1.1.*,
|
||||
ref-tf == 0.4.*,
|
||||
reflex == 0.5.*,
|
||||
semigroups >= 0.16 && < 0.19,
|
||||
stm == 2.4.*,
|
||||
template-haskell,
|
||||
text == 1.2.*,
|
||||
these >= 0.4 && < 0.8,
|
||||
time >= 1.4 && < 1.7,
|
||||
transformers >= 0.3 && < 0.6,
|
||||
unbounded-delays >= 0.1.0.9 && < 0.2,
|
||||
zenc == 0.1.*
|
||||
|
||||
if impl(ghcjs)
|
||||
hs-source-dirs: src-ghcjs
|
||||
@ -101,6 +107,8 @@ library
|
||||
|
||||
other-extensions: TemplateHaskell
|
||||
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
|
||||
if flag(use-reflex-optimizer)
|
||||
ghc-options: -fplugin=Reflex.Optimizer
|
||||
|
||||
test-suite hlint
|
||||
build-depends: base, hlint == 1.9.*
|
||||
|
||||
@ -77,7 +77,7 @@ closeWebSocket (JSWebSocket ws c) code reason = do
|
||||
newWebSocket
|
||||
:: WebView
|
||||
-> Text -- url
|
||||
-> (ByteString -> IO ()) -- onmessage
|
||||
-> (Either ByteString a -> IO ()) -- onmessage
|
||||
-> IO () -- onopen
|
||||
-> IO () -- onerror
|
||||
-> ((Bool, Word, Text) -> IO ()) -- onclose
|
||||
@ -94,7 +94,7 @@ newWebSocket wv url onMessage onOpen onError onClose = withWebViewContext wv $ \
|
||||
msg' <- fromJSStringMaybe c msg
|
||||
case msg' of
|
||||
Nothing -> return ()
|
||||
Just m -> onMessage $ encodeUtf8 m
|
||||
Just m -> onMessage $ Left $ encodeUtf8 m
|
||||
jsvaluemakeundefined c
|
||||
onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
|
||||
onOpen' <- wrapper $ \_ _ _ _ _ _ -> do
|
||||
@ -123,3 +123,8 @@ newWebSocket wv url onMessage onOpen onError onClose = withWebViewContext wv $ \
|
||||
addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onerror'] = this[3]; this[0]['onclose'] = this[4];"
|
||||
_ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
|
||||
return $ JSWebSocket ws c
|
||||
|
||||
onBSMessage :: Either ByteString b -> ByteString
|
||||
onBSMessage = either id (error "onBSMessage: ghc env expects ByteString.")
|
||||
|
||||
type JSVal = ()
|
||||
|
||||
@ -1,7 +1,10 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
{-# LANGUAGE JavaScriptFFI #-}
|
||||
|
||||
module Reflex.Dom.WebSocket.Foreign where
|
||||
module Reflex.Dom.WebSocket.Foreign
|
||||
( module Reflex.Dom.WebSocket.Foreign
|
||||
, JSVal
|
||||
) where
|
||||
|
||||
import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
|
||||
|
||||
@ -54,7 +57,7 @@ closeEvent = unsafeEventName (toJSString "close")
|
||||
newWebSocket
|
||||
:: a
|
||||
-> Text -- url
|
||||
-> (ByteString -> IO ()) -- onmessage
|
||||
-> (Either ByteString JSVal -> IO ()) -- onmessage
|
||||
-> IO () -- onopen
|
||||
-> IO () -- onerror
|
||||
-> ((Bool, Word, Text) -> IO ()) -- onclose
|
||||
@ -74,10 +77,13 @@ newWebSocket _ url onMessage onOpen onError onClose = do
|
||||
e <- ask
|
||||
d <- getData e
|
||||
liftIO $ case jsTypeOf d of
|
||||
String -> onMessage $ encodeUtf8 $ pFromJSVal d
|
||||
String -> onMessage $ Right d
|
||||
_ -> do
|
||||
ab <- unsafeFreeze $ pFromJSVal d
|
||||
onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
|
||||
onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab
|
||||
return $ JSWebSocket ws
|
||||
|
||||
foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
|
||||
|
||||
onBSMessage :: Either ByteString JSVal -> ByteString
|
||||
onBSMessage = either id (encodeUtf8 . pFromJSVal)
|
||||
|
||||
@ -21,7 +21,6 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
|
||||
) where
|
||||
|
||||
import Reflex.Class
|
||||
import Reflex.Deletable.Class
|
||||
import Reflex.DynamicWriter
|
||||
import Reflex.PerformEvent.Base
|
||||
import Reflex.PerformEvent.Class
|
||||
@ -69,6 +68,7 @@ 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
|
||||
@ -109,8 +109,20 @@ instance HasWebView m => HasWebView (DynamicWriterT t w m) where
|
||||
type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
|
||||
askWebView = lift askWebView
|
||||
|
||||
instance HasWebView m => HasWebView (RequestT t request response m) where
|
||||
type WebViewPhantom (RequestT t request response m) = WebViewPhantom m
|
||||
askWebView = lift askWebView
|
||||
|
||||
newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
|
||||
|
||||
instance PrimMonad m => PrimMonad (WithWebView x m) where
|
||||
type PrimState (WithWebView x m) = PrimState m
|
||||
primitive = lift . primitive
|
||||
|
||||
instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
|
||||
runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')
|
||||
sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
|
||||
|
||||
instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
|
||||
{-# INLINABLE newEventWithTrigger #-}
|
||||
newEventWithTrigger = lift . newEventWithTrigger
|
||||
@ -154,10 +166,6 @@ instance PerformEvent t m => PerformEvent t (WithWebView x m) where
|
||||
{-# INLINABLE performEvent #-}
|
||||
performEvent e = liftWith $ \run -> performEvent $ fmap run e
|
||||
|
||||
instance Deletable t m => Deletable t (WithWebView x m) where
|
||||
{-# INLINABLE deletable #-}
|
||||
deletable = liftThrough . deletable
|
||||
|
||||
runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
|
||||
runWithWebView = runReaderT . unWithWebView
|
||||
|
||||
@ -218,6 +226,10 @@ instance HasJS x m => HasJS x (DynamicWriterT t w m) where
|
||||
type JSM (DynamicWriterT t w m) = JSM m
|
||||
liftJS = lift . liftJS
|
||||
|
||||
instance HasJS x m => HasJS x (RequestT t request response m) where
|
||||
type JSM (RequestT t request response m) = JSM 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)
|
||||
|
||||
@ -18,14 +18,13 @@
|
||||
module Reflex.Dom.Builder.Class
|
||||
( module Reflex.Dom.Builder.Class
|
||||
, module Reflex.Dom.Builder.Class.Events
|
||||
, module Reflex.Deletable.Class
|
||||
) where
|
||||
|
||||
import Reflex.Class as Reflex
|
||||
import Reflex.Dom.Builder.Class.Events
|
||||
import Reflex.Deletable.Class
|
||||
import Reflex.DynamicWriter
|
||||
import Reflex.PerformEvent.Class
|
||||
import Reflex.PerformEvent.Base
|
||||
import Reflex.PostBuild.Class
|
||||
|
||||
import qualified Control.Category
|
||||
@ -34,16 +33,13 @@ import Control.Monad.Reader
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Default
|
||||
import Data.Foldable
|
||||
import Data.Functor.Misc
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Proxy
|
||||
import Data.Semigroup
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Data.Type.Coercion
|
||||
import GHC.Exts (Constraint)
|
||||
|
||||
@ -65,7 +61,7 @@ liftElementConfig cfg = cfg
|
||||
|
||||
-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building
|
||||
-- dynamic DOM in the 'Reflex' timeline @t@
|
||||
class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where
|
||||
class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomBuilder t m | m -> t where
|
||||
type DomBuilderSpace m :: *
|
||||
textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
|
||||
default textNode :: ( MonadTrans f
|
||||
@ -86,9 +82,11 @@ class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBui
|
||||
=> Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)
|
||||
element t cfg child = liftWith $ \run -> element t (liftElementConfig cfg) $ run child
|
||||
{-# INLINABLE element #-}
|
||||
{-
|
||||
-- | Create a placeholder in the DOM, with the ability to insert new DOM before it
|
||||
-- The provided DOM will be executed after the current frame, so it will not be affected by any occurrences that are concurrent with the occurrence that created it
|
||||
placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)
|
||||
-}
|
||||
inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)
|
||||
default inputElement :: ( MonadTransControl f
|
||||
, m ~ f m'
|
||||
@ -403,13 +401,6 @@ instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (ElementConfig
|
||||
|
||||
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
|
||||
{-# INLINABLE placeholder #-}
|
||||
placeholder cfg = lift $ do
|
||||
rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p
|
||||
p <- placeholder $ cfg
|
||||
{ _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild
|
||||
}
|
||||
return p
|
||||
wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
|
||||
|
||||
instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
|
||||
@ -421,32 +412,6 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (
|
||||
(el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
|
||||
put newS
|
||||
return (el, a)
|
||||
placeholder cfg = do
|
||||
let cfg' = cfg
|
||||
{ _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
|
||||
}
|
||||
let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
|
||||
-> Event t () -- ^ No more nodes will be added after this event fires
|
||||
-> m (Replaceable t (Dynamic t w))
|
||||
manageChildren newChildren additionsCeased = do
|
||||
rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
|
||||
let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
|
||||
numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
|
||||
let cs = reverse $ toList rcs
|
||||
myFirstId <- sample nextId
|
||||
let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
|
||||
return (myNextId, PatchMap $ Map.fromList numbered)
|
||||
newNextId = fst <$> numberedNewChildren
|
||||
mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
|
||||
rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
|
||||
p <- DynamicWriterT $ do
|
||||
modify (children:)
|
||||
lift $ placeholder cfg'
|
||||
let result = fst <$> _placeholder_insertedAbove p
|
||||
childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
|
||||
return $ p
|
||||
{ _placeholder_insertedAbove = result
|
||||
}
|
||||
inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig
|
||||
textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig
|
||||
selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do
|
||||
@ -460,6 +425,31 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (
|
||||
{ _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
|
||||
}
|
||||
|
||||
instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequestT t request response m) where
|
||||
type DomBuilderSpace (RequestT t request response m) = DomBuilderSpace m
|
||||
textNode = liftTextNode
|
||||
element elementTag cfg (RequestT child) = RequestT $ do
|
||||
r <- ask
|
||||
s <- get
|
||||
let cfg' = liftElementConfig cfg
|
||||
(el, (a, newS)) <- lift $ lift $ element elementTag cfg' $ runReaderT (runStateT child s) r
|
||||
put newS
|
||||
return (el, a)
|
||||
inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig
|
||||
textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig
|
||||
selectElement cfg (RequestT child) = RequestT $ do
|
||||
r <- ask
|
||||
s <- get
|
||||
let cfg' = cfg & selectElementConfig_elementConfig %~ liftElementConfig
|
||||
(el, (a, newS)) <- lift $ lift $ selectElement cfg' $ runReaderT (runStateT child s) r
|
||||
put newS
|
||||
return (el, a)
|
||||
placeRawElement = lift . placeRawElement
|
||||
wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
|
||||
{ _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
|
||||
}
|
||||
|
||||
|
||||
-- * Convenience functions
|
||||
|
||||
--TODO: Move/replace
|
||||
@ -521,7 +511,6 @@ instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where
|
||||
|
||||
instance DomBuilder t m => DomBuilder t (ReaderT r m) where
|
||||
type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m
|
||||
placeholder = liftPlaceholder
|
||||
|
||||
type LiftDomBuilder t f m =
|
||||
( Reflex t
|
||||
@ -555,8 +544,10 @@ liftTextNode = lift . textNode
|
||||
liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (f m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)
|
||||
liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag (fmap1 run cfg) $ run child
|
||||
|
||||
{-
|
||||
liftPlaceholder :: LiftDomBuilder t f m => PlaceholderConfig above t (f m) -> f m (Placeholder above t)
|
||||
liftPlaceholder cfg = liftWithStateless $ \run -> placeholder $ fmap1 run cfg
|
||||
-}
|
||||
|
||||
liftInputElement :: LiftDomBuilder t f m => InputElementConfig er t (f m) -> f m (InputElement er (DomBuilderSpace m) t)
|
||||
liftInputElement cfg = liftWithStateless $ \run -> inputElement $ fmap1 run cfg
|
||||
|
||||
@ -108,7 +108,7 @@ newtype EventResult en = EventResult { unEventResult :: EventResultType en }
|
||||
|
||||
type family EventResultType (en :: EventTag) :: * where
|
||||
EventResultType 'ClickTag = ()
|
||||
EventResultType 'DblclickTag = ()
|
||||
EventResultType 'DblclickTag = (Int, Int)
|
||||
EventResultType 'KeypressTag = Int
|
||||
EventResultType 'KeydownTag = Int
|
||||
EventResultType 'KeyupTag = Int
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
@ -27,6 +28,7 @@ import Reflex.Host.Class
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Lens hiding (element)
|
||||
import Control.Monad.Exception
|
||||
import Control.Monad.Primitive
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Ref
|
||||
import Control.Monad.Trans.Control
|
||||
@ -37,8 +39,12 @@ import qualified Data.Dependent.Map as DMap
|
||||
import Data.Dependent.Sum
|
||||
import Data.Functor.Misc
|
||||
import Data.IORef
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.Some (Some)
|
||||
import qualified Data.Some as Some
|
||||
import Data.Text (Text)
|
||||
import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
|
||||
import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
|
||||
@ -51,8 +57,9 @@ 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 GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
|
||||
import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling,
|
||||
removeChild, setNodeValue, toNode)
|
||||
import qualified GHCJS.DOM.Node as DOM
|
||||
import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
|
||||
WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
|
||||
castToHTMLTextAreaElement)
|
||||
@ -74,6 +81,10 @@ data ImmediateDomBuilderEnv t
|
||||
|
||||
newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
|
||||
|
||||
instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
|
||||
type PrimState (ImmediateDomBuilderT x m) = PrimState m
|
||||
primitive = lift . primitive
|
||||
|
||||
instance MonadTransControl (ImmediateDomBuilderT t) where
|
||||
type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
|
||||
liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
|
||||
@ -121,15 +132,42 @@ deleteBetweenInclusive s e = do
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> do
|
||||
let go = do
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
_ <- removeChild currentParent $ Just x
|
||||
when (toNode s /= toNode x) go
|
||||
go
|
||||
deleteUpToGivenParent currentParent s e
|
||||
_ <- removeChild currentParent $ Just e
|
||||
return ()
|
||||
|
||||
type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
|
||||
-- | s and e must both be children of the same node and s must precede e
|
||||
deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
|
||||
deleteBetweenExclusive s e = do
|
||||
mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> do
|
||||
let go = do
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
when (toNode s /= toNode x) $ do
|
||||
_ <- removeChild currentParent $ Just x
|
||||
go
|
||||
go
|
||||
|
||||
-- | 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 :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
|
||||
deleteUpTo s e = do
|
||||
mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> deleteUpToGivenParent currentParent s e
|
||||
|
||||
{-# INLINABLE deleteUpToGivenParent #-}
|
||||
deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
|
||||
deleteUpToGivenParent currentParent s e = do
|
||||
fix $ \loop -> do
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
_ <- removeChild currentParent $ Just x
|
||||
when (toNode s /= toNode x) loop
|
||||
|
||||
type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadIO (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO, MonadAdjust t m)
|
||||
|
||||
newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
|
||||
|
||||
@ -248,6 +286,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
|
||||
return $ TextNode n
|
||||
{-# INLINABLE element #-}
|
||||
element elementTag cfg child = fst <$> makeElement elementTag cfg child
|
||||
{-
|
||||
{-# INLINABLE placeholder #-}
|
||||
placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do
|
||||
n <- textNodeInternal ("" :: Text)
|
||||
@ -257,6 +296,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
|
||||
mp <- getParentNode n
|
||||
forM_ mp $ \p -> removeChild p $ Just n
|
||||
return $ Placeholder insertedAbove deleted
|
||||
-}
|
||||
{-# INLINABLE inputElement #-}
|
||||
inputElement cfg = do
|
||||
((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
|
||||
@ -354,6 +394,57 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
|
||||
placeRawElement = append
|
||||
wrapRawElement = wrap
|
||||
|
||||
instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
|
||||
runWithReplace a0 a' = do
|
||||
initialEnv <- ImmediateDomBuilderT ask
|
||||
before <- textNodeInternal ("" :: Text)
|
||||
-- We draw 'after' in this roundabout way to avoid using MonadFix
|
||||
Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
|
||||
let drawInitialChild = do
|
||||
result <- a0
|
||||
append after
|
||||
return result
|
||||
(result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
|
||||
Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
|
||||
result <- runImmediateDomBuilderT child $ initialEnv
|
||||
{ _immediateDomBuilderEnv_parent = toNode df
|
||||
}
|
||||
deleteBetweenExclusive before after
|
||||
insertBefore df after
|
||||
return result
|
||||
return (result0, result')
|
||||
sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do
|
||||
initialEnv <- ImmediateDomBuilderT ask
|
||||
let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
|
||||
drawChildInitial child = runImmediateDomBuilderT ((,,) <$> pure (error "sequenceDMapWithAdjust{ImmediateDomBuilderT}: drawChildInitial: DocumentFragment evaluated") <*> textNodeInternal ("" :: Text) <*> child) initialEnv --TODO: Don't return a DocumentFragment at all here; this will require that sequenceDMapWithAdjust accept differently-typed values for the constant and Event arguments.
|
||||
drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
|
||||
drawChildUpdate child = do
|
||||
Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
|
||||
runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
|
||||
{ _immediateDomBuilderEnv_parent = toNode df
|
||||
}
|
||||
updateChildren = ffor dm' $ \(PatchDMap p) -> PatchDMap $
|
||||
mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap drawChildUpdate mv)) p
|
||||
(children0, children') <- lift $ sequenceDMapWithAdjust (mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> drawChildInitial v) dm0) (updateChildren :: Event t (PatchDMap (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) m)) --TODO: Update stuff
|
||||
let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, _, v)) -> k :=> Identity v) children0
|
||||
placeholders0 = dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, ph, _)) -> Const2 (Some.This k) :=> Identity ph) children0
|
||||
result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
|
||||
mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> k :=> fmap (\(_, _, r) -> r) v) p
|
||||
placeholders' = ffor children' $ \(PatchDMap p) -> PatchMap $
|
||||
dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> Const2 (Some.This k) :=> Identity (fmap ((\(_, ph, _) -> ph) . runIdentity) (getComposeMaybe v))) p
|
||||
placeholders :: Behavior t (Map (Some k) DOM.Text) <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
|
||||
lastPlaceholder <- textNodeInternal ("" :: Text)
|
||||
performEvent_ $ flip push children' $ \(PatchDMap p) -> do
|
||||
phs <- sample placeholders
|
||||
if DMap.null p then return Nothing else return $ Just $ do
|
||||
let f :: DSum (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) (ComposeMaybe Identity) -> Performable m ()
|
||||
f (WrapArg k :=> ComposeMaybe mv) = do
|
||||
let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
|
||||
forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
|
||||
forM_ mv $ \(Identity (df, _, _)) -> df `insertBefore` nextPlaceholder
|
||||
mapM_ f $ DMap.toList p
|
||||
return (result0, 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
|
||||
@ -363,7 +454,7 @@ mkHasFocus e = do
|
||||
]
|
||||
|
||||
{-# INLINABLE insertImmediateAbove #-}
|
||||
insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
|
||||
insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
|
||||
insertImmediateAbove n toInsertAbove = do
|
||||
events <- askEvents
|
||||
lift $ performEvent $ ffor toInsertAbove $ \new -> do
|
||||
@ -374,21 +465,15 @@ insertImmediateAbove n toInsertAbove = do
|
||||
, _immediateDomBuilderEnv_document = doc
|
||||
, _immediateDomBuilderEnv_events = events
|
||||
}
|
||||
mp <- getParentNode n
|
||||
case mp of
|
||||
Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
|
||||
Just p -> void $ insertBefore p (Just df) (Just n) -- 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
|
||||
df `insertBefore` n
|
||||
return result
|
||||
|
||||
instance SupportsImmediateDomBuilder t m => Deletable t (ImmediateDomBuilderT t m) where
|
||||
{-# INLINABLE deletable #-}
|
||||
deletable delete child = liftThrough (deletable delete) $ do
|
||||
top <- textNodeInternal ("" :: Text)
|
||||
result <- child
|
||||
bottom <- textNodeInternal ("" :: Text)
|
||||
lift $ performEvent_ $ ffor delete $ \_ -> do
|
||||
deleteBetweenInclusive top bottom
|
||||
return result
|
||||
insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()
|
||||
insertBefore new existing = do
|
||||
mp <- getParentNode existing
|
||||
case mp of
|
||||
Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
|
||||
Just p -> void $ DOM.insertBefore p (Just 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
|
||||
@ -497,7 +582,7 @@ type family EventType en where
|
||||
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 -> return ()
|
||||
Dblclick -> getMouseEventCoords
|
||||
Keypress -> getKeyEvent
|
||||
Scroll -> getScrollTop e
|
||||
Keydown -> getKeyEvent
|
||||
@ -547,7 +632,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
|
||||
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 -> return ()
|
||||
Dblclick -> getMouseEventCoords
|
||||
Keypress -> getKeyEvent
|
||||
Scroll -> Window.getScrollY w
|
||||
Keydown -> getKeyEvent
|
||||
@ -796,7 +881,7 @@ getKeyEvent = do
|
||||
getMouseEventCoords :: EventM e MouseEvent (Int, Int)
|
||||
getMouseEventCoords = do
|
||||
e <- event
|
||||
bisequence (getX e, getY e)
|
||||
bisequence (getClientX e, getClientY e)
|
||||
|
||||
instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
|
||||
{-# INLINABLE sample #-}
|
||||
|
||||
@ -7,15 +7,15 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Reflex.Dom.Builder.InputDisabled where
|
||||
|
||||
import Control.Lens
|
||||
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
|
||||
import Reflex
|
||||
import Reflex.Deletable.Class
|
||||
import Reflex.Dom.Builder.Class
|
||||
import Reflex.Host.Class
|
||||
|
||||
@ -47,15 +47,16 @@ instance PerformEvent t m => PerformEvent t (InputDisabledT m) where
|
||||
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 = Map.delete "disabled" <$> _elementConfig_modifyAttributes cfg
|
||||
}
|
||||
|
||||
instance Deletable t m => Deletable t (InputDisabledT m) where
|
||||
deletable d = liftThrough $ deletable d
|
||||
|
||||
instance PostBuild t m => PostBuild t (InputDisabledT m) where
|
||||
getPostBuild = lift getPostBuild
|
||||
|
||||
@ -65,10 +66,16 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabl
|
||||
newEventWithTrigger = lift . newEventWithTrigger
|
||||
newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
|
||||
|
||||
instance MonadAdjust t m => MonadAdjust t (InputDisabledT m) where
|
||||
runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a')
|
||||
sequenceDMapWithAdjust dm0 dm' = InputDisabledT $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
|
||||
|
||||
instance DomBuilder t m => DomBuilder t (InputDisabledT m) where
|
||||
type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m
|
||||
{-
|
||||
placeholder cfg = lift $ placeholder $ cfg
|
||||
& placeholderConfig_insertAbove %~ fmap runInputDisabledT
|
||||
-}
|
||||
inputElement cfg = lift $ inputElement $ cfg
|
||||
{ _inputElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _inputElementConfig_elementConfig cfg
|
||||
}
|
||||
|
||||
@ -20,18 +20,24 @@ 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.Control
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
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.Constant
|
||||
import Data.Functor.Misc
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text.Encoding
|
||||
import Data.Tuple
|
||||
import GHC.Generics
|
||||
import Reflex.Class
|
||||
import Reflex.Dom.Builder.Class
|
||||
@ -43,21 +49,24 @@ import Reflex.PerformEvent.Class
|
||||
import Reflex.PostBuild.Class
|
||||
import Reflex.Spider
|
||||
|
||||
|
||||
newtype StaticDomBuilderT t m a = StaticDomBuilderT
|
||||
{ unStaticDomBuilderT :: StateT [Behavior t ByteString] m a -- Accumulated Html will be in revesed order
|
||||
{ unStaticDomBuilderT :: 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 MonadTransControl (StaticDomBuilderT t) where
|
||||
type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t ByteString]) a
|
||||
type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t Builder]) a
|
||||
liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT
|
||||
restoreT = defaultRestoreT StaticDomBuilderT
|
||||
|
||||
instance MonadTrans (StaticDomBuilderT t) where
|
||||
lift = StaticDomBuilderT . lift
|
||||
|
||||
runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t ByteString)
|
||||
runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t Builder)
|
||||
runStaticDomBuilderT (StaticDomBuilderT a) = do
|
||||
(result, a') <- runStateT a []
|
||||
return (result, mconcat $ reverse a')
|
||||
@ -87,15 +96,6 @@ instance MonadHold t m => MonadHold t (StaticDomBuilderT t m) where
|
||||
{-# INLINABLE holdIncremental #-}
|
||||
holdIncremental v0 v' = lift $ holdIncremental v0 v'
|
||||
|
||||
instance (Reflex t, Monad m, MonadHold t (StateT [Behavior t ByteString] m)) => Deletable t (StaticDomBuilderT t m) where
|
||||
{-# INLINABLE deletable #-}
|
||||
deletable delete (StaticDomBuilderT a) = StaticDomBuilderT $ do
|
||||
(result, a') <- lift $ runStateT a []
|
||||
let html = mconcat $ reverse a'
|
||||
b <- hold html (mempty <$ delete)
|
||||
modify (join b:)
|
||||
return result
|
||||
|
||||
instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilderT t m) where
|
||||
{-# INLINABLE newTriggerEvent #-}
|
||||
newTriggerEvent = return (never, const $ return ())
|
||||
@ -113,7 +113,7 @@ instance MonadRef m => MonadRef (StaticDomBuilderT t m) where
|
||||
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, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
|
||||
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, MonadAdjust t m)
|
||||
|
||||
data StaticDomSpace
|
||||
|
||||
@ -137,19 +137,45 @@ instance DomSpace StaticDomSpace where
|
||||
type RawSelectElement StaticDomSpace = ()
|
||||
addEventSpecFlags _ _ _ _ = StaticEventSpec
|
||||
|
||||
instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
|
||||
runWithReplace a0 a' = do
|
||||
(result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')
|
||||
o <- hold (snd result0) $ snd <$> result'
|
||||
StaticDomBuilderT $ modify $ (:) $ join o
|
||||
return (fst result0, fst <$> result')
|
||||
sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
|
||||
let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0
|
||||
loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
|
||||
mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . runStaticDomBuilderT) mv)) p
|
||||
(children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
|
||||
let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
|
||||
result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
|
||||
mapKeyValuePairsMonotonic (\(WrapArg k :=> mv) -> k :=> fmap snd mv) p
|
||||
outputs0 :: DMap k (Constant (Behavior t Builder))
|
||||
outputs0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (o, _)) -> k :=> Constant o) children0
|
||||
outputs' :: Event t (PatchDMap k (Constant (Behavior t Builder)))
|
||||
outputs' = ffor children' $ \(PatchDMap p) -> PatchDMap $
|
||||
mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Constant . fst . runIdentity) mv)) p
|
||||
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 => DomBuilder t (StaticDomBuilderT t m) where
|
||||
type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace
|
||||
{-# INLINABLE textNode #-}
|
||||
textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do
|
||||
--TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
|
||||
let escape = BL.toStrict . toLazyByteString . fromHtmlEscapedText
|
||||
let escape = fromHtmlEscapedText
|
||||
modify . (:) <=< hold (escape initialContents) $ fmap escape setContents
|
||||
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 toAttr (AttributeName _mns k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""
|
||||
let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
|
||||
es <- newFanEventWithTrigger $ \_ _ -> return (return ())
|
||||
StaticDomBuilderT $ do
|
||||
(result, innerHtml) <- lift $ runStaticDomBuilderT child
|
||||
@ -157,18 +183,12 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
|
||||
let tagBS = encodeUtf8 elementTag
|
||||
if Set.member elementTag voidElements
|
||||
then modify $ (:) $ mconcat [constant ("<" <> tagBS), attrs1, constant " />"]
|
||||
then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
|
||||
else do
|
||||
let open = mconcat [constant ("<" <> tagBS <> " "), attrs1, constant ">"]
|
||||
let close = constant $ "</" <> tagBS <> ">"
|
||||
let open = mconcat [constant ("<" <> byteString tagBS <> " "), attrs1, constant (byteString ">")]
|
||||
let close = constant $ byteString $ "</" <> tagBS <> ">"
|
||||
modify $ (:) $ mconcat [open, innerHtml, close]
|
||||
return (Element es (), result)
|
||||
{-# INLINABLE placeholder #-}
|
||||
placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do
|
||||
result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)
|
||||
acc <- foldDyn (:) [] (fmap snd result)
|
||||
modify $ (:) $ join $ mconcat . reverse <$> current acc
|
||||
return $ Placeholder (fmap fst result) never
|
||||
{-# INLINABLE inputElement #-}
|
||||
inputElement cfg = do
|
||||
(e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
|
||||
@ -215,6 +235,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
|
||||
type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))
|
||||
|
||||
{-# INLINE renderStatic #-}
|
||||
renderStatic :: StaticWidget x a -> IO (a, ByteString)
|
||||
renderStatic w = do
|
||||
runSpiderHost $ do
|
||||
@ -223,4 +244,4 @@ renderStatic w = do
|
||||
mPostBuildTrigger <- readRef postBuildTriggerRef
|
||||
forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
|
||||
bs' <- sample bs
|
||||
return (res, bs')
|
||||
return (res, LBS.toStrict $ toLazyByteString bs')
|
||||
|
||||
@ -15,6 +15,7 @@ module Reflex.Dom.Internal where
|
||||
|
||||
import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
|
||||
|
||||
import qualified Reflex as R
|
||||
import Reflex.Dom.Builder.Immediate
|
||||
import Reflex.Dom.Class
|
||||
import Reflex.Dom.Internal.Foreign
|
||||
@ -74,23 +75,49 @@ type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithWebView x (P
|
||||
attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a
|
||||
attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
|
||||
|
||||
{-# INLINABLE attachWidget' #-}
|
||||
attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
|
||||
attachWidget' rootElement wv w = do
|
||||
mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()
|
||||
mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do
|
||||
let (headWidget, bodyWidget) = widgets
|
||||
Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
|
||||
Just headElement <- getHead doc
|
||||
Just bodyElement <- getBody doc
|
||||
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
|
||||
rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a
|
||||
a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b
|
||||
return ((), postBuildTriggerRef)
|
||||
|
||||
unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
|
||||
unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do
|
||||
Just doc <- getOwnerDocument rootElement
|
||||
Just df <- createDocumentFragment doc
|
||||
let builderEnv = ImmediateDomBuilderEnv
|
||||
{ _immediateDomBuilderEnv_document = doc
|
||||
, _immediateDomBuilderEnv_parent = toNode df
|
||||
, _immediateDomBuilderEnv_events = events
|
||||
}
|
||||
result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
|
||||
setInnerHTML rootElement $ Just ("" :: String)
|
||||
_ <- appendChild rootElement $ Just df
|
||||
return result
|
||||
|
||||
{-# INLINABLE attachWidget' #-}
|
||||
attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
|
||||
attachWidget' rootElement wv w = attachWidget'' $ \events -> do
|
||||
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
|
||||
result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w
|
||||
return (result, postBuildTriggerRef)
|
||||
|
||||
type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
|
||||
|
||||
{-# INLINABLE attachWidget'' #-}
|
||||
attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))
|
||||
attachWidget'' w = do
|
||||
events <- newChan
|
||||
(result, fc@(FireCommand fire)) <- runSpiderHost $ do
|
||||
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
|
||||
let builderEnv = ImmediateDomBuilderEnv
|
||||
{ _immediateDomBuilderEnv_document = doc
|
||||
, _immediateDomBuilderEnv_parent = toNode df
|
||||
, _immediateDomBuilderEnv_events = events
|
||||
}
|
||||
results@(_, FireCommand fire) <- hostPerformEventT $ runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
|
||||
((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
|
||||
mPostBuildTrigger <- readRef postBuildTriggerRef
|
||||
forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
|
||||
return results
|
||||
return (result, fc)
|
||||
void $ forkIO $ forever $ do
|
||||
ers <- readChan events
|
||||
_ <- postGUISync $ runSpiderHost $ do
|
||||
@ -100,8 +127,6 @@ attachWidget' rootElement wv w = do
|
||||
_ <- fire (catMaybes mes) $ return ()
|
||||
liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
|
||||
return ()
|
||||
setInnerHTML rootElement $ Just (""::String)
|
||||
_ <- appendChild rootElement $ Just df
|
||||
return (result, fc)
|
||||
|
||||
-- | Run a reflex-dom application inside of an existing DOM element with the given ID
|
||||
|
||||
@ -24,7 +24,6 @@ module Reflex.Dom.Old
|
||||
, buildElementNS
|
||||
, buildEmptyElement
|
||||
, buildEmptyElementNS
|
||||
, deleteBetweenExclusive
|
||||
, elDynHtml'
|
||||
, elDynHtmlAttr'
|
||||
, elStopPropagationNS
|
||||
@ -46,7 +45,6 @@ module Reflex.Dom.Old
|
||||
import Control.Arrow (first)
|
||||
import Control.Lens (makeLenses, (%~), (&), (.~), (^.))
|
||||
import Control.Monad
|
||||
import Control.Monad.Exception
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
@ -64,7 +62,7 @@ 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, getParentNode, getPreviousSibling, removeChild, toNode)
|
||||
import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)
|
||||
import GHCJS.DOM.Types (IsElement, IsNode)
|
||||
import qualified GHCJS.DOM.Types as DOM
|
||||
import Reflex.Class
|
||||
@ -104,8 +102,6 @@ type MonadWidgetConstraints t m =
|
||||
, TriggerEvent t m
|
||||
, HasWebView m
|
||||
, HasWebView (Performable m)
|
||||
, MonadAsyncException m
|
||||
, MonadAsyncException (Performable m)
|
||||
, MonadRef m
|
||||
, Ref m ~ Ref IO
|
||||
, MonadRef (Performable m)
|
||||
@ -162,20 +158,6 @@ addDynamicAttributes attrs cfg = do
|
||||
buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)
|
||||
buildElementCommon elementTag child cfg = element elementTag cfg child
|
||||
|
||||
-- | s and e must both be children of the same node and s must precede e
|
||||
deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
|
||||
deleteBetweenExclusive s e = do
|
||||
mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> do
|
||||
let go = do
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
when (toNode s /= toNode x) $ do
|
||||
_ <- removeChild currentParent $ Just x
|
||||
go
|
||||
go
|
||||
|
||||
onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
|
||||
onEventName = elementOnEventName
|
||||
|
||||
|
||||
@ -51,17 +51,19 @@ data WebSocketConfig t a
|
||||
instance Reflex t => Default (WebSocketConfig t a) where
|
||||
def = WebSocketConfig never never True
|
||||
|
||||
data WebSocket t
|
||||
= WebSocket { _webSocket_recv :: Event t ByteString
|
||||
, _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
|
||||
)
|
||||
}
|
||||
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
|
||||
)
|
||||
}
|
||||
|
||||
-- This can be used to send either binary or text messages for the same websocket connection
|
||||
instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
|
||||
@ -70,7 +72,10 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit
|
||||
|
||||
|
||||
webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
|
||||
webSocket url config = do
|
||||
webSocket url config = webSocket' url config onBSMessage
|
||||
|
||||
webSocket' :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> b) -> m (RawWebSocket t b)
|
||||
webSocket' url config onRawMessage = do
|
||||
wv <- fmap unWebViewSingleton askWebView
|
||||
(eRecv, onMessage) <- newTriggerEvent
|
||||
currentSocketRef <- liftIO $ newIORef Nothing
|
||||
@ -91,7 +96,7 @@ webSocket url config = do
|
||||
liftIO $ threadDelay 1000000
|
||||
start
|
||||
start = do
|
||||
ws <- liftIO $ newWebSocket wv url onMessage onOpen onError onClose
|
||||
ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onError onClose
|
||||
liftIO $ writeIORef currentSocketRef $ Just ws
|
||||
return ()
|
||||
performEvent_ . (liftIO start <$) =<< getPostBuild
|
||||
@ -116,6 +121,6 @@ webSocket url config = do
|
||||
`catch`
|
||||
(\(_ :: SomeException) -> return False))
|
||||
unless success $ atomically $ unGetTQueue payloadQueue payload
|
||||
return $ WebSocket eRecv eOpen eError eClose
|
||||
return $ RawWebSocket eRecv eOpen eError eClose
|
||||
|
||||
makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
|
||||
|
||||
@ -97,7 +97,6 @@ import Data.Functor.Misc
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Data.Semigroup
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
@ -106,11 +105,8 @@ import Data.These
|
||||
import Data.Traversable
|
||||
import Prelude hiding (mapM, mapM_, sequence, sequence_)
|
||||
|
||||
widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
|
||||
widgetHoldInternal child0 child' = do
|
||||
childResult0 <- deletable (void child') child0
|
||||
childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'
|
||||
return (childResult0, _placeholder_insertedAbove childResult')
|
||||
widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
|
||||
widgetHoldInternal = runWithReplace
|
||||
|
||||
-- | 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.
|
||||
@ -131,26 +127,12 @@ partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
|
||||
|
||||
newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
|
||||
|
||||
listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m, MonadFix m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
|
||||
listHoldWithKey initialChildren modifyChildren buildChild = do
|
||||
let deleteChildSelector = fanMap $ fmap void modifyChildren
|
||||
liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren
|
||||
let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren
|
||||
buildAugmentedChild :: k -> v -> m (ChildResult t k a)
|
||||
buildAugmentedChild k v = do
|
||||
let delete = select deleteChildSelector $ Const2 k
|
||||
myCfg = def
|
||||
& insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)
|
||||
& deleteSelf .~ delete
|
||||
ph <- placeholder myCfg
|
||||
result <- deletable delete $ buildChild k v
|
||||
return $ ChildResult (result, (fmap Just <$> _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed
|
||||
rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
|
||||
augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
|
||||
let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults
|
||||
belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
|
||||
let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll
|
||||
return $ fmap (fmap (fst . unChildResult)) augmentedResults
|
||||
listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
|
||||
listHoldWithKey m0 m' f = do
|
||||
let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
|
||||
dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
|
||||
(a0, a') <- sequenceDMapWithAdjust dm0 dm'
|
||||
fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
|
||||
|
||||
text :: DomBuilder t m => Text -> m ()
|
||||
text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
|
||||
|
||||
Loading…
Reference in New Issue
Block a user