git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/DynamicWriter/Base.hs
246 lines 12 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE StandaloneDeriving #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.DynamicWriter.Base
17 ( DynamicWriterT (..)
18 , runDynamicWriterT
19 , withDynamicWriterT
20 ) where
22import Control.Monad.Exception
23import Control.Monad.Identity
24import Control.Monad.IO.Class
25import Control.Monad.Morph
26import Control.Monad.Primitive
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 (Semigroup(..))
40import Data.Some (Some)
41import Data.These
43import Reflex.Adjustable.Class
44import Reflex.Class
45import Reflex.DynamicWriter.Class
46import Reflex.EventWriter.Class (EventWriter, tellEvent)
47import Reflex.Host.Class
48import qualified Data.Patch.MapWithMove as MapWithMove
49import Reflex.PerformEvent.Class
50import Reflex.PostBuild.Class
51import Reflex.Query.Class
52import Reflex.Requester.Class
53import Reflex.TriggerEvent.Class
55mapIncrementalMapValues :: (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')
56mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
58mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
59mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
60 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
61 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
63mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
64mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
65 where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
66 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
68mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
69mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
70 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
71 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
72 f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
73 f x = unsafePatchMapWithMove $
74 let (p, changed) = case x of
75 This p_ -> (unPatchMapWithMove p_, mempty)
76 That c -> (mempty, c)
77 These p_ c -> (unPatchMapWithMove p_, c)
78 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
79 MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
80 MapWithMove.From_Delete -> return MapWithMove.From_Delete
81 MapWithMove.From_Move k -> case Map.lookup k changed of
82 Nothing -> return $ MapWithMove.From_Move k
83 Just v -> do
84 modify (k:)
85 return $ MapWithMove.From_Insert v
86 noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved
87 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
89-- | A basic implementation of 'DynamicWriter'.
90newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
91 -- The list is kept in reverse order
92 deriving
93 ( Functor
94 , Applicative
95 , Monad
96 , MonadTrans
97 , MFunctor
98 , MonadIO
99 , MonadFix
100 , MonadAsyncException
101 , MonadException
102 )
104deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
105deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
108instance MonadRef m => MonadRef (DynamicWriterT t w m) where
109 type Ref (DynamicWriterT t w m) = Ref m
110 newRef = lift . newRef
111 readRef = lift . readRef
112 writeRef r = lift . writeRef r
114instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
115 atomicModifyRef r = lift . atomicModifyRef r
117instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
118 newEventWithTrigger = lift . newEventWithTrigger
119 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
121-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
122-- along with the result of the action.
123runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
124runDynamicWriterT (DynamicWriterT a) = do
125 (result, ws) <- runStateT a []
126 return (result, mconcat $ reverse ws)
128instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where
129 tellDyn w = DynamicWriterT $ modify (w :)
131instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
132 ask = lift ask
133 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
134 reader = lift . reader
136instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
137 type Performable (DynamicWriterT t w m) = Performable m
138 performEvent_ = lift . performEvent_
139 performEvent = lift . performEvent
141instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
142 newTriggerEvent = lift newTriggerEvent
143 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
144 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
146instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
147 getPostBuild = lift getPostBuild
149instance MonadState s m => MonadState s (DynamicWriterT t w m) where
150 get = lift get
151 put = lift . put
153instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where
154 type PrimState (DynamicWriterT t w m) = PrimState m
155 primitive = lift . primitive
157newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
159-- | When the execution of a 'DynamicWriterT' action is adjusted using
160-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
161-- match.
162instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
163 runWithReplace a0 a' = do
164 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
165 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
166 return (fst result0, fst <$> result')
167 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
168 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
169 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
171traverseDMapWithKeyWithAdjustImpl :: 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)
172 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
173 -> DMap k v
174 -> Event t (p k v)
175 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
176 )
177 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
178 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
179 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
180 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
181 -> DMap k v
182 -> Event t (p k v)
183 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
184traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
185 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
186 let getValue (DynamicWriterTLoweredResult (v, _)) = v
187 getWritten (DynamicWriterTLoweredResult (_, w)) = w
188 liftedResult0 = DMap.map getValue result0
189 liftedResult' = ffor result' $ mapPatch getValue
190 liftedWritten0 :: Map (Some k) (Dynamic t w)
191 liftedWritten0 = weakenDMapWith getWritten result0
192 liftedWritten' = ffor result' $ weakenPatchWith getWritten
193 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
194 i <- holdIncremental liftedWritten0 liftedWritten'
195 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
196 return (liftedResult0, liftedResult')
198traverseIntMapWithKeyWithAdjustImpl :: 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')
199 => ( (IntMap.Key -> v -> m (v', Dynamic t w))
200 -> IntMap v
201 -> Event t (p v)
202 -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
203 )
204 -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
205 -> (IntMap.Key -> v -> DynamicWriterT t w m v')
206 -> IntMap v
207 -> Event t (p v)
208 -> DynamicWriterT t w m (IntMap v', Event t (p v'))
209traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
210 (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
211 let liftedResult0 = fmap fst result0
212 liftedResult' = fmap (fmap fst) result'
213 liftedWritten0 :: IntMap (Dynamic t w)
214 liftedWritten0 = fmap snd result0
215 liftedWritten' = fmap (fmap snd) result'
216 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
217 i <- holdIncremental liftedWritten0 liftedWritten'
218 tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
219 return (liftedResult0, liftedResult')
221-- | Map a function over the output of a 'DynamicWriterT'.
222withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
223 => (w -> w')
224 -> DynamicWriterT t w m a
225 -> DynamicWriterT t w' m a
226withDynamicWriterT f dw = do
227 (r, d) <- lift $ do
228 (r, d) <- runDynamicWriterT dw
229 let d' = fmap f d
230 return (r, d')
231 tellDyn d
232 return r
234instance Requester t m => Requester t (DynamicWriterT t w m) where
235 type Request (DynamicWriterT t w m) = Request m
236 type Response (DynamicWriterT t w m) = Response m
237 requesting = lift . requesting
238 requesting_ = lift . requesting_
240instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where
241 tellQueryIncremental = lift . tellQueryIncremental
242 askQueryResult = lift askQueryResult
243 queryIncremental = lift . queryIncremental
245instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
246 tellEvent = lift . tellEvent