Util.hs

{-# LANGUAGE CPP #-}

module Test.Util (
    -- * Timeouts
    Timeout(..)
  , within

    -- * Files
  , withTemporaryFile
  ) where

import Control.Concurrent
import Control.Exception
import Control.Monad.Catch
import Control.Monad.IO.Class
import GHC.Stack
import System.IO
import System.IO.Temp

{-------------------------------------------------------------------------------
  Timeouts
-------------------------------------------------------------------------------}

data Timeout = forall a. Show a => Timeout a CallStack
  deriving anyclass (Exception)

deriving stock instance Show Timeout

-- | Limit execution time of an action
within :: forall m a info.
     (HasCallStack, Show info, MonadIO m, MonadMask m)
  => Int   -- ^ Maximum duration in seconds
  -> info  -- ^ Additional information to include in the exception if thrown
  -> m a -> m a
within t info io = do
    me <- liftIO $ myThreadId

    let timer :: IO ()
        timer = do
            interruptible $ -- Ensure that the timer can be killed
              threadDelay (t * 1_000_000)
            throwTo me $ Timeout info callStack

        startTimer :: m ThreadId
        startTimer = liftIO $ forkIO timer

        stopTimer :: ThreadId -> ExitCase a -> m ()
        stopTimer tid _ = liftIO $ killThread tid

    fmap fst $
      generalBracket startTimer stopTimer $ \_ -> io

withTemporaryFile :: (FilePath -> IO a) -> IO a
withTemporaryFile k =
    withSystemTempFile "grapesy-test-suite.txt" (\fp h -> hClose h >> k fp)