git.iko.soy/patch
on develop help sign in
Add some typeclasses for Profiled
73658fdRyan Trinkle
src/Reflex/Profiled.hs+58−5
compare with develop
unifiedsplit
@@ -12,6 +12,9 @@ module Reflex.Profiled where
12import Control.Lens hiding (children)
12import Control.Lens hiding (children)
13import Control.Monad
13import Control.Monad
14import Control.Monad.Fix
14import Control.Monad.Fix
15+import Control.Monad.Primitive
16+import Control.Monad.Reader
17+import Control.Monad.Ref
15import Data.Coerce
18import Data.Coerce
16import Data.Dependent.Map (DMap, GCompare)
19import Data.Dependent.Map (DMap, GCompare)
17import Data.List
20import Data.List
@@ -26,6 +29,8 @@ import GHC.Foreign
26import GHC.IO.Encoding
29import GHC.IO.Encoding
27import GHC.Stack
30import GHC.Stack
28import Reflex.Class
31import Reflex.Class
32+import Reflex.PerformEvent.Class
33+import Reflex.Host.Class
29
34
30import System.IO.Unsafe
35import System.IO.Unsafe
31import Unsafe.Coerce
36import Unsafe.Coerce
@@ -80,7 +85,7 @@ showProfilingData = do
80 cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
85 cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
81 printCostCentreTree cct
86 printCostCentreTree cct
82
87
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)
84
89
85profileEvent :: Reflex t => Event t a -> Event t a
90profileEvent :: Reflex t => Event t a -> Event t a
86profileEvent e = unsafePerformIO $ do
91profileEvent e = unsafePerformIO $ do
@@ -93,10 +98,10 @@ profileEvent e = unsafePerformIO $ do
93--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
98--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
94
99
95instance Reflex t => Reflex (ProfiledTimeline t) where
100instance Reflex t => Reflex (ProfiledTimeline t) where
96− newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled (Behavior t a)
101+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
97− newtype Event (ProfiledTimeline t) a = Event_Profiled (Event t a)
102+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
98− newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled (Dynamic t a)
103+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
99− newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled (Incremental t p)
104+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
100 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
105 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
101 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
106 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
102 never = Event_Profiled never
107 never = Event_Profiled never
@@ -139,3 +144,51 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
139
144
140instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
145instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
141 sample (Behavior_Profiled b) = ProfiledM $ sample b
146 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