git.iko.soy/patch
on 2ab7121 help sign in
patch/src/Reflex/DynamicWriter.hs
191 lines 9.9 kB history raw
1-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard
2-- implementation.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
14#ifdef USE_REFLEX_OPTIMIZER
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16#endif
17module Reflex.DynamicWriter
18 ( MonadDynamicWriter (..)
19 , DynamicWriterT (..)
20 , runDynamicWriterT
21 , withDynamicWriterT
22 ) where
24import Control.Monad.Exception
25import Control.Monad.Identity
26import Control.Monad.IO.Class
27import Control.Monad.Reader
28import Control.Monad.Ref
29import Control.Monad.State.Strict
30import Data.Align
31import Data.Dependent.Map (DMap)
32import qualified Data.Dependent.Map as DMap
33import Data.Functor.Misc
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.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
58mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
59mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
60 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
61 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
62 f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
63 f x = unsafePatchMapWithMove $
64 let (p, changed) = case x of
65 This p_ -> (unPatchMapWithMove p_, mempty)
66 That c -> (mempty, c)
67 These p_ c -> (unPatchMapWithMove p_, c)
68 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
69 MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
70 MapWithMove.From_Delete -> return $ MapWithMove.From_Delete
71 MapWithMove.From_Move k -> case Map.lookup k changed of
72 Nothing -> return $ MapWithMove.From_Move k
73 Just v -> do
74 modify (k:)
75 return $ MapWithMove.From_Insert v
76 noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved
77 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
79-- | A basic implementation of 'MonadDynamicWriter'.
80newtype 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
82instance MonadRef m => MonadRef (DynamicWriterT t w m) where
83 type Ref (DynamicWriterT t w m) = Ref m
84 newRef = lift . newRef
85 readRef = lift . readRef
86 writeRef r = lift . writeRef r
88instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
89 atomicModifyRef r = lift . atomicModifyRef r
91instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
92 newEventWithTrigger = lift . newEventWithTrigger
93 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
95-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
96-- along with the result of the action.
97runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
98runDynamicWriterT (DynamicWriterT a) = do
99 (result, ws) <- runStateT a []
100 return (result, mconcat $ reverse ws)
102-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
103-- and combines them monoidally to provide a 'Dynamic' result.
104class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
105 tellDyn :: Dynamic t w -> m ()
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 MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
129 tellDyn = lift . tellDyn
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-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to
139-- match.
140instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust 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 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
146 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
148traverseDMapWithKeyWithAdjustImpl :: 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)
149 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
150 -> DMap k v
151 -> Event t (p k v)
152 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
153 )
154 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
155 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
156 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
157 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
158 -> DMap k v
159 -> Event t (p k v)
160 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
161traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
162 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
163 let getValue (DynamicWriterTLoweredResult (v, _)) = v
164 getWritten (DynamicWriterTLoweredResult (_, w)) = w
165 liftedResult0 = DMap.map getValue result0
166 liftedResult' = ffor result' $ mapPatch getValue
167 liftedWritten0 :: Map (Some k) (Dynamic t w)
168 liftedWritten0 = weakenDMapWith getWritten result0
169 liftedWritten' = ffor result' $ weakenPatchWith getWritten
170 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
171 i <- holdIncremental liftedWritten0 liftedWritten'
172 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
173 return (liftedResult0, liftedResult')
175-- | Map a function over the output of a 'DynamicWriterT'.
176withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
177 => (w -> w')
178 -> DynamicWriterT t w m a
179 -> DynamicWriterT t w' m a
180withDynamicWriterT f dw = do
181 (r, d) <- lift $ do
182 (r, d) <- runDynamicWriterT dw
183 let d' = fmap f d
184 return (r, d')
185 tellDyn d
186 return r
188instance Requester t m => Requester t (DynamicWriterT t w m) where
189 type Request (DynamicWriterT t w m) = Request m
190 type Response (DynamicWriterT t w m) = Response m
191 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f