git.iko.soy/patch
on ba77fac help sign in
patch/src/Reflex/DynamicWriter.hs
200 lines 11 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
12#ifdef USE_REFLEX_OPTIMIZER
13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
14#endif
15module Reflex.DynamicWriter where
17import Control.Monad.Exception
18import Control.Monad.Identity
19import Control.Monad.IO.Class
20import Control.Monad.Reader
21import Control.Monad.Ref
22import Control.Monad.State.Strict
23import Data.Dependent.Map (DMap, DSum (..))
24import qualified Data.Dependent.Map as DMap
25import Data.Functor.Misc
26import Data.Map (Map)
27import qualified Data.Map as Map
28import Data.Semigroup
29import Data.Some (Some)
30import qualified Data.Some as Some
31import Reflex.Class
32import Reflex.Dynamic
33import Reflex.Host.Class
34import Reflex.PerformEvent.Class
35import Reflex.PostBuild.Class
37instance MonadTrans (DynamicWriterT t w) where
38 lift = DynamicWriterT . lift
40mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v, Ord k) => Map k v -> Event t (PatchMap k v) -> m (Dynamic t v)
41mconcatIncremental m0 e = do
42 d <- foldDynMaybe apply m0 e
43 return $ fmap (mconcat . Map.elems) d
45mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
46mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
48mapIncrementalMapValues :: (Reflex t, Ord k) => (v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
49mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
51unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
52unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
54incrementalExtractFunctorDMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (f v)) -> Incremental t (PatchDMap (Const2 k v) f)
55incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap ComposeMaybe m
57mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)
58mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
60holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap k (Replaceable t v)) -> m (Incremental t (PatchMap k v))
61holdIncrementalReplaceableMap m0 m' = do
62 rec vals <- holdIncremental m0 $ m' <> valChanges
63 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
64 return $ mapIncrementalMapValues _replaceable_value vals
66mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
67mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
68 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
69 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
71data Replaceable t w = Replaceable
72 { _replaceable_value :: w
73 , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
74 }
76type DynamicWriterAccumulator t w = [Dynamic t w]
78newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
80instance MonadRef m => MonadRef (DynamicWriterT t w m) where
81 type Ref (DynamicWriterT t w m) = Ref m
82 newRef = lift . newRef
83 readRef = lift . readRef
84 writeRef r = lift . writeRef r
86instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
87 atomicModifyRef r = lift . atomicModifyRef r
89instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
90 newEventWithTrigger = lift . newEventWithTrigger
91 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
93runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
94runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
96mconcatIncrementalReplaceableDynMap :: forall m t k v.
97 (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)
98 => Map k (Replaceable t (Dynamic t v))
99 -> Event t (PatchMap k (Replaceable t (Dynamic t v)))
100 -> Event t ()
101 -> m (Replaceable t (Dynamic t v))
102mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
103 rec vals <- holdIncremental m0 $ m' <> valChanges
104 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
105 let i = mapIncrementalMapValues _replaceable_value vals
106 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
107 let replaceSelf nma x = do
108 guard nma
109 case Map.toList x of
110 [] -> return Nothing -- Delete self
111 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
112 _ -> mzero
113 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
114 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
116runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
117runDynamicWriterT (DynamicWriterT a) = do
118 (result, ws) <- runStateT a []
119 return (result, mconcat $ reverse ws)
121class Monad m => MonadDynamicWriter t w m | m -> t w where
122 tellDyn :: Dynamic t w -> m ()
124instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
125 tellDyn w = DynamicWriterT $ modify (w :)
127instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
128 ask = lift ask
129 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
130 reader = lift . reader
132liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
133liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
134 s <- get
135 (b, (a, newS)) <- lift $ f $ runStateT child s
136 put newS
137 return (b, a)
139instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
140 type Performable (DynamicWriterT t w m) = Performable m
141 performEvent_ = lift . performEvent_
142 performEvent = lift . performEvent
144instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
145 newTriggerEvent = lift newTriggerEvent
146 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
147 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
149instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
150 getPostBuild = lift getPostBuild
152instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
153 tellDyn = lift . tellDyn
155instance MonadState s m => MonadState s (DynamicWriterT t w m) where
156 get = lift get
157 put = lift . put
159newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }
161instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
162 runWithReplace a0 a' = do
163 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
164 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
165 return (fst result0, fst <$> result')
166 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do
167 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0
168 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
169 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p
170 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
171 let getValue (DynamicWriterTLoweredResult (v, _)) = v
172 getWritten (DynamicWriterTLoweredResult (_, w)) = w
173 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0
174 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $
175 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (Identity . getValue . runIdentity) mr)) p
176 liftedWritten0 :: Map (Some k) (Dynamic t w)
177 liftedWritten0 = Map.fromDistinctAscList $ (\(WrapArg k :=> Identity r) -> (Some.This k, getWritten r)) <$> DMap.toList result0
178 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchMap $
179 Map.fromDistinctAscList $ (\(WrapArg k :=> ComposeMaybe mr) -> (Some.This k, fmap (getWritten . runIdentity) mr)) <$> DMap.toList p
180 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
181 i <- holdIncremental liftedWritten0 liftedWritten'
182 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
183 return (liftedResult0, liftedResult')
185withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)
186 => (w -> w')
187 -> DynamicWriterT t w m a
188 -> DynamicWriterT t w' m a
189withDynamicWriterT f dw = do
190 (r, d) <- lift $ do
191 (r, d) <- runDynamicWriterT dw
192 let d' = fmap f d
193 return (r, d')
194 tellDyn d
195 return r
197instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where
198 type Request (DynamicWriterT t w m) = Request m
199 type Response (DynamicWriterT t w m) = Response m
200 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f