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