@@ -0,0 +1,180 @@
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+module Reflex.DynamicWriter where
14+import Control.Monad.Exception
15+import Control.Monad.IO.Class
16+import Control.Monad.Reader
17+import Control.Monad.Ref
18+import Control.Monad.State.Strict
19+import Data.Dependent.Map (DMap)
20+import Data.Functor.Compose
21+import Data.Functor.Misc
23+import qualified Data.Map as Map
26+import Reflex.Deletable.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.Host.Class
31+instance MonadTrans (DynamicWriterT t w) where
32+ lift = DynamicWriterT . lift
35+ PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
37+instance Patch PatchMap where
38+ 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?
39+ where insertions = Map.mapMaybeWithKey (const id) p
40+ deletions = Map.mapMaybeWithKey (const nothingToJust) p
41+ nothingToJust = \case
45+instance Ord k => Semigroup (PatchMap (Map k v)) where
46+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
47+ -- PatchMap is idempotent, so stimes n is id for every n
48+#if MIN_VERSION_semigroups(0,17,0)
49+ stimes = stimesIdempotentMonoid
51+ times1p n x = case compare n 0 of
52+ LT -> error "stimesIdempotentMonoid: negative multiplier"
57+instance Ord k => Monoid (PatchMap (Map k v)) where
58+ mempty = PatchMap mempty
61+mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
62+mconcatIncremental m0 e = do
63+ d <- foldDynMaybe apply m0 e
64+ return $ fmap (mconcat . Map.elems) d
66+mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
67+mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
69+mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
70+mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
72+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
73+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
75+incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
76+incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
78+mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
79+mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
81+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))
82+holdIncrementalReplaceableMap m0 m' = do
83+ rec vals <- holdIncremental m0 $ m' <> valChanges
84+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
85+ return $ mapIncrementalMapValues _replaceable_value vals
87+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
88+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
89+ where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
90+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
92+data Replaceable t w = Replaceable
93+ { _replaceable_value :: w
94+ , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
97+type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
99+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
101+instance 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
107+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
108+ atomicModifyRef r = lift . atomicModifyRef r
110+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
111+ newEventWithTrigger = lift . newEventWithTrigger
112+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
114+runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
115+runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
117+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))
118+mconcatIncrementalReplaceableDynMap 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
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?
129+ result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
130+ return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
132+runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
133+runDynamicWriterT (DynamicWriterT a) = do
134+ (result, ws) <- runStateT a []
135+ Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
138+class Monad m => MonadDynamicWriter t w m | m -> t w where
139+ tellDyn :: Dynamic t w -> m ()
141+instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
142+ tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
144+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
146+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
147+ reader = lift . reader
149+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)
150+liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
152+ (b, (a, newS)) <- lift $ f $ runStateT child s
156+instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
157+ deletable delete child = do
158+ (result, output) <- lift $ deletable delete $ runDynamicWriterT child
159+ DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
162+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
163+ type Performable (DynamicWriterT t w m) = Performable m
164+ performEvent_ = lift . performEvent_
165+ performEvent = lift . performEvent
167+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
168+ newTriggerEvent = lift newTriggerEvent
169+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
170+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
172+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
173+ getPostBuild = lift getPostBuild
175+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
176+ tellDyn = lift . tellDyn
178+instance MonadState s m => MonadState s (DynamicWriterT t w m) where