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