@@ -12,6 +12,9 @@ module Reflex.Profiled where
1212import Control.Lens hiding (children)
1313import Control.Monad
1414import Control.Monad.Fix
15+import Control.Monad.Primitive
16+import Control.Monad.Reader
17+import Control.Monad.Ref
1518import Data.Coerce
1619import Data.Dependent.Map (DMap, GCompare)
1720import Data.List
@@ -26,6 +29,8 @@ import GHC.Foreign
2629import GHC.IO.Encoding
2730import GHC.Stack
2831import Reflex.Class
32+import Reflex.PerformEvent.Class
33+import Reflex.Host.Class
2934
3035import System.IO.Unsafe
3136import Unsafe.Coerce
@@ -80,7 +85,7 @@ showProfilingData = do
8085 cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
8186 printCostCentreTree cct
8287
83−newtype ProfiledM m a = ProfiledM (m a) deriving (Functor, Applicative, Monad, MonadFix)
88+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
8489
8590profileEvent :: Reflex t => Event t a -> Event t a
8691profileEvent e = unsafePerformIO $ do
@@ -93,10 +98,10 @@ profileEvent e = unsafePerformIO $ do
9398--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
9499
95100instance Reflex t => Reflex (ProfiledTimeline t) where
96− newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled (Behavior t a)
97− newtype Event (ProfiledTimeline t) a = Event_Profiled (Event t a)
98− newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled (Dynamic t a)
99− newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled (Incremental t p)
101+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
102+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
103+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
104+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
100105 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
101106 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
102107 never = Event_Profiled never
@@ -139,3 +144,51 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
139144
140145instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
141146 sample (Behavior_Profiled b) = ProfiledM $ sample b
147+
148+instance MonadTrans ProfiledM where
149+ lift = ProfiledM
150+
151+instance MonadIO m => MonadIO (ProfiledM m) where
152+ liftIO = lift . liftIO
153+
154+instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
155+ type Performable (ProfiledM m) = Performable m
156+ performEvent_ = lift . performEvent_ . coerce
157+ performEvent = lift . fmap coerce . performEvent . coerce
158+
159+instance MonadRef m => MonadRef (ProfiledM m) where
160+ type Ref (ProfiledM m) = Ref m
161+ newRef = lift . newRef
162+ readRef = lift . readRef
163+ writeRef r = lift . writeRef r
164+
165+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
166+ newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
167+ newFanEventWithTrigger f = do
168+ es <- lift $ newFanEventWithTrigger f
169+ return $ EventSelector $ \k -> coerce $ select es k
170+
171+instance MonadReader r m => MonadReader r (ProfiledM m) where
172+ ask = lift ask
173+ local f (ProfiledM a) = ProfiledM $ local f a
174+ reader = lift . reader
175+
176+instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
177+ type EventTrigger (ProfiledTimeline t) = EventTrigger t
178+ type EventHandle (ProfiledTimeline t) = EventHandle t
179+ type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
180+
181+instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
182+ subscribeEvent = lift . subscribeEvent . coerce
183+
184+instance PrimMonad m => PrimMonad (ProfiledM m) where
185+ type PrimState (ProfiledM m) = PrimState m
186+ primitive = lift . primitive
187+
188+instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
189+ type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
190+ fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
191+ runHostFrame = lift . runHostFrame . coerce
192+
193+instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
194+ readEvent = lift . fmap coerce . readEvent