git.iko.soy/patch
on fcab323 help sign in
patch/src/Reflex/DynamicWriter.hs
181 lines 9.0 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.IO.Class
16import Control.Monad.Reader
17import Control.Monad.Ref
18import Control.Monad.State.Strict
19import Data.Dependent.Map (DMap)
20import Data.Functor.Compose
21import Data.Functor.Misc
22import Data.Map (Map)
23import qualified Data.Map as Map
24import Data.Semigroup
25import Reflex.Class
26import Reflex.Deletable.Class
27import Reflex.Dynamic
28import Reflex.PerformEvent.Class
29import Reflex.PostBuild.Class
30import Reflex.Host.Class
32instance MonadTrans (DynamicWriterT t w) where
33 lift = DynamicWriterT . lift
35data PatchMap a where
36 PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
38instance Patch PatchMap where
39 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
40 where insertions = Map.mapMaybeWithKey (const id) p
41 deletions = Map.mapMaybeWithKey (const nothingToJust) p
42 nothingToJust = \case
43 Nothing -> Just ()
44 Just _ -> Nothing
46instance Ord k => Semigroup (PatchMap (Map k v)) where
47 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
48 -- PatchMap is idempotent, so stimes n is id for every n
49#if MIN_VERSION_semigroups(0,17,0)
50 stimes = stimesIdempotentMonoid
51#else
52 times1p n x = case compare n 0 of
53 LT -> error "stimesIdempotentMonoid: negative multiplier"
54 EQ -> mempty
55 GT -> x
56#endif
58instance Ord k => Monoid (PatchMap (Map k v)) where
59 mempty = PatchMap mempty
60 mappend = (<>)
62mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
63mconcatIncremental m0 e = do
64 d <- foldDynMaybe apply m0 e
65 return $ fmap (mconcat . Map.elems) d
67mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
68mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
70mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
71mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
73unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
74unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
76incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
77incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
79mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
80mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
82holdIncrementalReplaceableMap :: 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))
83holdIncrementalReplaceableMap m0 m' = do
84 rec vals <- holdIncremental m0 $ m' <> valChanges
85 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
86 return $ mapIncrementalMapValues _replaceable_value vals
88mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
89mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
90 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
91 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
93data Replaceable t w = Replaceable
94 { _replaceable_value :: w
95 , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
96 }
98type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
100newtype 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
102instance MonadRef m => MonadRef (DynamicWriterT t w m) where
103 type Ref (DynamicWriterT t w m) = Ref m
104 newRef = lift . newRef
105 readRef = lift . readRef
106 writeRef r = lift . writeRef r
108instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
109 atomicModifyRef r = lift . atomicModifyRef r
111instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
112 newEventWithTrigger = lift . newEventWithTrigger
113 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
115runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
116runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
118mconcatIncrementalReplaceableDynMap :: forall m t k v. (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k) => Map k (Replaceable t (Dynamic t v)) -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v)))) -> Event t () -> m (Replaceable t (Dynamic t v))
119mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
120 rec vals <- holdIncremental m0 $ m' <> valChanges
121 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
122 let i = mapIncrementalMapValues _replaceable_value vals
123 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
124 let replaceSelf nma x = do
125 guard nma
126 case Map.toList x of
127 [] -> return Nothing -- Delete self
128 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
129 _ -> mzero
130 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
131 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
133runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
134runDynamicWriterT (DynamicWriterT a) = do
135 (result, ws) <- runStateT a []
136 Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
137 return (result, w)
139class Monad m => MonadDynamicWriter t w m | m -> t w where
140 tellDyn :: Dynamic t w -> m ()
142instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
143 tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
145instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
146 ask = lift ask
147 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
148 reader = lift . reader
150liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
151liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
152 s <- get
153 (b, (a, newS)) <- lift $ f $ runStateT child s
154 put newS
155 return (b, a)
157instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
158 deletable delete child = do
159 (result, output) <- lift $ deletable delete $ runDynamicWriterT child
160 DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
161 return result
163instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
164 type Performable (DynamicWriterT t w m) = Performable m
165 performEvent_ = lift . performEvent_
166 performEvent = lift . performEvent
168instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
169 newTriggerEvent = lift newTriggerEvent
170 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
171 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
173instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
174 getPostBuild = lift getPostBuild
176instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
177 tellDyn = lift . tellDyn
179instance MonadState s m => MonadState s (DynamicWriterT t w m) where
180 get = lift get
181 put = lift . put