ec7373e · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Eliminate placeholder/deletable

ec7373eRyan Trinkle10 years ago

src/Foreign/JavaScript/TH.hs+5−5

compare with develop

unifiedsplit

@@ -21,7 +21,6 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH

21 ) where

23import Reflex.Class

24−import Reflex.Deletable.Class

25import Reflex.DynamicWriter

24import Reflex.DynamicWriter

26import Reflex.PerformEvent.Base

25import Reflex.PerformEvent.Base

27import Reflex.PerformEvent.Class

26import Reflex.PerformEvent.Class

@@ -81,6 +80,8 @@ import Data.Monoid

81import Data.Text (Text)

80import Data.Text (Text)

82import qualified Data.Text as T

81import qualified Data.Text as T

83+import Unsafe.Coerce

84+

84class Monad m => HasWebView m where

85class Monad m => HasWebView m where

85 type WebViewPhantom m :: *

86 type WebViewPhantom m :: *

86 askWebView :: m (WebViewSingleton (WebViewPhantom m))

87 askWebView :: m (WebViewSingleton (WebViewPhantom m))

@@ -111,6 +112,9 @@ instance HasWebView m => HasWebView (DynamicWriterT t w m) where

111

112

112newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

113newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

113

114

115+instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where

116+ sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (unsafeCoerce dm')

117+

114instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

118instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

115 {-# INLINABLE newEventWithTrigger #-}

119 {-# INLINABLE newEventWithTrigger #-}

116 newEventWithTrigger = lift . newEventWithTrigger

120 newEventWithTrigger = lift . newEventWithTrigger

@@ -154,10 +158,6 @@ instance PerformEvent t m => PerformEvent t (WithWebView x m) where

154 {-# INLINABLE performEvent #-}

158 {-# INLINABLE performEvent #-}

155 performEvent e = liftWith $ \run -> performEvent $ fmap run e

159 performEvent e = liftWith $ \run -> performEvent $ fmap run e

156

160

157−instance Deletable t m => Deletable t (WithWebView x m) where

158− {-# INLINABLE deletable #-}

159− deletable = liftThrough . deletable

160−

161runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a

162runWithWebView = runReaderT . unWithWebView

163

src/Reflex/Dom/Builder/Class.hs+6−40

@@ -18,12 +18,10 @@

18module Reflex.Dom.Builder.Class

19 ( module Reflex.Dom.Builder.Class

20 , module Reflex.Dom.Builder.Class.Events

21− , module Reflex.Deletable.Class

22 ) where

21 ) where

24import Reflex.Class as Reflex

23import Reflex.Class as Reflex

25import Reflex.Dom.Builder.Class.Events

24import Reflex.Dom.Builder.Class.Events

26−import Reflex.Deletable.Class

27import Reflex.DynamicWriter

25import Reflex.DynamicWriter

28import Reflex.PerformEvent.Class

26import Reflex.PerformEvent.Class

29import Reflex.PostBuild.Class

27import Reflex.PostBuild.Class

@@ -34,16 +32,13 @@ import Control.Monad.Reader

34import Control.Monad.State.Strict

32import Control.Monad.State.Strict

35import Control.Monad.Trans.Control

33import Control.Monad.Trans.Control

36import Data.Default

34import Data.Default

37−import Data.Foldable

38import Data.Functor.Misc

35import Data.Functor.Misc

39−import Data.List.NonEmpty (NonEmpty, nonEmpty)

40import Data.Map (Map)

36import Data.Map (Map)

41import qualified Data.Map as Map

37import qualified Data.Map as Map

42import Data.Proxy

38import Data.Proxy

43import Data.Semigroup

39import Data.Semigroup

44import Data.String

40import Data.String

45import Data.Text (Text)

41import Data.Text (Text)

46−import Data.Traversable

47import Data.Type.Coercion

42import Data.Type.Coercion

48import GHC.Exts (Constraint)

43import GHC.Exts (Constraint)

@@ -65,7 +60,7 @@ liftElementConfig cfg = cfg

66-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

61-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

67-- dynamic DOM in the 'Reflex' timeline @t@

62-- dynamic DOM in the 'Reflex' timeline @t@

68−class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where

63+class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomBuilder t m | m -> t where

69 type DomBuilderSpace m :: *

64 type DomBuilderSpace m :: *

70 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

65 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

71 default textNode :: ( MonadTrans f

66 default textNode :: ( MonadTrans f

@@ -86,9 +81,11 @@ class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBui

86 => Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)

81 => Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)

87 element t cfg child = liftWith $ \run -> element t (liftElementConfig cfg) $ run child

82 element t cfg child = liftWith $ \run -> element t (liftElementConfig cfg) $ run child

88 {-# INLINABLE element #-}

83 {-# INLINABLE element #-}

84+ {-

89 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it

85 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it

90 -- 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

86 -- 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

91 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)

87 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)

88+-}

92 inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)

89 inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)

93 default inputElement :: ( MonadTransControl f

90 default inputElement :: ( MonadTransControl f

94 , m ~ f m'

91 , m ~ f m'

@@ -403,13 +400,6 @@ instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (ElementConfig

403

400

404instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where

401instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where

405 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

402 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

406− {-# INLINABLE placeholder #-}

407− placeholder cfg = lift $ do

408− rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p

409− p <- placeholder $ cfg

410− { _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild

411− }

412− return p

413 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

403 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

414

404

415instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

405instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

@@ -421,32 +411,6 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

421 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s

411 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s

422 put newS

412 put newS

423 return (el, a)

413 return (el, a)

424− placeholder cfg = do

425− let cfg' = cfg

426− { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg

427− }

428− let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order

429− -> Event t () -- ^ No more nodes will be added after this event fires

430− -> m (Replaceable t (Dynamic t w))

431− manageChildren newChildren additionsCeased = do

432− rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around

433− let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))

434− numberedNewChildren = flip pushAlways newChildren $ \rcs -> do

435− let cs = reverse $ toList rcs

436− myFirstId <- sample nextId

437− let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs

438− return (myNextId, PatchMap $ Map.fromList numbered)

439− newNextId = fst <$> numberedNewChildren

440− mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased

441− rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf

442− p <- DynamicWriterT $ do

443− modify (children:)

444− lift $ placeholder cfg'

445− let result = fst <$> _placeholder_insertedAbove p

446− childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p

447− return $ p

448− { _placeholder_insertedAbove = result

449− }

450 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig

414 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig

451 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig

415 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig

452 selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do

416 selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do

@@ -460,6 +424,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

460 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

424 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

461 }

425 }

462

426

427+

463-- * Convenience functions

428-- * Convenience functions

464

429

465--TODO: Move/replace

430--TODO: Move/replace

@@ -521,7 +486,6 @@ instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where

521

486

522instance DomBuilder t m => DomBuilder t (ReaderT r m) where

487instance DomBuilder t m => DomBuilder t (ReaderT r m) where

523 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m

488 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m

524− placeholder = liftPlaceholder

525

489

526type LiftDomBuilder t f m =

490type LiftDomBuilder t f m =

527 ( Reflex t

491 ( Reflex t

@@ -555,8 +519,10 @@ liftTextNode = lift . textNode

555liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (f m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)

519liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (f m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)

556liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag (fmap1 run cfg) $ run child

520liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag (fmap1 run cfg) $ run child

557

521

522+{-

558liftPlaceholder :: LiftDomBuilder t f m => PlaceholderConfig above t (f m) -> f m (Placeholder above t)

523liftPlaceholder :: LiftDomBuilder t f m => PlaceholderConfig above t (f m) -> f m (Placeholder above t)

559liftPlaceholder cfg = liftWithStateless $ \run -> placeholder $ fmap1 run cfg

524liftPlaceholder cfg = liftWithStateless $ \run -> placeholder $ fmap1 run cfg

525+-}

560

526

561liftInputElement :: LiftDomBuilder t f m => InputElementConfig er t (f m) -> f m (InputElement er (DomBuilderSpace m) t)

527liftInputElement :: LiftDomBuilder t f m => InputElementConfig er t (f m) -> f m (InputElement er (DomBuilderSpace m) t)

562liftInputElement cfg = liftWithStateless $ \run -> inputElement $ fmap1 run cfg

528liftInputElement cfg = liftWithStateless $ \run -> inputElement $ fmap1 run cfg

src/Reflex/Dom/Builder/Immediate.hs+69−20

@@ -9,6 +9,7 @@

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE RecursiveDo #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TemplateHaskell #-}

14{-# LANGUAGE TemplateHaskell #-}

14{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeFamilies #-}

@@ -35,10 +36,15 @@ import Data.Default

35import Data.Dependent.Map (DMap)

36import Data.Dependent.Map (DMap)

36import qualified Data.Dependent.Map as DMap

37import qualified Data.Dependent.Map as DMap

37import Data.Dependent.Sum

38import Data.Dependent.Sum

39+import Data.Functor.Compose

38import Data.Functor.Misc

40import Data.Functor.Misc

39import Data.IORef

41import Data.IORef

42+import Data.Map (Map)

43+import qualified Data.Map as Map

40import Data.Maybe

44import Data.Maybe

41import Data.Monoid

45import Data.Monoid

46+import Data.Some (Some)

47+import qualified Data.Some as Some

42import Data.Text (Text)

48import Data.Text (Text)

43import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

49import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

44import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

50import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

@@ -51,8 +57,9 @@ import qualified GHCJS.DOM.HTMLInputElement as Input

51import qualified GHCJS.DOM.HTMLSelectElement as Select

57import qualified GHCJS.DOM.HTMLSelectElement as Select

52import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

58import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

53import GHCJS.DOM.MouseEvent

59import GHCJS.DOM.MouseEvent

54−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,

60+import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling,

55 removeChild, setNodeValue, toNode)

61 removeChild, setNodeValue, toNode)

62+import qualified GHCJS.DOM.Node as DOM

56import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

63import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

57 WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

64 WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

58 castToHTMLTextAreaElement)

65 castToHTMLTextAreaElement)

@@ -121,15 +128,28 @@ deleteBetweenInclusive s e = do

121 case mCurrentParent of

128 case mCurrentParent of

122 Nothing -> return () --TODO: Is this the right behavior?

129 Nothing -> return () --TODO: Is this the right behavior?

123 Just currentParent -> do

130 Just currentParent -> do

124− let go = do

131+ deleteUpToGivenParent currentParent s e

125− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

126− _ <- removeChild currentParent $ Just x

127− when (toNode s /= toNode x) go

128− go

129 _ <- removeChild currentParent $ Just e

132 _ <- removeChild currentParent $ Just e

130 return ()

133 return ()

131

134

135+-- | 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

136+{-# INLINABLE deleteUpTo #-}

137+deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

138+deleteUpTo s e = do

139+ 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

140+ case mCurrentParent of

141+ Nothing -> return () --TODO: Is this the right behavior?

142+ Just currentParent -> deleteUpToGivenParent currentParent s e

143+

144+{-# INLINABLE deleteUpToGivenParent #-}

145+deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

146+deleteUpToGivenParent currentParent s e = do

147+ fix $ \loop -> do

148+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

149+ _ <- removeChild currentParent $ Just x

150+ when (toNode s /= toNode x) loop

151+

132−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)

152+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)

133

153

134newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

154newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

135

155

@@ -248,6 +268,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

248 return $ TextNode n

268 return $ TextNode n

249 {-# INLINABLE element #-}

269 {-# INLINABLE element #-}

250 element elementTag cfg child = fst <$> makeElement elementTag cfg child

270 element elementTag cfg child = fst <$> makeElement elementTag cfg child

271+ {-

251 {-# INLINABLE placeholder #-}

272 {-# INLINABLE placeholder #-}

252 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do

273 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do

253 n <- textNodeInternal ("" :: Text)

274 n <- textNodeInternal ("" :: Text)

@@ -257,6 +278,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

257 mp <- getParentNode n

278 mp <- getParentNode n

258 forM_ mp $ \p -> removeChild p $ Just n

279 forM_ mp $ \p -> removeChild p $ Just n

259 return $ Placeholder insertedAbove deleted

280 return $ Placeholder insertedAbove deleted

281+-}

260 {-# INLINABLE inputElement #-}

282 {-# INLINABLE inputElement #-}

261 inputElement cfg = do

283 inputElement cfg = do

262 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

284 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

@@ -354,6 +376,39 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

354 placeRawElement = append

376 placeRawElement = append

355 wrapRawElement = wrap

377 wrapRawElement = wrap

356

378

379+instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

380+ sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do

381+ initialEnv <- ImmediateDomBuilderT ask

382+ let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

383+ 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.

384+ drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

385+ drawChildUpdate child = do

386+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

387+ runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv

388+ { _immediateDomBuilderEnv_parent = toNode df

389+ }

390+ updateChildren = ffor dm' $ \(PatchDMap p) -> PatchDMap $

391+ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap drawChildUpdate mv)) p

392+ (children0, children') <- lift $ sequenceDMapWithAdjust (mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> drawChildInitial v) dm0) (updateChildren :: Event t (PatchDMap (DMap (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) m))) --TODO: Update stuff

393+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, _, v)) -> k :=> Identity v) children0

394+ placeholders0 = dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, ph, _)) -> Const2 (Some.This k) :=> Identity ph) children0

395+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

396+ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> k :=> fmap (\(_, _, r) -> r) v) p

397+ placeholders' = ffor children' $ \(PatchDMap p) -> PatchMap $

398+ dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> Const2 (Some.This k) :=> Identity (fmap ((\(_, ph, _) -> ph) . runIdentity) (getCompose v))) p

399+ placeholders :: Behavior t (Map (Some k) DOM.Text) <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

400+ lastPlaceholder <- textNodeInternal ("" :: Text)

401+ performEvent_ $ flip push children' $ \(PatchDMap p) -> do

402+ phs <- sample placeholders

403+ if DMap.null p then return Nothing else return $ Just $ do

404+ let f :: DSum (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) (Compose Maybe Identity) -> Performable m ()

405+ f (WrapArg k :=> Compose mv) = do

406+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

407+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

408+ forM_ mv $ \(Identity (df, _, _)) -> df `insertBefore` nextPlaceholder

409+ mapM_ f $ DMap.toList p

410+ return (result0, result')

411+

357mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

412mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

358mkHasFocus e = do

413mkHasFocus e = do

359 let initialFocus = False --TODO: Actually get the initial focus of the element

414 let initialFocus = False --TODO: Actually get the initial focus of the element

@@ -374,21 +429,15 @@ insertImmediateAbove n toInsertAbove = do

374 , _immediateDomBuilderEnv_document = doc

429 , _immediateDomBuilderEnv_document = doc

375 , _immediateDomBuilderEnv_events = events

430 , _immediateDomBuilderEnv_events = events

376 }

431 }

377− mp <- getParentNode n

432+ df `insertBefore` n

378− case mp of

379− Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()

380− 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

381 return result

433 return result

382

434

383−instance SupportsImmediateDomBuilder t m => Deletable t (ImmediateDomBuilderT t m) where

435+insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()

384− {-# INLINABLE deletable #-}

436+insertBefore new existing = do

385− deletable delete child = liftThrough (deletable delete) $ do

437+ mp <- getParentNode existing

386− top <- textNodeInternal ("" :: Text)

438+ case mp of

387− result <- child

439+ Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()

388− bottom <- textNodeInternal ("" :: Text)

440+ 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

389− lift $ performEvent_ $ ffor delete $ \_ -> do

390− deleteBetweenInclusive top bottom

391− return result

392

441

393instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

442instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

394 type Performable (ImmediateDomBuilderT t m) = Performable m

443 type Performable (ImmediateDomBuilderT t m) = Performable m

src/Reflex/Dom/Builder/InputDisabled.hs+8−5

@@ -7,18 +7,19 @@

7{-# LANGUAGE UndecidableInstances #-}

8module Reflex.Dom.Builder.InputDisabled where

10−import Control.Lens

11import Control.Monad.Fix

10import Control.Monad.Fix

12import Control.Monad.Ref

11import Control.Monad.Ref

13import Control.Monad.Trans

12import Control.Monad.Trans

14import Control.Monad.Trans.Control

13import Control.Monad.Trans.Control

14+import Data.Coerce

15import qualified Data.Map as Map

16import Foreign.JavaScript.TH

17import Reflex

18−import Reflex.Deletable.Class

19import Reflex.Dom.Builder.Class

18import Reflex.Dom.Builder.Class

20import Reflex.Host.Class

19import Reflex.Host.Class

21+import Unsafe.Coerce

22+

22-- | A DomBuilder transformer that disables all 'inputElement's,

23-- | A DomBuilder transformer that disables all 'inputElement's,

23-- 'textAreaElement's, and 'selectElement's by adding the "disabled" HTML

24-- 'textAreaElement's, and 'selectElement's by adding the "disabled" HTML

24-- attribute. Note that 'element's that happen to have "input", "textarea", or

25-- attribute. Note that 'element's that happen to have "input", "textarea", or

@@ -53,9 +54,6 @@ disableElementConfig cfg = cfg

53 , _elementConfig_modifyAttributes = Map.delete "disabled" <$> _elementConfig_modifyAttributes cfg

54 , _elementConfig_modifyAttributes = Map.delete "disabled" <$> _elementConfig_modifyAttributes cfg

54 }

55 }

56−instance Deletable t m => Deletable t (InputDisabledT m) where

57− deletable d = liftThrough $ deletable d

58−

59instance PostBuild t m => PostBuild t (InputDisabledT m) where

57instance PostBuild t m => PostBuild t (InputDisabledT m) where

60 getPostBuild = lift getPostBuild

58 getPostBuild = lift getPostBuild

@@ -65,10 +63,15 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabl

65 newEventWithTrigger = lift . newEventWithTrigger

63 newEventWithTrigger = lift . newEventWithTrigger

66 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

64 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

66+instance MonadAdjust t m => MonadAdjust t (InputDisabledT m) where

67+ sequenceDMapWithAdjust dm0 dm' = InputDisabledT $ sequenceDMapWithAdjust (coerce dm0) (unsafeCoerce dm') --TODO: Eliminate unsafeCoerce

68+

68instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

69instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

69 type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m

70 type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m

71+ {-

70 placeholder cfg = lift $ placeholder $ cfg

72 placeholder cfg = lift $ placeholder $ cfg

71 & placeholderConfig_insertAbove %~ fmap runInputDisabledT

73 & placeholderConfig_insertAbove %~ fmap runInputDisabledT

74+ -}

72 inputElement cfg = lift $ inputElement $ cfg

75 inputElement cfg = lift $ inputElement $ cfg

73 { _inputElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _inputElementConfig_elementConfig cfg

76 { _inputElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _inputElementConfig_elementConfig cfg

74 }

77 }

src/Reflex/Dom/Builder/Static.hs+30−17

@@ -24,14 +24,21 @@ import Control.Monad.Ref

24import Control.Monad.State.Strict

25import Control.Monad.Trans.Control

26import Data.ByteString (ByteString)

27+import qualified Data.ByteString as BS

27import Data.ByteString.Builder (toLazyByteString)

28import Data.ByteString.Builder (toLazyByteString)

28import qualified Data.ByteString.Lazy as BL

29import qualified Data.ByteString.Lazy as BL

29import Data.Default

30import Data.Default

31+import Data.Dependent.Map (DMap)

32+import qualified Data.Dependent.Map as DMap

30import Data.Dependent.Sum (DSum (..))

33import Data.Dependent.Sum (DSum (..))

34+import Data.Functor.Compose

35+import Data.Functor.Constant

36+import Data.Functor.Misc

31import qualified Data.Map as Map

37import qualified Data.Map as Map

32import Data.Monoid

38import Data.Monoid

33import qualified Data.Set as Set

39import qualified Data.Set as Set

34import Data.Text.Encoding

40import Data.Text.Encoding

41+import Data.Tuple

35import GHC.Generics

42import GHC.Generics

36import Reflex.Class

43import Reflex.Class

37import Reflex.Dom.Builder.Class

44import Reflex.Dom.Builder.Class

@@ -45,7 +52,7 @@ import Reflex.Spider

47newtype StaticDomBuilderT t m a = StaticDomBuilderT

54newtype StaticDomBuilderT t m a = StaticDomBuilderT

48− { unStaticDomBuilderT :: StateT [Behavior t ByteString] m a -- Accumulated Html will be in revesed order

55+ { unStaticDomBuilderT :: StateT [Behavior t ByteString] m a -- Accumulated Html will be in reversed order

49 }

56 }

50 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

57 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

@@ -87,15 +94,6 @@ instance MonadHold t m => MonadHold t (StaticDomBuilderT t m) where

87 {-# INLINABLE holdIncremental #-}

94 {-# INLINABLE holdIncremental #-}

88 holdIncremental v0 v' = lift $ holdIncremental v0 v'

95 holdIncremental v0 v' = lift $ holdIncremental v0 v'

90−instance (Reflex t, Monad m, MonadHold t (StateT [Behavior t ByteString] m)) => Deletable t (StaticDomBuilderT t m) where

91− {-# INLINABLE deletable #-}

92− deletable delete (StaticDomBuilderT a) = StaticDomBuilderT $ do

93− (result, a') <- lift $ runStateT a []

94− let html = mconcat $ reverse a'

95− b <- hold html (mempty <$ delete)

96− modify (join b:)

97− return result

98−

99instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilderT t m) where

97instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilderT t m) where

100 {-# INLINABLE newTriggerEvent #-}

98 {-# INLINABLE newTriggerEvent #-}

101 newTriggerEvent = return (never, const $ return ())

99 newTriggerEvent = return (never, const $ return ())

@@ -113,7 +111,7 @@ instance MonadRef m => MonadRef (StaticDomBuilderT t m) where

113instance MonadAtomicRef m => MonadAtomicRef (StaticDomBuilderT t m) where

111instance MonadAtomicRef m => MonadAtomicRef (StaticDomBuilderT t m) where

114 atomicModifyRef r = lift . atomicModifyRef r

112 atomicModifyRef r = lift . atomicModifyRef r

115

113

116−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)

114+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)

117

115

118data StaticDomSpace

116data StaticDomSpace

119

117

@@ -137,6 +135,27 @@ instance DomSpace StaticDomSpace where

137 type RawSelectElement StaticDomSpace = ()

135 type RawSelectElement StaticDomSpace = ()

138 addEventSpecFlags _ _ _ _ = StaticEventSpec

136 addEventSpecFlags _ _ _ _ = StaticEventSpec

139

137

138+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where

139+ sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

140+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0

141+ loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

142+ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap (fmap swap . runStaticDomBuilderT) mv)) p

143+ (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

144+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

145+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

146+ mapKeyValuePairsMonotonic (\(WrapArg k :=> mv) -> k :=> fmap snd mv) p

147+ outputs0 :: DMap k (Constant (Behavior t ByteString))

148+ outputs0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (o, _)) -> k :=> Constant o) children0

149+ outputs' :: Event t (PatchDMap (DMap k (Constant (Behavior t ByteString))))

150+ outputs' = ffor children' $ \(PatchDMap p) -> PatchDMap $

151+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> k :=> Compose (fmap (Constant . fst . runIdentity) mv)) p

152+ outputs <- holdIncremental outputs0 outputs'

153+ StaticDomBuilderT $ modify $ (:) $ pull $ do

154+ os <- sample $ currentIncremental outputs

155+ fmap BS.concat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do

156+ sample o

157+ return (result0, result')

158+

140instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

159instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

141 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

160 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

142 {-# INLINABLE textNode #-}

161 {-# INLINABLE textNode #-}

@@ -163,12 +182,6 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

163 let close = constant $ "</" <> tagBS <> ">"

182 let close = constant $ "</" <> tagBS <> ">"

164 modify $ (:) $ mconcat [open, innerHtml, close]

183 modify $ (:) $ mconcat [open, innerHtml, close]

165 return (Element es (), result)

184 return (Element es (), result)

166− {-# INLINABLE placeholder #-}

167− placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do

168− result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)

169− acc <- foldDyn (:) [] (fmap snd result)

170− modify $ (:) $ join $ mconcat . reverse <$> current acc

171− return $ Placeholder (fmap fst result) never

172 {-# INLINABLE inputElement #-}

185 {-# INLINABLE inputElement #-}

173 inputElement cfg = do

186 inputElement cfg = do

174 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

187 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

src/Reflex/Dom/Old.hs−3

@@ -43,7 +43,6 @@ module Reflex.Dom.Old

43import Control.Arrow (first)

44import Control.Lens (makeLenses, (%~), (&), (.~), (^.))

45import Control.Monad

46−import Control.Monad.Exception

47import Control.Monad.Fix

46import Control.Monad.Fix

48import Control.Monad.IO.Class

47import Control.Monad.IO.Class

49import Control.Monad.Reader

48import Control.Monad.Reader

@@ -95,8 +94,6 @@ type MonadWidgetConstraints t m =

95 , TriggerEvent t m

94 , TriggerEvent t m

96 , HasWebView m

95 , HasWebView m

97 , HasWebView (Performable m)

96 , HasWebView (Performable m)

98− , MonadAsyncException m

99− , MonadAsyncException (Performable m)

100 , MonadRef m

97 , MonadRef m

101 , Ref m ~ Ref IO

98 , Ref m ~ Ref IO

102 , MonadRef (Performable m)

99 , MonadRef (Performable m)

src/Reflex/Dom/Widget/Basic.hs+32−25

@@ -91,26 +91,34 @@ import Control.Lens hiding (children, element)

91import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

92import Data.Align

93import Data.Default

94+import Data.Dependent.Map (DMap, GCompare)

95+import qualified Data.Dependent.Map as DMap

94import Data.Either

96import Data.Either

95import Data.Foldable

97import Data.Foldable

98+import Data.Functor.Compose

96import Data.Functor.Misc

99import Data.Functor.Misc

97import Data.Map (Map)

100import Data.Map (Map)

98import qualified Data.Map as Map

101import qualified Data.Map as Map

99import Data.Maybe

102import Data.Maybe

100−import Data.Semigroup

101import Data.Set (Set)

103import Data.Set (Set)

102import qualified Data.Set as Set

104import qualified Data.Set as Set

105+import Data.Some (Some)

106+import qualified Data.Some as Some

103import Data.Text (Text)

107import Data.Text (Text)

104import qualified Data.Text as T

108import qualified Data.Text as T

105import Data.These

109import Data.These

106import Data.Traversable

110import Data.Traversable

107import Prelude hiding (mapM, mapM_, sequence, sequence_)

111import Prelude hiding (mapM, mapM_, sequence, sequence_)

108

112

113+--TODO: Implement this specially

109−widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

114+widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

110widgetHoldInternal child0 child' = do

115widgetHoldInternal child0 child' = do

111− childResult0 <- deletable (void child') child0

116+ (result0, result') <- sequenceDMapWithAdjust (DMap.singleton LeftTag child0) $ fmap (PatchDMap . DMap.insert LeftTag (Compose Nothing) . DMap.singleton RightTag . Compose . Just) child'

112− childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'

117+ let e :: forall x. x

113− return (childResult0, _placeholder_insertedAbove childResult')

118+ e = error "widgetHoldInternal: missing child (should be impossible)"

119+ return ( runIdentity $ DMap.findWithDefault e LeftTag result0

120+ , ffor result' $ \(PatchDMap p) -> runIdentity $ fromMaybe e $ getCompose $ DMap.findWithDefault e RightTag p

121+ )

114

122

115-- | 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.

123-- | 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.

116-- 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.

124-- 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.

@@ -129,28 +137,27 @@ partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0

129 then go t geq

137 then go t geq

130 else (Left h, lt) : go t geq

138 else (Left h, lt) : go t geq

131

139

140+partitionDMapBySetLT :: forall k v. GCompare k => Set (Some k) -> DMap k v -> Map (Either (Some k) ()) (DMap k v)

141+partitionDMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0

142+ where go :: [Some k] -> DMap k v -> [(Either (Some k) (), DMap k v)]

143+ go [] m = if DMap.null m

144+ then []

145+ else [(Right (), m)]

146+ go (sh@(Some.This h) : t) m =

147+ let (lt, eq, gt) = DMap.splitLookup h m

148+ geq = maybe id (DMap.insert h) eq gt

149+ in if DMap.null lt

150+ then go t geq

151+ else (Left sh, lt) : go t geq

152+

132newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }

153newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }

133

154

134−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))

155+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))

135−listHoldWithKey initialChildren modifyChildren buildChild = do

156+listHoldWithKey m0 m' f = do

136− let deleteChildSelector = fanMap $ fmap void modifyChildren

157+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

137− liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren

158+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> Compose $ fmap (f k) v)) m'

138− let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren

159+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'

139− buildAugmentedChild :: k -> v -> m (ChildResult t k a)

160+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time

140− buildAugmentedChild k v = do

141− let delete = select deleteChildSelector $ Const2 k

142− myCfg = def

143− & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)

144− & deleteSelf .~ delete

145− ph <- placeholder myCfg

146− result <- deletable delete $ buildChild k v

147− 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

148− rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild

149− augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove

150− let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults

151− belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())

152− let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll

153− return $ fmap (fmap (fst . unChildResult)) augmentedResults

154

161

155text :: DomBuilder t m => Text -> m ()

162text :: DomBuilder t m => Text -> m ()

156text t = void $ textNode $ def & textNodeConfig_initialContents .~ t

163text t = void $ textNode $ def & textNodeConfig_initialContents .~ t