git.iko.soy/patch
on 58010ed help sign in
patch/src/Reflex/DynamicWriter.hs
180 lines 9.8 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 #-}
12module Reflex.DynamicWriter where
14import Control.Monad.Exception
15import Control.Monad.Identity
16import Control.Monad.IO.Class
17import Control.Monad.Reader
18import Control.Monad.Ref
19import Control.Monad.State.Strict
20import Data.Dependent.Map (DMap, DSum (..))
21import Data.Foldable
22import Data.Functor.Compose
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.PerformEvent.Class
32import Reflex.PostBuild.Class
33import Reflex.Host.Class
35instance MonadTrans (DynamicWriterT t w) where
36 lift = DynamicWriterT . lift
38mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map 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 => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
44mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
46mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
47mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
49unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
50unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
52incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
53incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
55mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map 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 (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map 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 (Map k (Dynamic t v)) -> Incremental t PatchMap (Map 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 = [Replaceable t (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 (Map 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, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
115runDynamicWriterT (DynamicWriterT a) = do
116 (result, ws) <- runStateT a []
117 Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
118 return (result, w)
120class Monad m => MonadDynamicWriter t w m | m -> t w where
121 tellDyn :: Dynamic t w -> m ()
123instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
124 tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
126instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
127 ask = lift ask
128 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
129 reader = lift . reader
131liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
132liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
133 s <- get
134 (b, (a, newS)) <- lift $ f $ runStateT child s
135 put newS
136 return (b, a)
138instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
139 type Performable (DynamicWriterT t w m) = Performable m
140 performEvent_ = lift . performEvent_
141 performEvent = lift . performEvent
143instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
144 newTriggerEvent = lift newTriggerEvent
145 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
146 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
148instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
149 getPostBuild = lift getPostBuild
151instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
152 tellDyn = lift . tellDyn
154instance MonadState s m => MonadState s (DynamicWriterT t w m) where
155 get = lift get
156 put = lift . put
158newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }
160instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
161 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do
162 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0
163 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
164 mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p
165 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
166 let getValue (DynamicWriterTLoweredResult (v, _)) = v
167 getWritten (DynamicWriterTLoweredResult (_, w)) = w
168 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0
169 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $
170 mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> k :=> Compose (fmap (Identity . getValue . runIdentity) mr)) p
171 liftedWritten0 :: DMap (Const2 (Some k) (Dynamic t w)) Identity
172 liftedWritten0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> Const2 (Some.This k) :=> Identity (getWritten r)) result0
173 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchDMap $
174 mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> Const2 (Some.This k) :=> Compose (fmap (Identity . getWritten . runIdentity) mr)) p
175 --TODO: We should be able to improve the performance here in two ways
176 -- 1. Incrementally merging the Dynamics
177 -- 2. Incrementally updating the mconcat of the merged Dynamics
178 i <- holdIncremental liftedWritten0 liftedWritten'
179 tellDyn $ join $ fold . dmapToMap <$> incrementalToDynamic i
180 return (liftedResult0, liftedResult')