Halfway through unliftio switch

sandwich-hedgehog/package.yaml

@@ -19,11 +19,11 @@ dependencies:
 - hedgehog
 - monad-control
 - mtl
-- safe-exceptions
 - sandwich >= 0.1.0.4
 - string-interpolate
 - text
 - time
+- unliftio
 - wl-pprint-annotated
 - vty
 

sandwich-hedgehog/sandwich-hedgehog.cabal

@@ -47,11 +47,11 @@ library
     , hedgehog
     , monad-control
     , mtl
-    , safe-exceptions
     , sandwich >=0.1.0.4
     , string-interpolate
     , text
     , time
+    , unliftio
     , vty
     , wl-pprint-annotated
   default-language: Haskell2010
@@ -79,11 +79,11 @@ test-suite sandwich-hedgehog-test
     , hedgehog
     , monad-control
     , mtl
-    , safe-exceptions
     , sandwich >=0.1.0.4
     , string-interpolate
     , text
     , time
+    , unliftio
     , vty
     , wl-pprint-annotated
   default-language: Haskell2010

sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs

@@ -56,7 +56,7 @@ module Test.Sandwich.Hedgehog (
   ) where
 
 import Control.Applicative
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.Free
 import Control.Monad.IO.Class
 import Control.Monad.Reader

sandwich-quickcheck/package.yaml

@@ -19,10 +19,10 @@ dependencies:
 - monad-control
 - mtl
 - QuickCheck
-- safe-exceptions
 - sandwich >= 0.1.0.4
 - text
 - time
+- unliftio
 
 default-extensions:
 - OverloadedStrings

sandwich-quickcheck/sandwich-quickcheck.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 496ab214547ab49a21ff2bed85694f6d3b52326cdd719476fd8f526488cae467
+-- hash: 6f60d0ac0ceda196b8e70c79a5da77af10c4d52a9cba4791ffb053f667b9600f
 
 name:           sandwich-quickcheck
 version:        0.1.0.7
@@ -48,10 +48,10 @@ library
     , free
     , monad-control
     , mtl
-    , safe-exceptions
     , sandwich >=0.1.0.4
     , text
     , time
+    , unliftio
   default-language: Haskell2010
 
 test-suite sandwich-quickcheck-test
@@ -77,8 +77,8 @@ test-suite sandwich-quickcheck-test
     , free
     , monad-control
     , mtl
-    , safe-exceptions
     , sandwich >=0.1.0.4
     , text
     , time
+    , unliftio
   default-language: Haskell2010

sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs

@@ -32,7 +32,7 @@ module Test.Sandwich.QuickCheck (
   , modifyMaxShrinks
   ) where
 
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.Free
 import Control.Monad.IO.Class
 import Control.Monad.Reader

sandwich-slack/package.yaml

@@ -23,12 +23,12 @@ dependencies:
 - monad-logger
 - mtl
 - safe
-- safe-exceptions
 - sandwich
 - stm
 - string-interpolate
 - text
 - time
+- unliftio
 - vector
 - wreq
 

sandwich-slack/sandwich-slack.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6138f55d728f79ee3b7afe065d16ee37a3b075445596cb82a236df8f0e23bf47
+-- hash: edb46ab628d2fbd67e7d2aaf706c9613379157b0dc955e7dc14e7793778b163e
 
 name:           sandwich-slack
 version:        0.1.2.0
@@ -60,12 +60,12 @@ library
     , monad-logger
     , mtl
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
     , text
     , time
+    , unliftio
     , vector
     , wreq
   default-language: Haskell2010
@@ -98,13 +98,13 @@ executable sandwich-slack-exe
     , monad-logger
     , mtl
     , safe
-    , safe-exceptions
     , sandwich
     , sandwich-slack
     , stm
     , string-interpolate
     , text
     , time
+    , unliftio
     , vector
     , wreq
   default-language: Haskell2010
@@ -138,12 +138,12 @@ test-suite sandwich-slack-test
     , monad-logger
     , mtl
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
     , text
     , time
+    , unliftio
     , vector
     , wreq
   default-language: Haskell2010

sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs

@@ -30,7 +30,7 @@ module Test.Sandwich.Formatters.Slack (
 import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger hiding (logError)

sandwich-webdriver/package.yaml

@@ -25,7 +25,6 @@ dependencies:
 - http-client
 - http-client-tls
 - http-conduit
-- lifted-base
 - microlens
 - microlens-aeson
 - monad-control
@@ -36,13 +35,13 @@ dependencies:
 - random
 - retry
 - safe
-- safe-exceptions
 - sandwich >= 0.1.0.3
 - string-interpolate
 - temporary
 - text
 - time
 - transformers
+- unliftio
 - unordered-containers
 - vector
 - webdriver

sandwich-webdriver/sandwich-webdriver.cabal

@@ -74,7 +74,6 @@ library
     , http-client
     , http-client-tls
     , http-conduit
-    , lifted-base
     , microlens
     , microlens-aeson
     , monad-control
@@ -85,13 +84,13 @@ library
     , random
     , retry
     , safe
-    , safe-exceptions
     , sandwich >=0.1.0.3
     , string-interpolate
     , temporary
     , text
     , time
     , transformers
+    , unliftio
     , unordered-containers
     , vector
     , webdriver
@@ -151,7 +150,6 @@ executable sandwich-webdriver-exe
     , http-client
     , http-client-tls
     , http-conduit
-    , lifted-base
     , microlens
     , microlens-aeson
     , monad-control
@@ -162,7 +160,6 @@ executable sandwich-webdriver-exe
     , random
     , retry
     , safe
-    , safe-exceptions
     , sandwich >=0.1.0.3
     , sandwich-webdriver
     , string-interpolate
@@ -170,6 +167,7 @@ executable sandwich-webdriver-exe
     , text
     , time
     , transformers
+    , unliftio
     , unordered-containers
     , vector
     , webdriver
@@ -230,7 +228,6 @@ test-suite sandwich-webdriver-test
     , http-client
     , http-client-tls
     , http-conduit
-    , lifted-base
     , microlens
     , microlens-aeson
     , monad-control
@@ -241,7 +238,6 @@ test-suite sandwich-webdriver-test
     , random
     , retry
     , safe
-    , safe-exceptions
     , sandwich >=0.1.0.3
     , sandwich-webdriver
     , string-interpolate

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs

@@ -2,10 +2,10 @@
 
 module Test.Sandwich.WebDriver.Internal.Action where
 
-import Control.Concurrent.MVar.Lifted
-import Control.Exception.Safe
 import Control.Monad
+import Control.Monad.Catch (MonadCatch)
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
@@ -16,10 +16,12 @@ import Test.Sandwich
 import Test.Sandwich.WebDriver.Internal.Types
 import Test.Sandwich.WebDriver.Internal.Util
 import qualified Test.WebDriver as W
+import UnliftIO.Concurrent
+import UnliftIO.Exception
 
 
 -- | Close the given sessions
-closeSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Session -> WebDriver -> m ()
+closeSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => Session -> WebDriver -> m ()
 closeSession session (WebDriver {wdSessionMap}) = do
   toClose <- modifyMVar wdSessionMap $ \sessionMap ->
     case M.lookup session sessionMap of
@@ -29,7 +31,7 @@ closeSession session (WebDriver {wdSessionMap}) = do
   whenJust toClose $ \sess -> liftIO $ W.runWD sess W.closeSession
 
 -- | Close all sessions except those listed
-closeAllSessionsExcept :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => [Session] -> WebDriver -> m ()
+closeAllSessionsExcept :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => [Session] -> WebDriver -> m ()
 closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do
   toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep)
 
@@ -38,11 +40,11 @@ closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do
           (\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|])
 
 -- | Close all sessions
-closeAllSessions :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => WebDriver -> m ()
+closeAllSessions :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => WebDriver -> m ()
 closeAllSessions = closeAllSessionsExcept []
 
 -- | Close the current session
-closeCurrentSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m ()
+closeCurrentSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m ()
 closeCurrentSession = do
   webDriver <- getContext webdriver
   (session, _) <- getContext webdriverSession

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs

@@ -14,6 +14,7 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Monad.Trans.Except
@@ -23,7 +24,6 @@ import GHC.Stack
 import System.Directory
 import System.Exit
 import System.FilePath
-import System.IO.Temp
 import System.Process
 import Test.Sandwich.Expectations
 import Test.Sandwich.Logging
@@ -32,14 +32,13 @@ import Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox
 import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
 import Test.Sandwich.WebDriver.Internal.Types
 import Test.Sandwich.WebDriver.Internal.Util
+import UnliftIO.Temporary
 
 
 type Constraints m = (
   HasCallStack
   , MonadLogger m
-  , MonadIO m
+  , MonadUnliftIO m
-  , MonadBaseControl IO m
-  , MonadMask m
   )
 
 -- * Obtaining binaries
@@ -51,7 +50,7 @@ defaultSeleniumJarUrl = "https://selenium-release.storage.googleapis.com/3.141/s
 
 -- | Manually obtain a Selenium server JAR file, according to the 'SeleniumToUse' policy,
 -- storing it under the provided 'FilePath' if necessary and returning the exact path.
-obtainSelenium :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)
+obtainSelenium :: (MonadUnliftIO m, MonadLogger m) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)
 obtainSelenium toolsDir (DownloadSeleniumFrom url) = do
   let path = [i|#{toolsDir}/selenium-server-standalone.jar|]
   unlessM (liftIO $ doesFileExist path) $
@@ -69,7 +68,7 @@ obtainSelenium _ (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case
 -- | Manually obtain a chromedriver binary, according to the 'ChromeDriverToUse' policy,
 -- storing it under the provided 'FilePath' if necessary and returning the exact path.
 obtainChromeDriver :: (
-  MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadMask m
+  MonadUnliftIO m, MonadLogger m
   ) => FilePath -> ChromeDriverToUse -> m (Either T.Text FilePath)
 obtainChromeDriver toolsDir (DownloadChromeDriverFrom url) = do
   let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]
@@ -93,7 +92,7 @@ obtainChromeDriver _ (UseChromeDriverAt path) = liftIO (doesFileExist path) >>=
 
 -- | Manually obtain a geckodriver binary, according to the 'GeckoDriverToUse' policy,
 -- storing it under the provided 'FilePath' if necessary and returning the exact path.
-obtainGeckoDriver :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)
+obtainGeckoDriver :: (MonadUnliftIO m, MonadLogger m) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)
 obtainGeckoDriver toolsDir (DownloadGeckoDriverFrom url) = do
   let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]
   unlessM (liftIO $ doesFileExist path) $
@@ -160,7 +159,7 @@ geckoDriverExecutable = case detectPlatform of
   Windows -> "geckodriver.exe"
   _ -> "geckodriver"
 
-downloadAndUnzipToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadMask m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
@@ -180,7 +179,7 @@ downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
           >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
       xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
 
-downloadAndUntarballToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadThrow m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
@@ -189,7 +188,7 @@ downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
     >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
 
-curlDownloadToPath :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => String -> FilePath -> m ()
+curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m ()
 curlDownloadToPath downloadPath localPath = do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs

@@ -1,12 +1,14 @@
-{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
--- |
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Sandwich.WebDriver.Internal.Screenshots where
 
 import Control.Concurrent
-import Control.Exception.Lifted
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import qualified Data.Map as M
 import Data.String.Interpolate
 import qualified Data.Text as T
@@ -15,13 +17,14 @@ import Network.HTTP.Client
 import System.FilePath
 import Test.Sandwich.WebDriver.Internal.Types
 import Test.WebDriver
+import UnliftIO.Exception
 
 saveScreenshots :: (HasCallStack) => T.Text -> WebDriver -> FilePath -> IO ()
 saveScreenshots screenshotName (WebDriver {..}) resultsDir = do
   -- For every session, and for every window, try to get a screenshot for the results dir
   sessionMap <- readMVar wdSessionMap
-  forM_ (M.toList sessionMap) $ \(browser, sess) -> runWD sess $
+  forM_ (M.toList sessionMap) $ \(browser, sess) ->
     handle (\(e :: HttpException) -> case e of
                (HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|]
                e -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e}'|])
-           (saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])
+           (runWD sess $ saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs

@@ -1,19 +1,18 @@
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Test.Sandwich.WebDriver.Internal.StartWebDriver where
 
 import Control.Concurrent
-import Control.Exception
 import Control.Monad
 import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Retry
 import qualified Data.Aeson as A
 import Data.Default
@@ -40,6 +39,7 @@ import Test.Sandwich.WebDriver.Internal.Types
 import Test.Sandwich.WebDriver.Internal.Util
 import qualified Test.WebDriver as W
 import qualified Test.WebDriver.Firefox.Profile as FF
+import UnliftIO.Exception
 
 #ifndef mingw32_HOST_OS
 import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
@@ -57,7 +57,7 @@ fromText = id
 #endif
 
 
-type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)
+type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)
 
 -- | Spin up a Selenium WebDriver and create a WebDriver
 startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs

@@ -2,16 +2,16 @@
 
 module Test.Sandwich.WebDriver.Internal.Util where
 
-import Control.Exception
-import qualified Control.Exception.Lifted as E
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.String.Interpolate
 import qualified Data.Text as T
 import System.Directory
 import System.Process
 import qualified System.Random as R
+import UnliftIO.Exception
 
 #ifdef mingw32_HOST_OS
 import System.IO
@@ -29,8 +29,8 @@ moveAndTruncate from to = do
 
   where
     tryTruncateFile :: FilePath -> IO ()
-    tryTruncateFile path = E.catch (truncateFile path)
+    tryTruncateFile path = catch (truncateFile path)
-                                   (\(e :: E.SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])
+                                 (\(e :: SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])
 
     truncateFile :: FilePath -> IO ()
 #ifdef mingw32_HOST_OS
@@ -41,11 +41,11 @@ moveAndTruncate from to = do
 
 -- * Exceptions
 
-leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a)
+leftOnException :: (MonadUnliftIO m) => m (Either T.Text a) -> m (Either T.Text a)
-leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
+leftOnException = handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
 
-leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a)
+leftOnException' :: (MonadUnliftIO m) => m a -> m (Either T.Text a)
-leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
+leftOnException' action = catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
 
 -- * Util
 

sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs

@@ -23,7 +23,7 @@ module Test.Sandwich.WebDriver.Types (
   , WebDriverSessionMonad
   ) where
 
-import Control.Exception.Safe as ES
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
@@ -35,6 +35,7 @@ import Test.Sandwich.WebDriver.Internal.Types
 import qualified Test.WebDriver.Class as W
 import qualified Test.WebDriver.Internal as WI
 import qualified Test.WebDriver.Session as W
+import UnliftIO.Exception as ES
 
 
 type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context

sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs

@@ -18,11 +18,9 @@ module Test.Sandwich.WebDriver.Video (
   , defaultGdigrabOptions
   ) where
 
-import Control.Exception.Safe
 import Control.Monad.IO.Class
 import Control.Monad.Logger hiding (logError)
 import Control.Monad.Reader
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.String.Interpolate
 import System.Exit
 import System.FilePath
@@ -35,9 +33,10 @@ import Test.Sandwich.WebDriver.Internal.Video
 import Test.Sandwich.WebDriver.Windows
 import Test.WebDriver.Class as W
 import Test.WebDriver.Commands
+import UnliftIO.Exception
 
 
-type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context, MonadBaseControl IO m)
+type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context)
 
 -- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
 startFullScreenVideoRecording :: (

sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs

@@ -11,7 +11,7 @@ module Test.Sandwich.WebDriver.Windows (
   , getScreenResolution
   ) where
 
-import Control.Exception.Safe
+import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
 import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Reader
@@ -23,6 +23,7 @@ import Test.Sandwich.WebDriver.Internal.Types
 import Test.Sandwich.WebDriver.Resolution
 import Test.WebDriver
 import qualified Test.WebDriver.Class as W
+import UnliftIO.Exception
 
 
 -- | Position the window on the left 50% of the screen.

sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs

@@ -11,6 +11,7 @@ module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (
 import Control.Exception
 import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Retry
@@ -39,7 +40,7 @@ newtype Fd = Fd FD
 handleToFd h = Fd <$> HFD.handleToFd h
 #endif
 
-type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)
+type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)
 
 
 makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])

sandwich/app/Main.hs

@@ -5,7 +5,7 @@
 module Main where
 
 import Control.Concurrent
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger (LogLevel(..))

sandwich/package.yaml

@@ -39,7 +39,6 @@ dependencies:
 - exceptions
 - filepath
 - free
-- lifted-async
 - microlens
 - microlens-th
 - monad-control
@@ -50,13 +49,13 @@ dependencies:
 - process
 - retry
 - safe
-- safe-exceptions
 - stm
 - string-interpolate
 - text
 - time
 - transformers
 - transformers-base
+- unliftio
 - unliftio-core
 - vector
 - vty >= 6

sandwich/sandwich.cabal

@@ -123,7 +123,6 @@ library
     , filepath
     , free
     , haskell-src-exts
-    , lifted-async
     , microlens
     , microlens-th
     , monad-control
@@ -134,7 +133,6 @@ library
     , process
     , retry
     , safe
-    , safe-exceptions
     , stm
     , string-interpolate
     , template-haskell
@@ -142,6 +140,7 @@ library
     , time
     , transformers
     , transformers-base
+    , unliftio
     , unliftio-core
     , vector
     , vty >=6
@@ -187,7 +186,6 @@ executable sandwich-demo
     , filepath
     , free
     , haskell-src-exts
-    , lifted-async
     , microlens
     , microlens-th
     , monad-control
@@ -198,7 +196,6 @@ executable sandwich-demo
     , process
     , retry
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
@@ -207,6 +204,7 @@ executable sandwich-demo
     , time
     , transformers
     , transformers-base
+    , unliftio
     , unliftio-core
     , vector
     , vty >=6
@@ -249,7 +247,6 @@ executable sandwich-discover
     , filepath
     , free
     , haskell-src-exts
-    , lifted-async
     , microlens
     , microlens-th
     , monad-control
@@ -260,7 +257,6 @@ executable sandwich-discover
     , process
     , retry
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
@@ -269,6 +265,7 @@ executable sandwich-discover
     , time
     , transformers
     , transformers-base
+    , unliftio
     , unliftio-core
     , vector
     , vty >=6
@@ -316,7 +313,6 @@ executable sandwich-test
     , filepath
     , free
     , haskell-src-exts
-    , lifted-async
     , microlens
     , microlens-th
     , monad-control
@@ -327,7 +323,6 @@ executable sandwich-test
     , process
     , retry
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
@@ -336,6 +331,7 @@ executable sandwich-test
     , time
     , transformers
     , transformers-base
+    , unliftio
     , unliftio-core
     , vector
     , vty >=6
@@ -384,7 +380,6 @@ test-suite sandwich-test-suite
     , filepath
     , free
     , haskell-src-exts
-    , lifted-async
     , microlens
     , microlens-th
     , monad-control
@@ -395,7 +390,6 @@ test-suite sandwich-test-suite
     , process
     , retry
     , safe
-    , safe-exceptions
     , sandwich
     , stm
     , string-interpolate
@@ -404,6 +398,7 @@ test-suite sandwich-test-suite
     , time
     , transformers
     , transformers-base
+    , unliftio
     , unliftio-core
     , vector
     , vty >=6

sandwich/src/Test/Sandwich.hs

@@ -67,7 +67,7 @@ module Test.Sandwich (
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import qualified Control.Exception as E
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.Free
 import Control.Monad.IO.Class

sandwich/src/Test/Sandwich/Expectations.hs

@@ -4,42 +4,44 @@
 
 module Test.Sandwich.Expectations where
 
-import Control.Exception.Safe
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import qualified Data.List as L
 import Data.String.Interpolate
 import qualified Data.Text as T
 import GHC.Stack
 import Test.Sandwich.Types.Spec
+import UnliftIO.Exception
 
 -- * Manually fail a test or mark as pending
 
 -- | General-purpose function to throw a test exception with a 'String'.
-expectationFailure :: (HasCallStack, MonadThrow m) => String -> m a
+expectationFailure :: (HasCallStack, MonadIO m) => String -> m a
 expectationFailure = throwIO . Reason (Just callStack)
 
 -- | Throws a 'Pending' exception, which will cause the test to be marked as pending.
-pending :: (HasCallStack, MonadThrow m) => m a
+pending :: (HasCallStack, MonadIO m) => m a
 pending = throwIO $ Pending (Just callStack) Nothing
 
 -- | Throws a 'Pending' exception with a message to add additional details.
-pendingWith :: (HasCallStack, MonadThrow m) => String -> m a
+pendingWith :: (HasCallStack, MonadIO m) => String -> m a
 pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)
 
 -- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.
-xit :: (HasCallStack, MonadThrow m) => String -> ExampleT context m1 () -> SpecFree context m ()
+xit :: (HasCallStack, MonadIO m) => String -> ExampleT context m1 () -> SpecFree context m ()
 xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)
 
 -- * Expecting failures
 
 -- | Assert that a given action should fail with some 'FailureReason'.
-shouldFail :: (HasCallStack, MonadCatch m) => m () -> m ()
+shouldFail :: (HasCallStack, MonadUnliftIO m) => m () -> m ()
 shouldFail action = do
   try action >>= \case
     Left (_ :: FailureReason) -> return ()
     Right () -> expectationFailure [i|Expected test to fail|]
 
 -- | Assert that a given action should fail with some 'FailureReason' matching a predicate.
-shouldFailPredicate :: (HasCallStack, MonadCatch m) => (FailureReason -> Bool) -> m () -> m ()
+shouldFailPredicate :: (HasCallStack, MonadUnliftIO m) => (FailureReason -> Bool) -> m () -> m ()
 shouldFailPredicate p action = do
   try action >>= \case
     Left (err :: FailureReason) -> case p err of
@@ -48,7 +50,7 @@ shouldFailPredicate p action = do
     Right () -> expectationFailure [i|Expected test to fail, but it succeeded|]
 
 -- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.
-shouldThrow :: (HasCallStack, MonadCatch m, Exception e) =>
+shouldThrow :: (HasCallStack, MonadUnliftIO m, Exception e) =>
   m a
   -- ^ The action to run.
   -> (e -> Bool)
@@ -63,65 +65,65 @@ shouldThrow action f = do
 -- * Assertions
 
 -- | Asserts that two things are equal.
-shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
+shouldBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m ()
 shouldBe x y
   | x == y = return ()
   | otherwise = throwIO (ExpectedButGot (Just callStack) (SEB y) (SEB x))
 
 -- | Asserts that two things are not equal.
-shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
+shouldNotBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m ()
 shouldNotBe x y
   | x /= y = return ()
   | otherwise = throwIO (DidNotExpectButGot (Just callStack) (SEB y))
 
 -- | Asserts that the given list contains a subsequence.
-shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
+shouldContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m ()
 shouldContain haystack needle = case needle `L.isInfixOf` haystack of
   True -> return ()
   False -> expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type
 
 -- | Asserts that the given list contains an item matching a predicate.
-shouldContainPredicate :: (HasCallStack, MonadThrow m, Show a) => [a] -> (a -> Bool) -> m ()
+shouldContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()
 shouldContainPredicate haystack p = case L.find p haystack of
   Just _ -> return ()
   Nothing -> expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]
 
 -- | Asserts that the given list does not contain a subsequence.
-shouldNotContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
+shouldNotContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m ()
 shouldNotContain haystack needle = case needle `L.isInfixOf` haystack of
   True -> expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]
   False -> return ()
 
 -- | Asserts that the given list contains an item matching a predicate.
-shouldNotContainPredicate :: (HasCallStack, MonadThrow m, Show a) => [a] -> (a -> Bool) -> m ()
+shouldNotContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()
 shouldNotContainPredicate haystack p = case L.find p haystack of
   Nothing -> return ()
   Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]
 
 -- | Asserts that the given 'Maybe' is 'Nothing'.
-shouldBeNothing :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()
+shouldBeNothing :: (HasCallStack, MonadIO m, Show a) => Maybe a -> m ()
 shouldBeNothing Nothing = return ()
 shouldBeNothing x = expectationFailure [i|Expected Nothing but got #{x}|]
 
 -- | Asserts that the given 'Maybe' is 'Just'.
-shouldBeJust :: (HasCallStack, MonadThrow m) => Maybe a -> m ()
+shouldBeJust :: (HasCallStack, MonadIO m) => Maybe a -> m ()
 shouldBeJust (Just _) = return ()
 shouldBeJust Nothing = expectationFailure [i|Expected Just but got Nothing.|]
 
 -- | Asserts that the given 'Either' is 'Left'.
-shouldBeLeft :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()
+shouldBeLeft :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m ()
 shouldBeLeft (Left _) = return ()
 shouldBeLeft x = expectationFailure [i|Expected Left but got #{x}|]
 
 -- | Asserts that the given 'Either' is 'Right'.
-shouldBeRight :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()
+shouldBeRight :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m ()
 shouldBeRight (Right _) = return ()
 shouldBeRight x = expectationFailure [i|Expected Right but got #{x}.|]
 
 -- | Asserts that the given text contains a substring.
-textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
+textShouldContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m ()
 t `textShouldContain` txt = ((T.unpack t) :: String) `shouldContain` (T.unpack txt)
 
 -- | Asserts that the given text does not contain a substring.
-textShouldNotContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
+textShouldNotContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m ()
 t `textShouldNotContain` txt = ((T.unpack t) :: String) `shouldNotContain` (T.unpack txt)

sandwich/src/Test/Sandwich/Formatters/Print/FailureReason.hs

@@ -6,7 +6,7 @@ module Test.Sandwich.Formatters.Print.FailureReason (
   printFailureReason
   ) where
 
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.Reader
 import qualified Data.List as L
 import Data.String.Interpolate

sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs

@@ -31,7 +31,7 @@ import Brick.Widgets.List
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Concurrent.STM
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger hiding (logError)

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs

@@ -5,7 +5,7 @@ module Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget where
 
 import Brick
 import Brick.Widgets.Border
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.Reader
 import qualified Data.List as L
 import Data.Maybe

sandwich/src/Test/Sandwich/Golden.hs

@@ -22,7 +22,6 @@ module Test.Sandwich.Golden (
   , goldenFailFirstTime
   ) where
 
-import Control.Exception.Safe
 import Control.Monad
 import Control.Monad.Free
 import Control.Monad.IO.Class
@@ -37,6 +36,7 @@ import System.FilePath
 import Test.Sandwich
 import Test.Sandwich.Golden.Update
 import Test.Sandwich.Types.Spec
+import UnliftIO.Exception
 
 
 data Golden a = Golden {
@@ -90,7 +90,7 @@ goldenShowable = mkGolden (\f x -> writeFile f (show x)) ((read <$>) . readFile)
 
 -- | Runs a Golden test.
 
-golden :: (MonadIO m, MonadThrow m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()
+golden :: (MonadIO m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()
 golden (Golden {..}) = it goldenName $ do
   let goldenTestDir = takeDirectory goldenFile
   liftIO $ createDirectoryIfMissing True goldenTestDir

sandwich/src/Test/Sandwich/Golden/Update.hs

@@ -6,13 +6,13 @@ module Test.Sandwich.Golden.Update (
   , defaultDirGoldenTest
   ) where
 
-import Control.Exception.Safe
 import Control.Monad
 import Data.Maybe
 import Data.String.Interpolate
 import System.Console.ANSI
 import System.Directory
 import System.Environment
+import UnliftIO.Exception
 
 
 defaultDirGoldenTest :: FilePath

sandwich/src/Test/Sandwich/Interpreters/StartTree.hs

@@ -11,7 +11,7 @@ module Test.Sandwich.Interpreters.StartTree (
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
 import Control.Concurrent.STM
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger

sandwich/src/Test/Sandwich/Logging.hs

@@ -22,14 +22,12 @@ module Test.Sandwich.Logging (
   ) where
 
 import Control.Concurrent
-import Control.Concurrent.Async.Lifted hiding (wait)
 import Control.DeepSeq (rnf)
 import qualified Control.Exception as C
-import Control.Exception.Safe
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logOther)
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.String.Interpolate
 import Data.Text
 import Foreign.C.Error
@@ -38,6 +36,8 @@ import GHC.Stack
 import System.IO
 import System.IO.Error (mkIOError)
 import System.Process
+import UnliftIO.Async hiding (wait)
+import UnliftIO.Exception
 
 #if !MIN_VERSION_base(4,13,0)
 import Control.Monad.Fail
@@ -74,11 +74,11 @@ logOther = logOtherCS callStack
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle
+createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> m ProcessHandle
 createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
 createProcessWithLogging' logLevel cp = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -95,11 +95,11 @@ createProcessWithLogging' logLevel cp = do
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
 -- Every line output by the process will be fed to a 'debug' call.
-readCreateProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String
+readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> String -> m String
 readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
-readCreateProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
+readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
 readCreateProcessWithLogging' logLevel cp input = do
   (hReadErr, hWriteErr) <- liftIO createPipe
 
@@ -131,8 +131,8 @@ readCreateProcessWithLogging' logLevel cp input = do
         -- wait on the process
         ex <- waitForProcess p
         return (ex, output)
-      (Nothing, _) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
+      (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
-      (_, Nothing) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
+      (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
 
   case ex of
     ExitSuccess -> return output
@@ -149,11 +149,11 @@ readCreateProcessWithLogging' logLevel cp input = do
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLoggingAndStdin :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
 createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLoggingAndStdin' :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
 createProcessWithLoggingAndStdin' logLevel cp input = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -179,11 +179,11 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
   return p
 
 -- | Higher level version of 'createProcessWithLogging', accepting a shell command.
-callCommandWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
+callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()
 callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
 
 -- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
-callCommandWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
+callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
 callCommandWithLogging' logLevel cmd = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -199,7 +199,7 @@ callCommandWithLogging' logLevel cmd = do
 
   liftIO (waitForProcess p) >>= \case
     ExitSuccess -> return ()
-    ExitFailure r -> liftIO $ throw $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
+    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
 
 
 -- * Util

sandwich/src/Test/Sandwich/ParallelN.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- | Wrapper around 'parallel' for limiting the threads using a semaphore.
 
@@ -20,24 +20,25 @@ module Test.Sandwich.ParallelN (
   ) where
 
 import Control.Concurrent.QSem
-import Control.Exception.Safe
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Test.Sandwich.Contexts
 import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
+import UnliftIO.Exception
 
 
 
 -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads.
 parallelN :: (
-  MonadIO m, MonadMask m
+  MonadUnliftIO m
   ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelN = parallelN' defaultParallelNodeOptions
 
 parallelN' :: (
-  MonadIO m, MonadMask m
+  MonadUnliftIO m
   ) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $
   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
@@ -47,12 +48,12 @@ parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" par
 
 -- | Same as 'parallelN', but extracts the semaphore size from the command line options.
 parallelNFromArgs :: forall context a m. (
-  MonadIO m, MonadMask m, HasCommandLineOptions context a
+  MonadUnliftIO m, HasCommandLineOptions context a
   ) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions
 
 parallelNFromArgs' :: forall context a m. (
-  MonadIO m, MonadMask m, HasCommandLineOptions context a
+  MonadUnliftIO m, HasCommandLineOptions context a
   ) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $
   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children

sandwich/src/Test/Sandwich/TestTimer.hs

@@ -6,8 +6,8 @@
 module Test.Sandwich.TestTimer where
 
 import Control.Concurrent
-import Control.Exception.Safe
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Control.Monad.Trans.State
 import qualified Data.Aeson as A
@@ -26,6 +26,7 @@ import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import Test.Sandwich.Types.TestTimer
 import Test.Sandwich.Util (whenJust)
+import UnliftIO.Exception
 
 
 type EventName = T.Text
@@ -34,14 +35,14 @@ type ProfileName = T.Text
 -- * User functions
 
 -- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.
-timeAction :: (MonadMask m, MonadIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a
+timeAction :: (MonadUnliftIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a
 timeAction eventName action = do
   tt <- asks getTestTimer
   BaseContext {baseContextTestTimerProfile} <- asks getBaseContext
   timeAction' tt baseContextTestTimerProfile eventName action
 
 -- | Time a given action with a given profile name and event name. Use when you want to manually specify the profile name.
-timeActionByProfile :: (MonadMask m, MonadIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a
+timeActionByProfile :: (MonadUnliftIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a
 timeActionByProfile profileName eventName action = do
   tt <- asks getTestTimer
   timeAction' tt profileName eventName action
@@ -81,7 +82,7 @@ finalizeSpeedScopeTestTimer (SpeedScopeTestTimer {..}) = do
   whenJust testTimerHandle hClose
   readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode
 
-timeAction' :: (MonadMask m, MonadIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a
+timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a
 timeAction' NullTestTimer _ _ = id
 timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_
   (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do

sandwich/src/Test/Sandwich/Types/Spec.hs

@@ -20,8 +20,8 @@
 module Test.Sandwich.Types.Spec where
 
 import Control.Applicative
-import Control.Exception.Safe
 import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.Free
 import Control.Monad.Free.TH
 import Control.Monad.IO.Unlift
@@ -37,6 +37,7 @@ import GHC.Stack
 import GHC.TypeLits
 import Graphics.Vty.Image (Image)
 import Safe
+import UnliftIO.Exception
 
 #if !MIN_VERSION_base(4,13,0)
 import Control.Monad.Fail
@@ -70,7 +71,7 @@ instance (MonadBaseControl b m) => MonadBaseControl b (ExampleT context m) where
   liftBaseWith = defaultLiftBaseWith
   restoreM = defaultRestoreM
 
-instance (Monad m, MonadThrow m) => MonadFail (ExampleT context m) where
+instance (MonadIO m) => MonadFail (ExampleT context m) where
   fail :: (HasCallStack) => String -> ExampleT context m a
   fail = throwIO . Reason (Just callStack)
 

sandwich/test/Around.hs

@@ -4,7 +4,7 @@ module Around where
 
 
 import Control.Concurrent
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Writer

sandwich/test/Before.hs

@@ -2,7 +2,7 @@
 
 module Before where
 
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Writer
 import qualified Data.List as L

sandwich/test/Describe.hs

@@ -2,7 +2,7 @@
 
 module Describe where
 
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Writer
 import Data.String.Interpolate

sandwich/test/Introduce.hs

@@ -6,7 +6,7 @@ module Introduce where
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Concurrent.STM
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Writer
 import Data.Foldable

sandwich/test/TestUtil.hs

@@ -3,7 +3,7 @@
 module TestUtil where
 
 import Control.Concurrent.STM
-import Control.Exception.Safe
+import UnliftIO.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Logger
 import Control.Monad.Trans.Writer