git.iko.soy/patch
on 39301ec help sign in
patch/src/Reflex/DynamicWriter.hs
193 lines 10.0 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 Reflex.PerformEvent.Class
42import Reflex.PostBuild.Class
43import Reflex.Requester.Class
44import Reflex.TriggerEvent.Class
46instance MonadTrans (DynamicWriterT t w) where
47 lift = DynamicWriterT . lift
49mapIncrementalMapValues :: (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')
50mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
52mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
53mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
54 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
55 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
57mergeDynIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
58mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
59 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
60 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
61 f x = unsafePatchMapWithMove $
62 let (p, changed) = case x of
63 This p_ -> (unPatchMapWithMove p_, mempty)
64 That c -> (mempty, c)
65 These p_ c -> (unPatchMapWithMove p_, c)
66 (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ \case
67 MapEdit_Insert moved v -> return $ MapEdit_Insert moved v
68 MapEdit_Delete moved -> return $ MapEdit_Delete moved
69 MapEdit_Move moved k -> case Map.lookup k changed of
70 Nothing -> return $ MapEdit_Move moved k
71 Just v -> do
72 modify (k:)
73 return $ MapEdit_Insert moved v
74 noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved
75 removeMovedFlag = \case --TODO: Check if moved was true before, in each case?
76 MapEdit_Insert _ v -> MapEdit_Insert False v
77 MapEdit_Delete _ -> MapEdit_Delete False
78 MapEdit_Move _ k -> MapEdit_Move False k
79 in Map.differenceWith (\e _ -> Just $ removeMovedFlag e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
81-- | A basic implementation of 'MonadDynamicWriter'.
82newtype 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
84instance MonadRef m => MonadRef (DynamicWriterT t w m) where
85 type Ref (DynamicWriterT t w m) = Ref m
86 newRef = lift . newRef
87 readRef = lift . readRef
88 writeRef r = lift . writeRef r
90instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
91 atomicModifyRef r = lift . atomicModifyRef r
93instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
94 newEventWithTrigger = lift . newEventWithTrigger
95 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
97-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
98-- along with the result of the action.
99runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
100runDynamicWriterT (DynamicWriterT a) = do
101 (result, ws) <- runStateT a []
102 return (result, mconcat $ reverse ws)
104-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
105-- and combines them monoidally to provide a 'Dynamic' result.
106class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
107 tellDyn :: Dynamic t w -> m ()
109instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
110 tellDyn w = DynamicWriterT $ modify (w :)
112instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
113 ask = lift ask
114 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
115 reader = lift . reader
117instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
118 type Performable (DynamicWriterT t w m) = Performable m
119 performEvent_ = lift . performEvent_
120 performEvent = lift . performEvent
122instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
123 newTriggerEvent = lift newTriggerEvent
124 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
125 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
127instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
128 getPostBuild = lift getPostBuild
130instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
131 tellDyn = lift . tellDyn
133instance MonadState s m => MonadState s (DynamicWriterT t w m) where
134 get = lift get
135 put = lift . put
137newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
139-- | When the execution of a 'DynamicWriterT' action is adjusted using
140-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to
141-- match.
142instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
143 runWithReplace a0 a' = do
144 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
145 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
146 return (fst result0, fst <$> result')
147 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
148 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
150traverseDMapWithKeyWithAdjustImpl :: 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)
151 => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
152 -> DMap k v
153 -> Event t (p k v)
154 -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
155 )
156 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
157 -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
158 -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
159 -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
160 -> DMap k v
161 -> Event t (p k v)
162 -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
163traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
164 (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
165 let getValue (DynamicWriterTLoweredResult (v, _)) = v
166 getWritten (DynamicWriterTLoweredResult (_, w)) = w
167 liftedResult0 = DMap.map getValue result0
168 liftedResult' = ffor result' $ mapPatch getValue
169 liftedWritten0 :: Map (Some k) (Dynamic t w)
170 liftedWritten0 = weakenDMapWith getWritten result0
171 liftedWritten' = ffor result' $ weakenPatchWith getWritten
172 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
173 i <- holdIncremental liftedWritten0 liftedWritten'
174 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
175 return (liftedResult0, liftedResult')
177-- | Map a function over the output of a 'DynamicWriterT'.
178withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
179 => (w -> w')
180 -> DynamicWriterT t w m a
181 -> DynamicWriterT t w' m a
182withDynamicWriterT f dw = do
183 (r, d) <- lift $ do
184 (r, d) <- runDynamicWriterT dw
185 let d' = fmap f d
186 return (r, d')
187 tellDyn d
188 return r
190instance Requester t m => Requester t (DynamicWriterT t w m) where
191 type Request (DynamicWriterT t w m) = Request m
192 type Response (DynamicWriterT t w m) = Response m
193 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f