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