git.iko.soy/patch
on 28ca47b help sign in
patch/src/Reflex/DynamicWriter/Base.hs
232 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.Reader
26import Control.Monad.Ref
27import Control.Monad.State.Strict
28import Data.Align
29import Data.Dependent.Map (DMap)
30import qualified Data.Dependent.Map as DMap
31import Data.FastMutableIntMap
32import Data.Functor.Misc
33import Data.IntMap (IntMap)
34import qualified Data.IntMap as IntMap
35import Data.Map (Map)
36import qualified Data.Map as Map
37import Data.Semigroup
38import Data.Some (Some)
39import Data.These
41import Reflex.Adjustable.Class
42import Reflex.Class
43import Reflex.DynamicWriter.Class
44import Reflex.EventWriter.Class (EventWriter, tellEvent)
45import Reflex.Host.Class
46import qualified Reflex.Patch.MapWithMove as MapWithMove
47import Reflex.PerformEvent.Class
48import Reflex.PostBuild.Class
49import Reflex.Query.Class
50import Reflex.Requester.Class
51import Reflex.TriggerEvent.Class
53instance MonadTrans (DynamicWriterT t w) where
54 lift = DynamicWriterT . lift
56mapIncrementalMapValues :: (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')
57mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
59mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
60mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
61 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
62 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
64mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
65mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
66 where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
67 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
69mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
70mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
71 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
72 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
73 f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
74 f x = unsafePatchMapWithMove $
75 let (p, changed) = case x of
76 This p_ -> (unPatchMapWithMove p_, mempty)
77 That c -> (mempty, c)
78 These p_ c -> (unPatchMapWithMove p_, c)
79 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
80 MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
81 MapWithMove.From_Delete -> return MapWithMove.From_Delete
82 MapWithMove.From_Move k -> case Map.lookup k changed of
83 Nothing -> return $ MapWithMove.From_Move k
84 Just v -> do
85 modify (k:)
86 return $ MapWithMove.From_Insert v
87 noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved
88 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
90-- | A basic implementation of 'MonadDynamicWriter'.
91newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
92 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
94deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
95deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
98instance MonadRef m => MonadRef (DynamicWriterT t w m) where
99 type Ref (DynamicWriterT t w m) = Ref m
100 newRef = lift . newRef
101 readRef = lift . readRef
102 writeRef r = lift . writeRef r
104instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
105 atomicModifyRef r = lift . atomicModifyRef r
107instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
108 newEventWithTrigger = lift . newEventWithTrigger
109 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
111-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
112-- along with the result of the action.
113runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
114runDynamicWriterT (DynamicWriterT a) = do
115 (result, ws) <- runStateT a []
116 return (result, mconcat $ reverse ws)
118instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
119 tellDyn w = DynamicWriterT $ modify (w :)
121instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
122 ask = lift ask
123 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
124 reader = lift . reader
126instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
127 type Performable (DynamicWriterT t w m) = Performable m
128 performEvent_ = lift . performEvent_
129 performEvent = lift . performEvent
131instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
132 newTriggerEvent = lift newTriggerEvent
133 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
134 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
136instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
137 getPostBuild = lift getPostBuild
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_
226instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where
227 tellQueryIncremental = lift . tellQueryIncremental
228 askQueryResult = lift askQueryResult
229 queryIncremental = lift . queryIncremental
231instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
232 tellEvent = lift . tellEvent