git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/DynamicWriter/Base.hs
237 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.Primitive
26import Control.Monad.Reader
27import Control.Monad.Ref
28import Control.Monad.State.Strict
29import Data.Align
30import Data.Dependent.Map (DMap)
31import qualified Data.Dependent.Map as DMap
32import Data.FastMutableIntMap
33import Data.Functor.Misc
34import Data.IntMap (IntMap)
35import qualified Data.IntMap as IntMap
36import Data.Map (Map)
37import qualified Data.Map as Map
38import Data.Semigroup (Semigroup(..))
39import Data.Some (Some)
40import Data.These
42import Reflex.Adjustable.Class
43import Reflex.Class
44import Reflex.DynamicWriter.Class
45import Reflex.EventWriter.Class (EventWriter, tellEvent)
46import Reflex.Host.Class
47import qualified Data.Patch.MapWithMove as MapWithMove
48import Reflex.PerformEvent.Class
49import Reflex.PostBuild.Class
50import Reflex.Query.Class
51import Reflex.Requester.Class
52import Reflex.TriggerEvent.Class
54instance MonadTrans (DynamicWriterT t w) where
55 lift = DynamicWriterT . lift
57mapIncrementalMapValues :: (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')
58mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
60mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
61mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
62 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
63 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
65mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
66mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
67 where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
68 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
70mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
71mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
72 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
73 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
74 f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
75 f x = unsafePatchMapWithMove $
76 let (p, changed) = case x of
77 This p_ -> (unPatchMapWithMove p_, mempty)
78 That c -> (mempty, c)
79 These p_ c -> (unPatchMapWithMove p_, c)
80 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
81 MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
82 MapWithMove.From_Delete -> return MapWithMove.From_Delete
83 MapWithMove.From_Move k -> case Map.lookup k changed of
84 Nothing -> return $ MapWithMove.From_Move k
85 Just v -> do
86 modify (k:)
87 return $ MapWithMove.From_Insert v
88 noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved
89 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
91-- | A basic implementation of 'DynamicWriter'.
92newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
93 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
95deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
96deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
99instance MonadRef m => MonadRef (DynamicWriterT t w m) where
100 type Ref (DynamicWriterT t w m) = Ref m
101 newRef = lift . newRef
102 readRef = lift . readRef
103 writeRef r = lift . writeRef r
105instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
106 atomicModifyRef r = lift . atomicModifyRef r
108instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
109 newEventWithTrigger = lift . newEventWithTrigger
110 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
112-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
113-- along with the result of the action.
114runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
115runDynamicWriterT (DynamicWriterT a) = do
116 (result, ws) <- runStateT a []
117 return (result, mconcat $ reverse ws)
119instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where
120 tellDyn w = DynamicWriterT $ modify (w :)
122instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
123 ask = lift ask
124 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
125 reader = lift . reader
127instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
128 type Performable (DynamicWriterT t w m) = Performable m
129 performEvent_ = lift . performEvent_
130 performEvent = lift . performEvent
132instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
133 newTriggerEvent = lift newTriggerEvent
134 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
135 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
137instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
138 getPostBuild = lift getPostBuild
140instance MonadState s m => MonadState s (DynamicWriterT t w m) where
141 get = lift get
142 put = lift . put
144instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where
145 type PrimState (DynamicWriterT t w m) = PrimState m
146 primitive = lift . primitive
148newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
150-- | When the execution of a 'DynamicWriterT' action is adjusted using
151-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
152-- match.
153instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
154 runWithReplace a0 a' = do
155 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
156 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
157 return (fst result0, fst <$> result')
158 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
159 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
160 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
162traverseDMapWithKeyWithAdjustImpl :: 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)
163 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
164 -> DMap k v
165 -> Event t (p k v)
166 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
167 )
168 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
169 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
170 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
171 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
172 -> DMap k v
173 -> Event t (p k v)
174 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
175traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
176 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
177 let getValue (DynamicWriterTLoweredResult (v, _)) = v
178 getWritten (DynamicWriterTLoweredResult (_, w)) = w
179 liftedResult0 = DMap.map getValue result0
180 liftedResult' = ffor result' $ mapPatch getValue
181 liftedWritten0 :: Map (Some k) (Dynamic t w)
182 liftedWritten0 = weakenDMapWith getWritten result0
183 liftedWritten' = ffor result' $ weakenPatchWith getWritten
184 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
185 i <- holdIncremental liftedWritten0 liftedWritten'
186 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
187 return (liftedResult0, liftedResult')
189traverseIntMapWithKeyWithAdjustImpl :: 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')
190 => ( (IntMap.Key -> v -> m (v', Dynamic t w))
191 -> IntMap v
192 -> Event t (p v)
193 -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
194 )
195 -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
196 -> (IntMap.Key -> v -> DynamicWriterT t w m v')
197 -> IntMap v
198 -> Event t (p v)
199 -> DynamicWriterT t w m (IntMap v', Event t (p v'))
200traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
201 (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
202 let liftedResult0 = fmap fst result0
203 liftedResult' = fmap (fmap fst) result'
204 liftedWritten0 :: IntMap (Dynamic t w)
205 liftedWritten0 = fmap snd result0
206 liftedWritten' = fmap (fmap snd) result'
207 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
208 i <- holdIncremental liftedWritten0 liftedWritten'
209 tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
210 return (liftedResult0, liftedResult')
212-- | Map a function over the output of a 'DynamicWriterT'.
213withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
214 => (w -> w')
215 -> DynamicWriterT t w m a
216 -> DynamicWriterT t w' m a
217withDynamicWriterT f dw = do
218 (r, d) <- lift $ do
219 (r, d) <- runDynamicWriterT dw
220 let d' = fmap f d
221 return (r, d')
222 tellDyn d
223 return r
225instance Requester t m => Requester t (DynamicWriterT t w m) where
226 type Request (DynamicWriterT t w m) = Request m
227 type Response (DynamicWriterT t w m) = Response m
228 requesting = lift . requesting
229 requesting_ = lift . requesting_
231instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where
232 tellQueryIncremental = lift . tellQueryIncremental
233 askQueryResult = lift askQueryResult
234 queryIncremental = lift . queryIncremental
236instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
237 tellEvent = lift . tellEvent