git.iko.soy/patch
on 1ff7dbf help sign in
patch/src/Reflex/DynamicWriter.hs
198 lines 10 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{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13module Reflex.DynamicWriter where
15import Control.Monad.Exception
16import Control.Monad.Identity
17import Control.Monad.IO.Class
18import Control.Monad.Reader
19import Control.Monad.Ref
20import Control.Monad.State.Strict
21import Data.Dependent.Map (DMap, DSum (..))
22import qualified Data.Dependent.Map as DMap
23import Data.Functor.Misc
24import Data.Map (Map)
25import qualified Data.Map as Map
26import Data.Semigroup
27import Data.Some (Some)
28import qualified Data.Some as Some
29import Reflex.Class
30import Reflex.Dynamic
31import Reflex.Host.Class
32import Reflex.PerformEvent.Class
33import Reflex.PostBuild.Class
35instance MonadTrans (DynamicWriterT t w) where
36 lift = DynamicWriterT . lift
38mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v, Ord k) => Map k v -> Event t (PatchMap k v) -> m (Dynamic t v)
39mconcatIncremental m0 e = do
40 d <- foldDynMaybe apply m0 e
41 return $ fmap (mconcat . Map.elems) d
43mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
44mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
46mapIncrementalMapValues :: (Reflex t, Ord k) => (v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
47mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
49unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
50unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
52incrementalExtractFunctorDMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (f v)) -> Incremental t (PatchDMap (Const2 k v) f)
53incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap ComposeMaybe m
55mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)
56mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
58holdIncrementalReplaceableMap :: 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))
59holdIncrementalReplaceableMap m0 m' = do
60 rec vals <- holdIncremental m0 $ m' <> valChanges
61 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
62 return $ mapIncrementalMapValues _replaceable_value vals
64mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
65mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
66 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
67 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
69data Replaceable t w = Replaceable
70 { _replaceable_value :: w
71 , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
72 }
74type DynamicWriterAccumulator t w = [Dynamic t w]
76newtype 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
78instance MonadRef m => MonadRef (DynamicWriterT t w m) where
79 type Ref (DynamicWriterT t w m) = Ref m
80 newRef = lift . newRef
81 readRef = lift . readRef
82 writeRef r = lift . writeRef r
84instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
85 atomicModifyRef r = lift . atomicModifyRef r
87instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
88 newEventWithTrigger = lift . newEventWithTrigger
89 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
91runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
92runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
94mconcatIncrementalReplaceableDynMap :: forall m t k v.
95 (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)
96 => Map k (Replaceable t (Dynamic t v))
97 -> Event t (PatchMap k (Replaceable t (Dynamic t v)))
98 -> Event t ()
99 -> m (Replaceable t (Dynamic t v))
100mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
101 rec vals <- holdIncremental m0 $ m' <> valChanges
102 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
103 let i = mapIncrementalMapValues _replaceable_value vals
104 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
105 let replaceSelf nma x = do
106 guard nma
107 case Map.toList x of
108 [] -> return Nothing -- Delete self
109 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
110 _ -> mzero
111 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
112 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
114runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
115runDynamicWriterT (DynamicWriterT a) = do
116 (result, ws) <- runStateT a []
117 return (result, mconcat $ reverse ws)
119class Monad m => MonadDynamicWriter t w m | m -> t w where
120 tellDyn :: Dynamic t w -> m ()
122instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
123 tellDyn w = DynamicWriterT $ modify (w :)
125instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
126 ask = lift ask
127 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
128 reader = lift . reader
130liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
131liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
132 s <- get
133 (b, (a, newS)) <- lift $ f $ runStateT child s
134 put newS
135 return (b, a)
137instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
138 type Performable (DynamicWriterT t w m) = Performable m
139 performEvent_ = lift . performEvent_
140 performEvent = lift . performEvent
142instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
143 newTriggerEvent = lift newTriggerEvent
144 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
145 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
147instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
148 getPostBuild = lift getPostBuild
150instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
151 tellDyn = lift . tellDyn
153instance MonadState s m => MonadState s (DynamicWriterT t w m) where
154 get = lift get
155 put = lift . put
157newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }
159instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
160 runWithReplace a0 a' = do
161 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
162 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
163 return (fst result0, fst <$> result')
164 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do
165 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0
166 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
167 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p
168 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
169 let getValue (DynamicWriterTLoweredResult (v, _)) = v
170 getWritten (DynamicWriterTLoweredResult (_, w)) = w
171 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0
172 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $
173 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (Identity . getValue . runIdentity) mr)) p
174 liftedWritten0 :: Map (Some k) (Dynamic t w)
175 liftedWritten0 = Map.fromDistinctAscList $ fmap (\(WrapArg k :=> Identity r) -> (Some.This k, getWritten r)) $ DMap.toList result0
176 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchMap $
177 Map.fromDistinctAscList $ fmap (\(WrapArg k :=> ComposeMaybe mr) -> (Some.This k, fmap (getWritten . runIdentity) mr)) $ DMap.toList p
178 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
179 i <- holdIncremental liftedWritten0 liftedWritten'
180 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
181 return (liftedResult0, liftedResult')
183withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)
184 => (w -> w')
185 -> DynamicWriterT t w m a
186 -> DynamicWriterT t w' m a
187withDynamicWriterT f dw = do
188 (r, d) <- lift $ do
189 (r, d) <- runDynamicWriterT dw
190 let d' = fmap f d
191 return (r, d')
192 tellDyn d
193 return r
195instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where
196 type Request (DynamicWriterT t w m) = Request m
197 type Response (DynamicWriterT t w m) = Response m
198 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f