git.iko.soy/reflex-dom
on 43eb501 help sign in
reflex-dom/src/Reflex/Dom/DynamicWriter.hs
242 lines 12 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
12module Reflex.Dom.DynamicWriter where
14import Reflex
15import Reflex.Dom.Builder.Class
16import Reflex.Dom.Class
17import Reflex.Dom.PerformEvent.Class
18import Reflex.Dom.PostBuild.Class
19import Reflex.Host.Class
21import Control.Lens hiding (element)
22import Control.Monad.Exception
23import Control.Monad.IO.Class
24import Control.Monad.Reader
25import Control.Monad.Ref
26import Control.Monad.State.Strict
27import Data.Dependent.Map (DMap)
28import Data.Foldable
29import Data.Functor.Compose
30import Data.Functor.Misc
31import Data.List.NonEmpty (NonEmpty, nonEmpty)
32import Data.Map (Map)
33import qualified Data.Map as Map
34import Data.Semigroup
35import Data.Traversable
37instance MonadTrans (DynamicWriterT t w) where
38 lift = DynamicWriterT . lift
40data PatchMap a where
41 PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
43instance Patch PatchMap where
44 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?
45 where insertions = Map.mapMaybeWithKey (const id) p
46 deletions = Map.mapMaybeWithKey (const nothingToJust) p
47 nothingToJust = \case
48 Nothing -> Just ()
49 Just _ -> Nothing
51instance Ord k => Semigroup (PatchMap (Map k v)) where
52 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
53 -- PatchMap is idempotent, so stimes n is id for every n
54#if MIN_VERSION_semigroups(0,17,0)
55 stimes = stimesIdempotentMonoid
56#else
57 times1p n x = case compare n 0 of
58 LT -> error "stimesIdempotentMonoid: negative multiplier"
59 EQ -> mempty
60 GT -> x
61#endif
63instance Ord k => Monoid (PatchMap (Map k v)) where
64 mempty = PatchMap mempty
65 mappend = (<>)
67mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
68mconcatIncremental m0 e = do
69 d <- foldDynMaybe apply m0 e
70 return $ fmap (mconcat . Map.elems) d
72mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
73mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
75mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
76mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
78unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
79unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
81incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
82incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
84mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
85mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
87holdIncrementalReplaceableMap :: 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))
88holdIncrementalReplaceableMap m0 m' = do
89 rec vals <- holdIncremental m0 $ m' <> valChanges
90 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
91 return $ mapIncrementalMapValues _replaceable_value vals
93mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
94mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
95 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
96 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
98data Replaceable t w = Replaceable
99 { _replaceable_value :: w
100 , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
101 }
103type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
105newtype 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
107instance HasWebView m => HasWebView (DynamicWriterT t w m) where
108 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
109 askWebView = lift askWebView
111instance MonadRef m => MonadRef (DynamicWriterT t w m) where
112 type Ref (DynamicWriterT t w m) = Ref m
113 newRef = lift . newRef
114 readRef = lift . readRef
115 writeRef r = lift . writeRef r
117instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
118 atomicModifyRef r = lift . atomicModifyRef r
120instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
121 newEventWithTrigger = lift . newEventWithTrigger
122 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
124runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
125runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
127mconcatIncrementalReplaceableDynMap :: 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))
128mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
129 rec vals <- holdIncremental m0 $ m' <> valChanges
130 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
131 let i = mapIncrementalMapValues _replaceable_value vals
132 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
133 let replaceSelf nma x = do
134 guard nma
135 case Map.toList x of
136 [] -> return Nothing -- Delete self
137 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
138 _ -> mzero
139 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
140 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
142runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
143runDynamicWriterT (DynamicWriterT a) = do
144 (result, ws) <- runStateT a []
145 Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
146 return (result, w)
148class Monad m => MonadDynamicWriter t w m | m -> t w where
149 tellDyn :: Dynamic t w -> m ()
151instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
152 tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
154instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
155 ask = lift ask
156 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
157 reader = lift . reader
159liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
160liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
161 s <- get
162 (b, (a, newS)) <- lift $ f $ runStateT child s
163 put newS
164 return (b, a)
166{-# INLINABLE liftDynamicWriterTElementConfig #-}
167liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m
168liftDynamicWriterTElementConfig cfg = cfg
169 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg
170 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg
171 }
173instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
174 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
175 textNode = liftTextNode
176 element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do
177 s <- get
178 let cfg' = cfg
179 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg
180 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg
181 }
182 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
183 put newS
184 return (el, a)
185 placeholder cfg = do
186 let cfg' = cfg
187 { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
188 }
189 let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
190 -> Event t () -- ^ No more nodes will be added after this event fires
191 -> m (Replaceable t (Dynamic t w))
192 manageChildren newChildren additionsCeased = do
193 rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
194 let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
195 numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
196 let cs = reverse $ toList rcs
197 myFirstId <- sample nextId
198 let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
199 return (myNextId, PatchMap $ Map.fromList numbered)
200 newNextId = fst <$> numberedNewChildren
201 mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
202 rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
203 p <- DynamicWriterT $ do
204 modify (children:)
205 lift $ placeholder cfg'
206 let result = fst <$> _placeholder_insertedAbove p
207 childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
208 return $ p
209 { _placeholder_insertedAbove = result
210 }
211 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
212 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
214instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
215 deletable delete child = do
216 (result, output) <- lift $ deletable delete $ runDynamicWriterT child
217 DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
218 return result
220instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
221 type Performable (DynamicWriterT t w m) = Performable m
222 performEvent_ = lift . performEvent_
223 performEvent = lift . performEvent
225instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
226 newTriggerEvent = lift newTriggerEvent
227 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
228 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
230instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
231 getPostBuild = lift getPostBuild
233instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
234 tellDyn = lift . tellDyn
236instance MonadState s m => MonadState s (DynamicWriterT t w m) where
237 get = lift get
238 put = lift . put
240instance HasJS x m => HasJS x (DynamicWriterT t w m) where
241 type JSM (DynamicWriterT t w m) = JSM m
242 liftJS = lift . liftJS