@@ -1,4 +1,4 @@
1−{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, RecursiveDo #-}
1+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, RecursiveDo, ScopedTypeVariables, LambdaCase, GADTs #-}
22module Reflex.Dom.DynamicWriter where
33
44import Reflex
@@ -14,11 +14,85 @@ import Control.Monad.State.Strict
1414import Control.Monad.Reader
1515import Control.Monad.Ref
1616import Control.Monad.Exception
17+import Data.Map (Map)
18+import qualified Data.Map as Map
19+import Data.Dependent.Map (DMap)
20+import Data.List.NonEmpty (NonEmpty, nonEmpty)
21+import Data.Functor.Compose
22+import Data.Functor.Misc
23+import Data.Semigroup
24+import Data.Foldable
25+import Data.Traversable
1726
1827instance MonadTrans (DynamicWriterT t w) where
1928 lift = DynamicWriterT . lift
2029
21−newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
30+data PatchMap a where
31+ PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
32+
33+instance Patch PatchMap where
34+ apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
35+ where insertions = Map.mapMaybeWithKey (const id) p
36+ deletions = Map.mapMaybeWithKey (const nothingToJust) p
37+ nothingToJust = \case
38+ Nothing -> Just ()
39+ Just _ -> Nothing
40+
41+instance Ord k => Semigroup (PatchMap (Map k v)) where
42+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
43+ -- PatchMap is idempotent, so stimes n is id for every n
44+#if MIN_VERSION_semigroups(0,17,0)
45+ stimes = stimesIdempotentMonoid
46+#else
47+ times1p n x = case compare n 0 of
48+ LT -> error "stimesIdempotentMonoid: negative multiplier"
49+ EQ -> mempty
50+ GT -> x
51+#endif
52+
53+instance Ord k => Monoid (PatchMap (Map k v)) where
54+ mempty = PatchMap mempty
55+ mappend = (<>)
56+
57+mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
58+mconcatIncremental m0 e = do
59+ d <- foldDynMaybe apply m0 e
60+ return $ fmap (mconcat . Map.elems) d
61+
62+mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
63+mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
64+
65+mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
66+mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
67+
68+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
69+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ fmap g $ updatedIncremental a
70+
71+incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
72+incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
73+
74+mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
75+mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
76+
77+incrementalReplaceableMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))
78+incrementalReplaceableMap v0 e = do
79+ rec vals <- holdIncremental v0 $ e <> valChanges
80+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
81+ return $ mapIncrementalMapValues _replaceable_value vals
82+
83+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
84+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
85+ where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
86+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
87+
88+data Replaceable t w = Replaceable
89+ { _replaceable_value :: w
90+ , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
91+ }
92+
93+type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
94+
95+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
2296
2397instance HasWebView m => HasWebView (DynamicWriterT t w m) where
2498 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
@@ -37,24 +111,31 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWrit
37111 newEventWithTrigger = lift . newEventWithTrigger
38112 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
39113
40−runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
114+runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
115+runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
116+
117+mconcatIncrementalReplaceableDynMap :: (Reflex t, Monoid v, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Dynamic t v
118+mconcatIncrementalReplaceableDynMap = fmap (mconcat . Map.elems) . incrementalToDynamic . mergeDynIncremental
119+
120+runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w, MonadFix m) => DynamicWriterT t w m a -> m (a, Dynamic t w)
41121runDynamicWriterT (DynamicWriterT a) = do
42122 (result, ws) <- runStateT a []
43− w <- mconcatDyn $ reverse ws
123+ i <- incrementalReplaceableMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never
124+ let w = mconcatIncrementalReplaceableDynMap i
44125 return (result, w)
45126
46127class Monad m => MonadDynamicWriter t w m | m -> t w where
47128 tellDyn :: Dynamic t w -> m ()
48129
49−instance Monad m => MonadDynamicWriter t w (DynamicWriterT t w m) where
50− tellDyn w = DynamicWriterT $ modify (w:)
130+instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
131+ tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
51132
52133instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
53134 ask = lift ask
54135 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
55136 reader = lift . reader
56137
57−liftDynamicWriterTThroughSync :: Monad m' => (m (a, [Dynamic t w]) -> m' (b, (a, [Dynamic t w]))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
138+liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
58139liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
59140 s <- get
60141 (b, (a, newS)) <- lift $ f $ runStateT child s
@@ -65,7 +146,7 @@ liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
65146liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m
66147liftDynamicWriterTElementConfig cfg = cfg
67148 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg
68− , _elementConfig_eventHandler = _elementConfig_eventHandler cfg -- This requires PolyKinds, and will fail to unify types otherwise
149+ , _elementConfig_eventHandler = _elementConfig_eventHandler cfg
69150 }
70151
71152instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
@@ -80,41 +161,46 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (
80161 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
81162 put newS
82163 return (el, a)
83− fragment cfg (DynamicWriterT child) = do --TODO: Delete these things
84− s <- DynamicWriterT get
85− let cfg' = cfg
86− { _fragmentConfig_insertAbove = fmap runDynamicWriterT $ _fragmentConfig_insertAbove cfg
87− }
88− rec children <- foldDyn (:) [] childOutputs
89− tellDyn $ mconcat =<< children -- Needs to go above the child to preserve order
90− (f, (a, newS)) <- DynamicWriterT $ lift $ fragment cfg' $ runStateT child s
91− DynamicWriterT $ put newS
92− let result = fmap fst $ _fragment_insertedAbove f
93− childOutputs = fmap snd $ _fragment_insertedAbove f
94− let f' = f
95− { _fragment_insertedAbove = result
96− }
97− return (f', a)
98− placeholder cfg = do --TODO: Delete these things
164+ placeholder cfg = do
99165 let cfg' = cfg
100− { _placeholderConfig_insertAbove = fmap runDynamicWriterT $ _placeholderConfig_insertAbove cfg
166+ { _placeholderConfig_insertAbove = fmap runDynamicWriterTInternal $ _placeholderConfig_insertAbove cfg
101167 }
102− rec children <- foldDyn (:) [] childOutputs
103− tellDyn $ mconcat =<< children -- Needs to go above the child to preserve order
104− p <- DynamicWriterT $ lift $ placeholder cfg'
168+ let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
169+ -> Event t () -- ^ No more nodes will be added after this event fires
170+ -> m (Replaceable t (Dynamic t w))
171+ manageChildren newChildren additionsCeased = do
172+ rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
173+ let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
174+ numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
175+ let cs = reverse $ toList rcs
176+ myFirstId <- sample nextId
177+ let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
178+ return (myNextId, PatchMap $ Map.fromList numbered)
179+ newNextId = fst <$> numberedNewChildren
180+ replaceableMap <- incrementalReplaceableMap Map.empty $ snd <$> numberedNewChildren
181+ noMoreAdditions <- holdDyn False $ True <$ additionsCeased
182+ let replaceSelf nma i = do
183+ guard nma
184+ case Map.toList i of
185+ [] -> return Nothing -- Delete self
186+ _ -> mzero
187+ return $ Replaceable (mconcatIncrementalReplaceableDynMap replaceableMap) $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic replaceableMap
188+ rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
189+ p <- DynamicWriterT $ do
190+ modify (children:)
191+ lift $ placeholder cfg'
105192 let result = fmap fst $ _placeholder_insertedAbove p
106− childOutputs = fmap snd $ _placeholder_insertedAbove p
193+ childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
107194 return $ p
108195 { _placeholder_insertedAbove = result
109196 }
110197 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
111198 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
112199
113−instance (Deletable t m, Reflex t, Monoid w, MonadHold t m) => Deletable t (DynamicWriterT t w m) where
200+instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
114201 deletable delete child = do
115202 (result, output) <- lift $ deletable delete $ runDynamicWriterT child
116− output' <- holdDyn output $ constDyn mempty <$ delete
117− tellDyn $ join output'
203+ DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
118204 return result
119205
120206instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where