git.iko.soy/patch
on 17cbba7 help sign in
patch/src/Reflex/DynamicWriter/Base.hs
228 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.Class
42import Reflex.Adjustable.Class
43import Reflex.DynamicWriter.Class
44import Reflex.Host.Class
45import qualified Reflex.Patch.MapWithMove as MapWithMove
46import Reflex.PerformEvent.Class
47import Reflex.PostBuild.Class
48import Reflex.Query.Class
49import Reflex.Requester.Class
50import Reflex.TriggerEvent.Class
52instance MonadTrans (DynamicWriterT t w) where
53 lift = DynamicWriterT . lift
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 'MonadDynamicWriter'.
90newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
91 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
93deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
94deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
97instance MonadRef m => MonadRef (DynamicWriterT t w m) where
98 type Ref (DynamicWriterT t w m) = Ref m
99 newRef = lift . newRef
100 readRef = lift . readRef
101 writeRef r = lift . writeRef r
103instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
104 atomicModifyRef r = lift . atomicModifyRef r
106instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
107 newEventWithTrigger = lift . newEventWithTrigger
108 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
110-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
111-- along with the result of the action.
112runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
113runDynamicWriterT (DynamicWriterT a) = do
114 (result, ws) <- runStateT a []
115 return (result, mconcat $ reverse ws)
117instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
118 tellDyn w = DynamicWriterT $ modify (w :)
120instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
121 ask = lift ask
122 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
123 reader = lift . reader
125instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
126 type Performable (DynamicWriterT t w m) = Performable m
127 performEvent_ = lift . performEvent_
128 performEvent = lift . performEvent
130instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
131 newTriggerEvent = lift newTriggerEvent
132 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
133 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
135instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
136 getPostBuild = lift getPostBuild
138instance MonadState s m => MonadState s (DynamicWriterT t w m) where
139 get = lift get
140 put = lift . put
142newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
144-- | When the execution of a 'DynamicWriterT' action is adjusted using
145-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
146-- match.
147instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
148 runWithReplace a0 a' = do
149 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
150 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
151 return (fst result0, fst <$> result')
152 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
153 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
154 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
156traverseDMapWithKeyWithAdjustImpl :: 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)
157 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
158 -> DMap k v
159 -> Event t (p k v)
160 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
161 )
162 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
163 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
164 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
165 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
166 -> DMap k v
167 -> Event t (p k v)
168 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
169traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
170 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
171 let getValue (DynamicWriterTLoweredResult (v, _)) = v
172 getWritten (DynamicWriterTLoweredResult (_, w)) = w
173 liftedResult0 = DMap.map getValue result0
174 liftedResult' = ffor result' $ mapPatch getValue
175 liftedWritten0 :: Map (Some k) (Dynamic t w)
176 liftedWritten0 = weakenDMapWith getWritten result0
177 liftedWritten' = ffor result' $ weakenPatchWith getWritten
178 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
179 i <- holdIncremental liftedWritten0 liftedWritten'
180 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
181 return (liftedResult0, liftedResult')
183traverseIntMapWithKeyWithAdjustImpl :: 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')
184 => ( (IntMap.Key -> v -> m (v', Dynamic t w))
185 -> IntMap v
186 -> Event t (p v)
187 -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
188 )
189 -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
190 -> (IntMap.Key -> v -> DynamicWriterT t w m v')
191 -> IntMap v
192 -> Event t (p v)
193 -> DynamicWriterT t w m (IntMap v', Event t (p v'))
194traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
195 (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
196 let liftedResult0 = fmap fst result0
197 liftedResult' = fmap (fmap fst) result'
198 liftedWritten0 :: IntMap (Dynamic t w)
199 liftedWritten0 = fmap snd result0
200 liftedWritten' = fmap (fmap snd) result'
201 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
202 i <- holdIncremental liftedWritten0 liftedWritten'
203 tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
204 return (liftedResult0, liftedResult')
206-- | Map a function over the output of a 'DynamicWriterT'.
207withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
208 => (w -> w')
209 -> DynamicWriterT t w m a
210 -> DynamicWriterT t w' m a
211withDynamicWriterT f dw = do
212 (r, d) <- lift $ do
213 (r, d) <- runDynamicWriterT dw
214 let d' = fmap f d
215 return (r, d')
216 tellDyn d
217 return r
219instance Requester t m => Requester t (DynamicWriterT t w m) where
220 type Request (DynamicWriterT t w m) = Request m
221 type Response (DynamicWriterT t w m) = Response m
222 requesting = lift . requesting
223 requesting_ = lift . requesting_
225instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where
226 tellQueryIncremental = lift . tellQueryIncremental
227 askQueryResult = lift askQueryResult
228 queryIncremental = lift . queryIncremental