git.iko.soy/patch
on 5374696 help sign in
patch/src/Reflex/DynamicWriter.hs
180 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
26import Reflex.Deletable.Class
27import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Class
29import Reflex.Host.Class
31instance MonadTrans (DynamicWriterT t w) where
32 lift = DynamicWriterT . lift
34data PatchMap a where
35 PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
37instance Patch PatchMap where
38 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?
39 where insertions = Map.mapMaybeWithKey (const id) p
40 deletions = Map.mapMaybeWithKey (const nothingToJust) p
41 nothingToJust = \case
42 Nothing -> Just ()
43 Just _ -> Nothing
45instance Ord k => Semigroup (PatchMap (Map k v)) where
46 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
47 -- PatchMap is idempotent, so stimes n is id for every n
48#if MIN_VERSION_semigroups(0,17,0)
49 stimes = stimesIdempotentMonoid
50#else
51 times1p n x = case compare n 0 of
52 LT -> error "stimesIdempotentMonoid: negative multiplier"
53 EQ -> mempty
54 GT -> x
55#endif
57instance Ord k => Monoid (PatchMap (Map k v)) where
58 mempty = PatchMap mempty
59 mappend = (<>)
61mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
62mconcatIncremental m0 e = do
63 d <- foldDynMaybe apply m0 e
64 return $ fmap (mconcat . Map.elems) d
66mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
67mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
69mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
70mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
72unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
73unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
75incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
76incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
78mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
79mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
81holdIncrementalReplaceableMap :: 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))
82holdIncrementalReplaceableMap m0 m' = do
83 rec vals <- holdIncremental m0 $ m' <> valChanges
84 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
85 return $ mapIncrementalMapValues _replaceable_value vals
87mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
88mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
89 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
90 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
92data Replaceable t w = Replaceable
93 { _replaceable_value :: w
94 , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
95 }
97type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
99newtype 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
101instance MonadRef m => MonadRef (DynamicWriterT t w m) where
102 type Ref (DynamicWriterT t w m) = Ref m
103 newRef = lift . newRef
104 readRef = lift . readRef
105 writeRef r = lift . writeRef r
107instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
108 atomicModifyRef r = lift . atomicModifyRef r
110instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
111 newEventWithTrigger = lift . newEventWithTrigger
112 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
114runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
115runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
117mconcatIncrementalReplaceableDynMap :: 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))
118mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
119 rec vals <- holdIncremental m0 $ m' <> valChanges
120 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
121 let i = mapIncrementalMapValues _replaceable_value vals
122 noMoreAdditions <- holdDyn False $ True <$ additionsCeased
123 let replaceSelf nma x = do
124 guard nma
125 case Map.toList x of
126 [] -> return Nothing -- Delete self
127 [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
128 _ -> mzero
129 result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
130 return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
132runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
133runDynamicWriterT (DynamicWriterT a) = do
134 (result, ws) <- runStateT a []
135 Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
136 return (result, w)
138class Monad m => MonadDynamicWriter t w m | m -> t w where
139 tellDyn :: Dynamic t w -> m ()
141instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
142 tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
144instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
145 ask = lift ask
146 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
147 reader = lift . reader
149liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
150liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
151 s <- get
152 (b, (a, newS)) <- lift $ f $ runStateT child s
153 put newS
154 return (b, a)
156instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
157 deletable delete child = do
158 (result, output) <- lift $ deletable delete $ runDynamicWriterT child
159 DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
160 return result
162instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
163 type Performable (DynamicWriterT t w m) = Performable m
164 performEvent_ = lift . performEvent_
165 performEvent = lift . performEvent
167instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
168 newTriggerEvent = lift newTriggerEvent
169 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
170 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
172instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
173 getPostBuild = lift getPostBuild
175instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
176 tellDyn = lift . tellDyn
178instance MonadState s m => MonadState s (DynamicWriterT t w m) where
179 get = lift get
180 put = lift . put