{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes   #-}

module Test.Hspec.Slow (
    configure,
    timedHspec,
    timedHspecParallel,
    timeThese
  ) where

import           Control.Concurrent.STM.TVar
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.STM
import           Data.Time.Clock
import           Test.Hspec
import           Data.Maybe
import           Test.Hspec.Core.Spec

type SlowResults = [(String, NominalDiffTime)]
type SlowResultTracker = TVar SlowResults

data SlowConfiguration = SlowConfiguration {
  SlowConfiguration -> Int
duration :: Int,
  SlowConfiguration -> SlowResultTracker
tracker  :: SlowResultTracker
}

configure :: Int -> IO SlowConfiguration
configure :: Int -> IO SlowConfiguration
configure Int
x =
  [(String, NominalDiffTime)] -> IO SlowResultTracker
forall a. a -> IO (TVar a)
newTVarIO [] IO SlowResultTracker
-> (SlowResultTracker -> IO SlowConfiguration)
-> IO SlowConfiguration
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SlowResultTracker
t ->
    SlowConfiguration -> IO SlowConfiguration
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> SlowResultTracker -> SlowConfiguration
SlowConfiguration Int
x SlowResultTracker
t)

stopwatch :: MonadIO m => m a -> m (a, NominalDiffTime)
stopwatch :: m a -> m (a, NominalDiffTime)
stopwatch m a
x = do
  UTCTime
start <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  !a
a <- m a
x
  UTCTime
end <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  (a, NominalDiffTime) -> m (a, NominalDiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start)

trackedAction :: MonadIO m => String -> m a -> ReaderT SlowConfiguration m a
trackedAction :: String -> m a -> ReaderT SlowConfiguration m a
trackedAction String
s m a
m = do
  SlowConfiguration
conf <- ReaderT SlowConfiguration m SlowConfiguration
forall r (m :: * -> *). MonadReader r m => m r
ask
  (a
result, NominalDiffTime
d) <- m (a, NominalDiffTime)
-> ReaderT SlowConfiguration m (a, NominalDiffTime)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> m (a, NominalDiffTime)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, NominalDiffTime)
stopwatch m a
m)
  if NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> (Int -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Int -> NominalDiffTime)
-> (SlowConfiguration -> Int)
-> SlowConfiguration
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlowConfiguration -> Int
duration (SlowConfiguration -> NominalDiffTime)
-> SlowConfiguration -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ SlowConfiguration
conf)
    then do
      IO () -> ReaderT SlowConfiguration m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SlowConfiguration m ())
-> IO () -> ReaderT SlowConfiguration m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ SlowResultTracker
-> ([(String, NominalDiffTime)] -> [(String, NominalDiffTime)])
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (SlowConfiguration -> SlowResultTracker
tracker SlowConfiguration
conf) ([(String, NominalDiffTime)]
-> [(String, NominalDiffTime)] -> [(String, NominalDiffTime)]
forall a. [a] -> [a] -> [a]
++ [(String
s, NominalDiffTime
d)])
      a -> ReaderT SlowConfiguration m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
    else a -> ReaderT SlowConfiguration m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

type Timer = forall m a. (MonadIO m, Example (m a)) => String -> m a -> SpecWith (Arg (m a))

timed :: SlowConfiguration -> Timer
timed :: SlowConfiguration -> Timer
timed SlowConfiguration
c String
s m a
a = String -> m a -> SpecWith (Arg (m a))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
s (m a -> SpecWith (Arg (m a))) -> m a -> SpecWith (Arg (m a))
forall a b. (a -> b) -> a -> b
$ ReaderT SlowConfiguration m a -> SlowConfiguration -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (String -> m a -> ReaderT SlowConfiguration m a
forall (m :: * -> *) a.
MonadIO m =>
String -> m a -> ReaderT SlowConfiguration m a
trackedAction String
s m a
a) SlowConfiguration
c

slowReport :: (MonadIO m) => SlowConfiguration -> m ()
slowReport :: SlowConfiguration -> m ()
slowReport SlowConfiguration
s = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [(String, NominalDiffTime)]
slows <- SlowResultTracker -> IO [(String, NominalDiffTime)]
forall a. TVar a -> IO a
readTVarIO (SlowConfiguration -> SlowResultTracker
tracker SlowConfiguration
s)
    String -> IO ()
putStrLn String
"Slow examples:"
    ((String, NominalDiffTime) -> IO ())
-> [(String, NominalDiffTime)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
t, NominalDiffTime
v) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> String
forall a. Show a => a -> String
show NominalDiffTime
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t) [(String, NominalDiffTime)]
slows

timedHspec :: SlowConfiguration -> (Timer -> SpecWith ()) -> IO ()
timedHspec :: SlowConfiguration -> (Timer -> SpecWith ()) -> IO ()
timedHspec SlowConfiguration
t Timer -> SpecWith ()
x = SpecWith () -> IO ()
hspec (SpecWith () -> IO ()) -> SpecWith () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> SpecWith () -> SpecWith ()
forall a. IO () -> SpecWith a -> SpecWith a
afterAll_ (IO () -> SpecWith () -> SpecWith ())
-> (SlowConfiguration -> IO ())
-> SlowConfiguration
-> SpecWith ()
-> SpecWith ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlowConfiguration -> IO ()
forall (m :: * -> *). MonadIO m => SlowConfiguration -> m ()
slowReport) SlowConfiguration
t (SpecWith () -> SpecWith ()) -> SpecWith () -> SpecWith ()
forall a b. (a -> b) -> a -> b
$ Timer -> SpecWith ()
x (SlowConfiguration -> Timer
timed SlowConfiguration
t)

timedHspecParallel :: SlowConfiguration -> (Timer -> SpecWith ()) -> IO ()
timedHspecParallel :: SlowConfiguration -> (Timer -> SpecWith ()) -> IO ()
timedHspecParallel SlowConfiguration
t Timer -> SpecWith ()
x = SpecWith () -> IO ()
hspec (SpecWith () -> IO ()) -> SpecWith () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> SpecWith () -> SpecWith ()
forall a. IO () -> SpecWith a -> SpecWith a
afterAll_ (IO () -> SpecWith () -> SpecWith ())
-> (SlowConfiguration -> IO ())
-> SlowConfiguration
-> SpecWith ()
-> SpecWith ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlowConfiguration -> IO ()
forall (m :: * -> *). MonadIO m => SlowConfiguration -> m ()
slowReport) SlowConfiguration
t (SpecWith () -> SpecWith ()) -> SpecWith () -> SpecWith ()
forall a b. (a -> b) -> a -> b
$ SpecWith () -> SpecWith ()
forall a. SpecWith a -> SpecWith a
parallel (SpecWith () -> SpecWith ()) -> SpecWith () -> SpecWith ()
forall a b. (a -> b) -> a -> b
$ Timer -> SpecWith ()
x (SlowConfiguration -> Timer
timed SlowConfiguration
t)

-- | times all tests without having to use a custom `it` function
timeThese :: SlowConfiguration -> SpecWith a -> SpecWith a
timeThese :: SlowConfiguration -> SpecWith a -> SpecWith a
timeThese SlowConfiguration
config = (IO () -> SpecWith a -> SpecWith a
forall a. IO () -> SpecWith a -> SpecWith a
afterAll_ (SlowConfiguration -> IO ()
forall (m :: * -> *). MonadIO m => SlowConfiguration -> m ()
slowReport SlowConfiguration
config)) (SpecWith a -> SpecWith a)
-> (SpecWith a -> SpecWith a) -> SpecWith a -> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item a -> Item a) -> SpecWith a -> SpecWith a
forall a. (Item a -> Item a) -> SpecWith a -> SpecWith a
mapSpecItem_ ((Item a -> ActionWith a -> ActionWith a) -> Item a -> Item a
forall a b.
(Item a -> ActionWith a -> ActionWith b) -> Item a -> Item b
modifyAroundAction ((Item a -> ActionWith a -> ActionWith a) -> Item a -> Item a)
-> (Item a -> ActionWith a -> ActionWith a) -> Item a -> Item a
forall a b. (a -> b) -> a -> b
$ SlowConfiguration -> Item a -> ActionWith a -> ActionWith a
forall a. SlowConfiguration -> Item a -> (a -> IO ()) -> a -> IO ()
adhocMeasure SlowConfiguration
config)

adhocMeasure :: SlowConfiguration -> Item a -> (a -> IO ()) -> a -> IO ()
adhocMeasure :: SlowConfiguration -> Item a -> (a -> IO ()) -> a -> IO ()
adhocMeasure SlowConfiguration
config Item a
item a -> IO ()
theTestF a
a = ReaderT SlowConfiguration IO () -> SlowConfiguration -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (String -> IO () -> ReaderT SlowConfiguration IO ()
forall (m :: * -> *) a.
MonadIO m =>
String -> m a -> ReaderT SlowConfiguration m a
trackedAction (Item a -> String
forall a. Item a -> String
makeDescription Item a
item) (IO () -> ReaderT SlowConfiguration IO ())
-> IO () -> ReaderT SlowConfiguration IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO ()
theTestF a
a) SlowConfiguration
config

makeDescription :: Item a -> String
makeDescription :: Item a -> String
makeDescription Item a
item = Maybe Location -> String
defaultDescription (Item a -> Maybe Location
forall a. Item a -> Maybe Location
itemLocation Item a
item)  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\t" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
  Item a -> String
forall a. Item a -> String
itemRequirement Item a
item

defaultDescription :: Maybe Location -> String
defaultDescription :: Maybe Location -> String
defaultDescription Maybe Location
stack = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"source location not found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Location -> String
forall a. Show a => a -> String
show Maybe Location
stack)  (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ do
  Location String
locationFile Int
locationLine Int
locationColumn <- Maybe Location
stack
  String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String
locationFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
locationLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
locationColumn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")

modifyAroundAction :: (Item a -> ActionWith a -> ActionWith b) -> Item a -> Item b
modifyAroundAction :: (Item a -> ActionWith a -> ActionWith b) -> Item a -> Item b
modifyAroundAction Item a -> ActionWith a -> ActionWith b
action item :: Item a
item@Item{itemExample :: forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample = Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
e} =
  Item a
item{ itemExample :: Params -> (ActionWith b -> IO ()) -> ProgressCallback -> IO Result
itemExample = \Params
params ActionWith b -> IO ()
aroundAction -> Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
e Params
params (ActionWith b -> IO ()
aroundAction (ActionWith b -> IO ())
-> (ActionWith a -> ActionWith b) -> ActionWith a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> ActionWith a -> ActionWith b
action Item a
item) }