git.iko.soy/patch
on e8029ed help sign in
patch/src/Reflex/DynamicWriter.hs
224 lines 12 kB history raw
1-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard
2-- implementation.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
14#ifdef USE_REFLEX_OPTIMIZER
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16#endif
17module Reflex.DynamicWriter
18 ( MonadDynamicWriter (..)
19 , DynamicWriterT (..)
20 , runDynamicWriterT
21 , withDynamicWriterT
22 ) where
24import Control.Monad.Exception
25import Control.Monad.Identity
26import Control.Monad.IO.Class
27import Control.Monad.Reader
28import Control.Monad.Ref
29import Control.Monad.State.Strict
30import Data.Align
31import Data.Dependent.Map (DMap)
32import qualified Data.Dependent.Map as DMap
33import Data.FastMutableIntMap
34import Data.Functor.Misc
35import Data.IntMap (IntMap)
36import qualified Data.IntMap as IntMap
37import Data.Map (Map)
38import qualified Data.Map as Map
39import Data.Semigroup
40import Data.Some (Some)
41import Data.These
42import Reflex.Class
43import Reflex.Host.Class
44import qualified Reflex.Patch.MapWithMove as MapWithMove
45import Reflex.PerformEvent.Class
46import Reflex.PostBuild.Class
47import Reflex.Requester.Class
48import Reflex.TriggerEvent.Class
50instance MonadTrans (DynamicWriterT t w) where
51 lift = DynamicWriterT . lift
53mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')
54mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
56mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
57mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
58 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
59 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
61mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
62mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
63 where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
64 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
66mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
67mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
68 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
69 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
70 f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
71 f x = unsafePatchMapWithMove $
72 let (p, changed) = case x of
73 This p_ -> (unPatchMapWithMove p_, mempty)
74 That c -> (mempty, c)
75 These p_ c -> (unPatchMapWithMove p_, c)
76 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
77 MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
78 MapWithMove.From_Delete -> return $ MapWithMove.From_Delete
79 MapWithMove.From_Move k -> case Map.lookup k changed of
80 Nothing -> return $ MapWithMove.From_Move k
81 Just v -> do
82 modify (k:)
83 return $ MapWithMove.From_Insert v
84 noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved
85 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
87-- | A basic implementation of 'MonadDynamicWriter'.
88newtype 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
90instance MonadRef m => MonadRef (DynamicWriterT t w m) where
91 type Ref (DynamicWriterT t w m) = Ref m
92 newRef = lift . newRef
93 readRef = lift . readRef
94 writeRef r = lift . writeRef r
96instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
97 atomicModifyRef r = lift . atomicModifyRef r
99instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
100 newEventWithTrigger = lift . newEventWithTrigger
101 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
103-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
104-- along with the result of the action.
105runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
106runDynamicWriterT (DynamicWriterT a) = do
107 (result, ws) <- runStateT a []
108 return (result, mconcat $ reverse ws)
110-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
111-- and combines them monoidally to provide a 'Dynamic' result.
112class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
113 tellDyn :: Dynamic t w -> m ()
115instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
116 tellDyn w = DynamicWriterT $ modify (w :)
118instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
119 ask = lift ask
120 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
121 reader = lift . reader
123instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
124 type Performable (DynamicWriterT t w m) = Performable m
125 performEvent_ = lift . performEvent_
126 performEvent = lift . performEvent
128instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
129 newTriggerEvent = lift newTriggerEvent
130 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
131 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
133instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
134 getPostBuild = lift getPostBuild
136instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
137 tellDyn = lift . tellDyn
139instance MonadState s m => MonadState s (DynamicWriterT t w m) where
140 get = lift get
141 put = lift . put
143newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
145-- | When the execution of a 'DynamicWriterT' action is adjusted using
146-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
147-- match.
148instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
149 runWithReplace a0 a' = do
150 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
151 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
152 return (fst result0, fst <$> result')
153 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
154 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
155 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
157traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)
158 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
159 -> DMap k v
160 -> Event t (p k v)
161 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
162 )
163 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
164 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
165 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
166 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
167 -> DMap k v
168 -> Event t (p k v)
169 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
170traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
171 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
172 let getValue (DynamicWriterTLoweredResult (v, _)) = v
173 getWritten (DynamicWriterTLoweredResult (_, w)) = w
174 liftedResult0 = DMap.map getValue result0
175 liftedResult' = ffor result' $ mapPatch getValue
176 liftedWritten0 :: Map (Some k) (Dynamic t w)
177 liftedWritten0 = weakenDMapWith getWritten result0
178 liftedWritten' = ffor result' $ weakenPatchWith getWritten
179 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
180 i <- holdIncremental liftedWritten0 liftedWritten'
181 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
182 return (liftedResult0, liftedResult')
184traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')
185 => ( (IntMap.Key -> v -> m ((v', Dynamic t w)))
186 -> IntMap v
187 -> Event t (p v)
188 -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
189 )
190 -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
191 -> (IntMap.Key -> v -> DynamicWriterT t w m v')
192 -> IntMap v
193 -> Event t (p v)
194 -> DynamicWriterT t w m (IntMap v', Event t (p v'))
195traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
196 (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
197 let liftedResult0 = fmap fst result0
198 liftedResult' = fmap (fmap fst) result'
199 liftedWritten0 :: IntMap (Dynamic t w)
200 liftedWritten0 = fmap snd result0
201 liftedWritten' = fmap (fmap snd) result'
202 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
203 i <- holdIncremental liftedWritten0 liftedWritten'
204 tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
205 return (liftedResult0, liftedResult')
207-- | Map a function over the output of a 'DynamicWriterT'.
208withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
209 => (w -> w')
210 -> DynamicWriterT t w m a
211 -> DynamicWriterT t w' m a
212withDynamicWriterT f dw = do
213 (r, d) <- lift $ do
214 (r, d) <- runDynamicWriterT dw
215 let d' = fmap f d
216 return (r, d')
217 tellDyn d
218 return r
220instance Requester t m => Requester t (DynamicWriterT t w m) where
221 type Request (DynamicWriterT t w m) = Request m
222 type Response (DynamicWriterT t w m) = Response m
223 requesting = lift . requesting
224 requesting_ = lift . requesting_