{-# LANGUAGE BangPatterns #-}

-- | Note: this module is re-exported as a whole from "Test.Tasty.Runners"
module Test.Tasty.Runners.Utils where

import Control.Exception
import Control.Applicative
import Control.Concurrent (mkWeakThreadId, myThreadId)
import Control.Monad (forM_)
#ifndef VERSION_clock
import Data.Time.Clock.POSIX (getPOSIXTime)
#endif
import Data.Typeable (Typeable)
import Prelude  -- Silence AMP import warnings
import Text.Printf
import Foreign.C (CInt)
#ifdef VERSION_clock
import qualified System.Clock as Clock
#endif

-- Install handlers only on UNIX
#ifdef VERSION_unix
#define INSTALL_HANDLERS 1
#else
#define INSTALL_HANDLERS 0
#endif

#if INSTALL_HANDLERS
import System.Posix.Signals
import System.Mem.Weak (deRefWeak)
#endif

import Test.Tasty.Core (Time)

-- | Catch possible exceptions that may arise when evaluating a string.
-- For normal (total) strings, this is a no-op.
--
-- This function should be used to display messages generated by the test
-- suite (such as test result descriptions).
--
-- See e.g. <https://github.com/feuerbach/tasty/issues/25>
formatMessage :: String -> IO String
formatMessage :: String -> IO String
formatMessage = Int -> String -> IO String
go Int
3
  where
    -- to avoid infinite recursion, we introduce the recursion limit
    go :: Int -> String -> IO String
    go :: Int -> String -> IO String
go Int
0        String
_ = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"exceptions keep throwing other exceptions!"
    go Int
recLimit String
msg = do
      Either SomeException ()
mbStr <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ()
forall a. [a] -> ()
forceElements String
msg
      case Either SomeException ()
mbStr of
        Right () -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
        Left SomeException
e' -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"message threw an exception: %s" (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> String -> IO String
go (Int
recLimitInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e' :: SomeException))

-- | Force elements of a list
-- (<https://ro-che.info/articles/2015-05-28-force-list>)
forceElements :: [a] -> ()
forceElements :: [a] -> ()
forceElements = (a -> () -> ()) -> () -> [a] -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> () -> ()
seq ()

-- from https://ro-che.info/articles/2014-07-30-bracket
-- | Install signal handlers so that e.g. the cursor is restored if the test
-- suite is killed by SIGTERM. Upon a signal, a 'SignalException' will be
-- thrown to the thread that has executed this action.
--
-- This function is called automatically from the @defaultMain*@ family of
-- functions. You only need to call it explicitly if you call
-- 'tryIngredients' yourself.
--
-- This function does nothing on non-UNIX systems or when compiled with GHC
-- older than 7.6.
installSignalHandlers :: IO ()
installSignalHandlers :: IO ()
installSignalHandlers = do
#if INSTALL_HANDLERS
  ThreadId
main_thread_id <- IO ThreadId
myThreadId
  Weak ThreadId
weak_tid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
main_thread_id
  [CInt] -> (CInt -> IO Handler) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ CInt
sigHUP, CInt
sigTERM, CInt
sigUSR1, CInt
sigUSR2, CInt
sigXCPU, CInt
sigXFSZ ] ((CInt -> IO Handler) -> IO ()) -> (CInt -> IO Handler) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
sig ->
    CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ Weak ThreadId -> CInt -> IO ()
send_exception Weak ThreadId
weak_tid CInt
sig) Maybe SignalSet
forall a. Maybe a
Nothing
  where
    send_exception :: Weak ThreadId -> CInt -> IO ()
send_exception Weak ThreadId
weak_tid CInt
sig = do
      Maybe ThreadId
m <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
weak_tid
      case Maybe ThreadId
m of
        Maybe ThreadId
Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ThreadId
tid -> ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (SignalException -> SomeException
forall e. Exception e => e -> SomeException
toException (SignalException -> SomeException)
-> SignalException -> SomeException
forall a b. (a -> b) -> a -> b
$ CInt -> SignalException
SignalException CInt
sig)
#else
  return ()
#endif

-- | This exception is thrown when the program receives a signal, assuming
-- 'installSignalHandlers' was called.
--
-- The 'CInt' field contains the signal number, as in
-- 'System.Posix.Signals.Signal'. We don't use that type synonym, however,
-- because it's not available on non-UNIXes.
newtype SignalException = SignalException CInt
  deriving (Int -> SignalException -> String -> String
[SignalException] -> String -> String
SignalException -> String
(Int -> SignalException -> String -> String)
-> (SignalException -> String)
-> ([SignalException] -> String -> String)
-> Show SignalException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SignalException] -> String -> String
$cshowList :: [SignalException] -> String -> String
show :: SignalException -> String
$cshow :: SignalException -> String
showsPrec :: Int -> SignalException -> String -> String
$cshowsPrec :: Int -> SignalException -> String -> String
Show, Typeable)
instance Exception SignalException

-- | Measure the time taken by an 'IO' action to run
timed :: IO a -> IO (Time, a)
timed :: IO a -> IO (Time, a)
timed IO a
t = do
  Time
start <- IO Time
getTime
  !a
r    <- IO a
t
  Time
end   <- IO Time
getTime
  (Time, a) -> IO (Time, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
endTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
start, a
r)

#ifdef VERSION_clock
-- | Get monotonic time
--
-- Warning: This is not the system time, but a monotonically increasing time
-- that facilitates reliable measurement of time differences.
getTime :: IO Time
getTime :: IO Time
getTime = do
  TimeSpec
t <- Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Monotonic
  let ns :: Time
ns = Integer -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Integer -> Time) -> Integer -> Time
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_clock(0,7,1)
        TimeSpec -> Integer
Clock.toNanoSecs TimeSpec
t
#else
        Clock.timeSpecAsNanoSecs t
#endif
  Time -> IO Time
forall (m :: * -> *) a. Monad m => a -> m a
return (Time -> IO Time) -> Time -> IO Time
forall a b. (a -> b) -> a -> b
$ Time
ns Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
10 Time -> Int -> Time
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
9 :: Int)
#else
-- | Get system time
getTime :: IO Time
getTime = realToFrac <$> getPOSIXTime
#endif