-- | A module with time measuring primitives that might not work in all monads
-- that building allows.
--
-- Measures are collected only if the environment variable
-- @DEBUG_TIMESTATS_ENABLE@ is set to any value ahead of invoking any function
-- in this module.
--
module Debug.TimeStats.Unsafe
  ( unsafeMeasureM
  ) where

import Debug.TimeStats
         ( lookupTimeStatsRef
         , measureMWithLiftIO
         )
import GHC.Clock (getMonotonicTimeNSec)
import System.IO.Unsafe (unsafePerformIO)

-- | Like 'Debug.TimeStats.measureM' but can measure other monads.
--
-- This function relies on a hack to perform IO in any monad, which does not
-- always work. In particular, we can expect it to miss time in monads where
--
-- > seq (m >>= \_ -> undefined) () == undefined -- for some computation m
--
-- An example of such a monad is the list monad
--
-- > seq ([()] >>= \_ -> undefined) () == undefined
--
-- Another example is the monad @Control.Monad.Free.Free f@.
--
-- > seq (return () >>= \_ -> undefined :: Free IO ()) () == undefined
--
-- But it seems to work in monads with state like @IO@, @ReaderT IO@, and
-- @Control.Monad.State.State s@.
--
-- > seq (return () >>= \_ -> undefined :: YourMonadHere ()) () == ()
--
{-# INLINE unsafeMeasureM #-}
unsafeMeasureM :: Monad m => String -> m a -> m a
unsafeMeasureM :: forall (m :: * -> *) a. Monad m => String -> m a -> m a
unsafeMeasureM String
label = String -> (forall b. IO b -> m b) -> m a -> m a
forall (m :: * -> *) a.
Monad m =>
String -> (forall b. IO b -> m b) -> m a -> m a
measureMWithLiftIO String
label IO b -> m b
forall b. IO b -> m b
forall (m :: * -> *) a. Monad m => IO a -> m a
intersperseIOinM

---------------------
-- intersperseIOinM
---------------------

-- | Hack to intersperse IO actions into any monad
intersperseIOinM :: Monad m => IO a -> m a
intersperseIOinM :: forall (m :: * -> *) a. Monad m => IO a -> m a
intersperseIOinM IO a
m = do
    -- The fictitious state is only used to force @unsafePerformIO@
    -- to run @m@ every time @intersperseIOinM m@ is evaluated.
    Bool
s <- m Bool
getStateM
    case IO (Bool, a) -> (Bool, a)
forall a. IO a -> a
unsafePerformIO (IO (Bool, a) -> (Bool, a)) -> IO (Bool, a) -> (Bool, a)
forall a b. (a -> b) -> a -> b
$ (,) Bool
s (a -> (Bool, a)) -> IO a -> IO (Bool, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m of
      (Bool
_, a
r) -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
  where
    -- We mark this function as NOINLINE to ensure the compiler cannot reason
    -- by unfolding that two calls of @getStateM@ yield the same value.
    {-# NOINLINE getStateM #-}
    getStateM :: m Bool
getStateM = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True