diff --git a/sandwich-hedgehog/package.yaml b/sandwich-hedgehog/package.yaml index 8815eeb..1def644 100644 --- a/sandwich-hedgehog/package.yaml +++ b/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 diff --git a/sandwich-hedgehog/sandwich-hedgehog.cabal b/sandwich-hedgehog/sandwich-hedgehog.cabal index 437ca5f..05dae7a 100644 --- a/sandwich-hedgehog/sandwich-hedgehog.cabal +++ b/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 diff --git a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs b/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs index 4bc3656..519bd45 100644 --- a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs +++ b/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 diff --git a/sandwich-quickcheck/package.yaml b/sandwich-quickcheck/package.yaml index 4102926..3913a51 100644 --- a/sandwich-quickcheck/package.yaml +++ b/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 diff --git a/sandwich-quickcheck/sandwich-quickcheck.cabal b/sandwich-quickcheck/sandwich-quickcheck.cabal index a674305..b2f60f2 100644 --- a/sandwich-quickcheck/sandwich-quickcheck.cabal +++ b/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 diff --git a/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs b/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs index c47f094..240f123 100644 --- a/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs +++ b/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 diff --git a/sandwich-slack/package.yaml b/sandwich-slack/package.yaml index de1b9da..1afc43a 100644 --- a/sandwich-slack/package.yaml +++ b/sandwich-slack/package.yaml @@ -23,12 +23,12 @@ dependencies: - monad-logger - mtl - safe -- safe-exceptions - sandwich - stm - string-interpolate - text - time +- unliftio - vector - wreq diff --git a/sandwich-slack/sandwich-slack.cabal b/sandwich-slack/sandwich-slack.cabal index f79718f..b8043aa 100644 --- a/sandwich-slack/sandwich-slack.cabal +++ b/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 diff --git a/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs b/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs index 90335bd..3de99ec 100644 --- a/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs +++ b/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) diff --git a/sandwich-webdriver/package.yaml b/sandwich-webdriver/package.yaml index 57e9320..c97462c 100644 --- a/sandwich-webdriver/package.yaml +++ b/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 diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal index ecae2a7..d45d371 100644 --- a/sandwich-webdriver/sandwich-webdriver.cabal +++ b/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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs index 663228b..c59ca7c 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs +++ b/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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs index dfcb5fe..9e8a96d 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs +++ b/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 - , MonadBaseControl IO m - , MonadMask m + , MonadUnliftIO 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) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs index 5f999e2..aacbe08 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs +++ b/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|]) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index c022fe3..83a4626 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs index 777a49b..0959ba4 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs +++ b/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) - (\(e :: E.SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|]) + tryTruncateFile path = catch (truncateFile path) + (\(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 = E.handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e) +leftOnException :: (MonadUnliftIO m) => m (Either T.Text a) -> m (Either T.Text a) +leftOnException = handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e) -leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a) -leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e) +leftOnException' :: (MonadUnliftIO m) => m a -> m (Either T.Text a) +leftOnException' action = catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e) -- * Util diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs index 74a81fd..fa8aef1 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs +++ b/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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs index 22d5b67..d7dd13e 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs +++ b/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 :: ( diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs index 0939fee..4be13a0 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs +++ b/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. diff --git a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs b/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs index b88e5c0..0568159 100644 --- a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +++ b/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)]) diff --git a/sandwich/app/Main.hs b/sandwich/app/Main.hs index dd3474c..45a2147 100644 --- a/sandwich/app/Main.hs +++ b/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(..)) diff --git a/sandwich/package.yaml b/sandwich/package.yaml index c046201..c01107a 100644 --- a/sandwich/package.yaml +++ b/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 diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal index 39bab2e..e0c95be 100644 --- a/sandwich/sandwich.cabal +++ b/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 diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index 7eb7b5f..5e1ebdf 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Expectations.hs b/sandwich/src/Test/Sandwich/Expectations.hs index 2cba948..98c4a52 100644 --- a/sandwich/src/Test/Sandwich/Expectations.hs +++ b/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) diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/FailureReason.hs b/sandwich/src/Test/Sandwich/Formatters/Print/FailureReason.hs index 23acc1c..9a9a362 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/FailureReason.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs index c4b82ca..5188499 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs +++ b/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) diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs index 48e31af..d0f0590 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Golden.hs b/sandwich/src/Test/Sandwich/Golden.hs index a239d95..5867b2d 100644 --- a/sandwich/src/Test/Sandwich/Golden.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Golden/Update.hs b/sandwich/src/Test/Sandwich/Golden/Update.hs index 6cd4b4e..28de00e 100644 --- a/sandwich/src/Test/Sandwich/Golden/Update.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index fda258e..1f521b6 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Logging.hs b/sandwich/src/Test/Sandwich/Logging.hs index fe3202f..5438cb7 100644 --- a/sandwich/src/Test/Sandwich/Logging.hs +++ b/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 $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle." + (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin 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 diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 7507de6..644518a 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index dbb629b..a5b472f 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/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 diff --git a/sandwich/src/Test/Sandwich/Types/Spec.hs b/sandwich/src/Test/Sandwich/Types/Spec.hs index de6e7f0..697207b 100644 --- a/sandwich/src/Test/Sandwich/Types/Spec.hs +++ b/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) diff --git a/sandwich/test/Around.hs b/sandwich/test/Around.hs index e91bb36..110ec06 100644 --- a/sandwich/test/Around.hs +++ b/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 diff --git a/sandwich/test/Before.hs b/sandwich/test/Before.hs index 4084a3e..996f46f 100644 --- a/sandwich/test/Before.hs +++ b/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 diff --git a/sandwich/test/Describe.hs b/sandwich/test/Describe.hs index e63e809..96cb7d3 100644 --- a/sandwich/test/Describe.hs +++ b/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 diff --git a/sandwich/test/Introduce.hs b/sandwich/test/Introduce.hs index dcf0143..762cce6 100644 --- a/sandwich/test/Introduce.hs +++ b/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 diff --git a/sandwich/test/TestUtil.hs b/sandwich/test/TestUtil.hs index cd40cdc..7e94874 100644 --- a/sandwich/test/TestUtil.hs +++ b/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