git.iko.soy/patch
on 84c126c help sign in
patch/src/Reflex/DynamicWriter.hs
168 lines 8.5 kB history raw
1-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard
2-- implementation.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.DynamicWriter
17 ( MonadDynamicWriter (..)
18 , DynamicWriterT (..)
19 , runDynamicWriterT
20 , withDynamicWriterT
21 ) where
23import Control.Monad.Exception
24import Control.Monad.Identity
25import Control.Monad.IO.Class
26import Control.Monad.Reader
27import Control.Monad.Ref
28import Control.Monad.State.Strict
29import Data.Dependent.Map (DMap, DSum (..))
30import qualified Data.Dependent.Map as DMap
31import Data.Functor.Misc
32import Data.Map (Map)
33import qualified Data.Map as Map
34import Data.Semigroup
35import Data.Some (Some)
36import qualified Data.Some as Some
37import Reflex.Class
38import Reflex.Host.Class
39import Reflex.PerformEvent.Class
40import Reflex.PostBuild.Class
41import Reflex.Requester.Class
42import Reflex.TriggerEvent.Class
44instance MonadTrans (DynamicWriterT t w) where
45 lift = DynamicWriterT . lift
47mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
48mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
50mapIncrementalMapValues :: (Reflex t, Ord k) => (v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')
51mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
53unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
54unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
56incrementalExtractFunctorDMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (f v)) -> Incremental t (PatchDMap (Const2 k v) f)
57incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap ComposeMaybe m
59mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)
60mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
62mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
63mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
64 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
65 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
67-- | A basic implementation of 'MonadDynamicWriter'.
68newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
70instance MonadRef m => MonadRef (DynamicWriterT t w m) where
71 type Ref (DynamicWriterT t w m) = Ref m
72 newRef = lift . newRef
73 readRef = lift . readRef
74 writeRef r = lift . writeRef r
76instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
77 atomicModifyRef r = lift . atomicModifyRef r
79instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
80 newEventWithTrigger = lift . newEventWithTrigger
81 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
83-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
84-- along with the result of the action.
85runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
86runDynamicWriterT (DynamicWriterT a) = do
87 (result, ws) <- runStateT a []
88 return (result, mconcat $ reverse ws)
90-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
91-- and combines them monoidally to provide a 'Dynamic' result.
92class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
93 tellDyn :: Dynamic t w -> m ()
95instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
96 tellDyn w = DynamicWriterT $ modify (w :)
98instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
99 ask = lift ask
100 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
101 reader = lift . reader
103instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
104 type Performable (DynamicWriterT t w m) = Performable m
105 performEvent_ = lift . performEvent_
106 performEvent = lift . performEvent
108instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
109 newTriggerEvent = lift newTriggerEvent
110 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
111 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
113instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
114 getPostBuild = lift getPostBuild
116instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
117 tellDyn = lift . tellDyn
119instance MonadState s m => MonadState s (DynamicWriterT t w m) where
120 get = lift get
121 put = lift . put
123newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult (v, Dynamic t w)
125-- | When the execution of a 'DynamicWriterT' action is adjusted using
126-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to
127-- match.
128instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
129 runWithReplace a0 a' = do
130 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
131 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
132 return (fst result0, fst <$> result')
133 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do
134 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0
135 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
136 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p
137 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
138 let getValue (DynamicWriterTLoweredResult (v, _)) = v
139 getWritten (DynamicWriterTLoweredResult (_, w)) = w
140 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0
141 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $
142 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (Identity . getValue . runIdentity) mr)) p
143 liftedWritten0 :: Map (Some k) (Dynamic t w)
144 liftedWritten0 = Map.fromDistinctAscList $ (\(WrapArg k :=> Identity r) -> (Some.This k, getWritten r)) <$> DMap.toList result0
145 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchMap $
146 Map.fromDistinctAscList $ (\(WrapArg k :=> ComposeMaybe mr) -> (Some.This k, fmap (getWritten . runIdentity) mr)) <$> DMap.toList p
147 --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
148 i <- holdIncremental liftedWritten0 liftedWritten'
149 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
150 return (liftedResult0, liftedResult')
152-- | Map a function over the output of a 'DynamicWriterT'.
153withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
154 => (w -> w')
155 -> DynamicWriterT t w m a
156 -> DynamicWriterT t w' m a
157withDynamicWriterT f dw = do
158 (r, d) <- lift $ do
159 (r, d) <- runDynamicWriterT dw
160 let d' = fmap f d
161 return (r, d')
162 tellDyn d
163 return r
165instance Requester t m => Requester t (DynamicWriterT t w m) where
166 type Request (DynamicWriterT t w m) = Request m
167 type Response (DynamicWriterT t w m) = Response m
168 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f