git.iko.soy/reflex-dom
on a00ce01 help sign in
reflex-dom/src/Reflex/Dom/DynamicWriter.hs
232 lines 12 kB history raw
1{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, FunctionalDependencies, RecursiveDo, ScopedTypeVariables, LambdaCase, GADTs #-}
2module Reflex.Dom.DynamicWriter where
4import Reflex
5import Reflex.Host.Class
6import Reflex.Dom.Class
7import Reflex.Dom.Builder.Class
8import Reflex.Dom.PerformEvent.Class
9import Reflex.Dom.PostBuild.Class
11import Control.Lens hiding (element)
12import Control.Monad.IO.Class
13import Control.Monad.State.Strict
14import Control.Monad.Reader
15import Control.Monad.Ref
16import Control.Monad.Exception
17import Data.Map (Map)
18import qualified Data.Map as Map
19import Data.Dependent.Map (DMap)
20import Data.List.NonEmpty (NonEmpty, nonEmpty)
21import Data.Functor.Compose
22import Data.Functor.Misc
23import Data.Semigroup
24import Data.Foldable
25import Data.Traversable
27instance MonadTrans (DynamicWriterT t w) where
28 lift = DynamicWriterT . lift
30data PatchMap a where
31 PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
33instance 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
41instance 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
53instance Ord k => Monoid (PatchMap (Map k v)) where
54 mempty = PatchMap mempty
55 mappend = (<>)
57mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
58mconcatIncremental m0 e = do
59 d <- foldDynMaybe apply m0 e
60 return $ fmap (mconcat . Map.elems) d
62mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
63mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
65mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
66mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
68unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
69unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
71incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
72incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
74mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
75mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
77holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))
78holdIncrementalReplaceableMap m0 m' = do
79 rec vals <- holdIncremental m0 $ m' <> valChanges
80 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
81 return $ mapIncrementalMapValues _replaceable_value vals
83mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
84mergeDynIncremental 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
88data 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 }
93type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
95newtype 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
97instance HasWebView m => HasWebView (DynamicWriterT t w m) where
98 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
99 askWebView = lift askWebView
101instance MonadRef m => MonadRef (DynamicWriterT t w m) where
102 type Ref (DynamicWriterT t w m) = Ref m
103 newRef = lift . newRef
104 readRef = lift . readRef
105 writeRef r = lift . writeRef r
107instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
108 atomicModifyRef r = lift . atomicModifyRef r
110instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
111 newEventWithTrigger = lift . newEventWithTrigger
112 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
114runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
115runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
117mconcatIncrementalReplaceableDynMap :: forall m t k v. (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k) => Map k (Replaceable t (Dynamic t v)) -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v)))) -> Event t () -> m (Replaceable t (Dynamic t v))
118mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
119 rec vals <- holdIncremental m0 $ m' <> valChanges
120 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
121 let i = mapIncrementalMapValues _replaceable_value vals
122 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
123 let replaceSelf nma x = do
124 guard nma
125 case Map.toList x of
126 [] -> return Nothing -- Delete self
127 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
128 _ -> mzero
129 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
130 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
132runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
133runDynamicWriterT (DynamicWriterT a) = do
134 (result, ws) <- runStateT a []
135 Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
136 return (result, w)
138class Monad m => MonadDynamicWriter t w m | m -> t w where
139 tellDyn :: Dynamic t w -> m ()
141instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
142 tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
144instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
145 ask = lift ask
146 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
147 reader = lift . reader
149liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
150liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
151 s <- get
152 (b, (a, newS)) <- lift $ f $ runStateT child s
153 put newS
154 return (b, a)
156{-# INLINABLE liftDynamicWriterTElementConfig #-}
157liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m
158liftDynamicWriterTElementConfig cfg = cfg
159 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg
160 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg
161 }
163instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
164 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
165 textNode = liftTextNode
166 element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do
167 s <- get
168 let cfg' = cfg
169 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg
170 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg
171 }
172 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
173 put newS
174 return (el, a)
175 placeholder cfg = do
176 let cfg' = cfg
177 { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
178 }
179 let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
180 -> Event t () -- ^ No more nodes will be added after this event fires
181 -> m (Replaceable t (Dynamic t w))
182 manageChildren newChildren additionsCeased = do
183 rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
184 let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
185 numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
186 let cs = reverse $ toList rcs
187 myFirstId <- sample nextId
188 let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
189 return (myNextId, PatchMap $ Map.fromList numbered)
190 newNextId = fst <$> numberedNewChildren
191 mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
192 rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
193 p <- DynamicWriterT $ do
194 modify (children:)
195 lift $ placeholder cfg'
196 let result = fst <$> _placeholder_insertedAbove p
197 childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
198 return $ p
199 { _placeholder_insertedAbove = result
200 }
201 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
202 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
204instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
205 deletable delete child = do
206 (result, output) <- lift $ deletable delete $ runDynamicWriterT child
207 DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
208 return result
210instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
211 type Performable (DynamicWriterT t w m) = Performable m
212 performEvent_ = lift . performEvent_
213 performEvent = lift . performEvent
215instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
216 newTriggerEvent = lift newTriggerEvent
217 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
218 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
220instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
221 getPostBuild = lift getPostBuild
223instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
224 tellDyn = lift . tellDyn
226instance MonadState s m => MonadState s (DynamicWriterT t w m) where
227 get = lift get
228 put = lift . put
230instance HasJS x m => HasJS x (DynamicWriterT t w m) where
231 type JSM (DynamicWriterT t w m) = JSM m
232 liftJS = lift . liftJS