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