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