Done embracing unliftio

sandwich-hedgehog/package.yaml

@@ -15,6 +15,7 @@ extra-source-files:
 
 dependencies:
 - base < 5
+- exceptions
 - free
 - hedgehog
 - monad-control
@@ -24,6 +25,7 @@ dependencies:
 - text
 - time
 - unliftio
+- unliftio-core
 - wl-pprint-annotated
 - vty
 

sandwich-hedgehog/sandwich-hedgehog.cabal

@@ -43,6 +43,7 @@ library
       LambdaCase
   build-depends:
       base <5
+    , exceptions
     , free
     , hedgehog
     , monad-control
@@ -52,6 +53,7 @@ library
     , text
     , time
     , unliftio
+    , unliftio-core
     , vty
     , wl-pprint-annotated
   default-language: Haskell2010
@@ -75,6 +77,7 @@ test-suite sandwich-hedgehog-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base <5
+    , exceptions
     , free
     , hedgehog
     , monad-control
@@ -84,6 +87,7 @@ test-suite sandwich-hedgehog-test
     , text
     , time
     , unliftio
+    , unliftio-core
     , vty
     , wl-pprint-annotated
   default-language: Haskell2010

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

@@ -56,11 +56,9 @@ module Test.Sandwich.Hedgehog (
   ) where
 
 import Control.Applicative
-import UnliftIO.Exception
+import Control.Monad.Catch (MonadCatch)
 import Control.Monad.Free
 import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe
 import Data.String.Interpolate
 import GHC.Stack
@@ -72,6 +70,7 @@ import Hedgehog.Internal.Runner as HR
 import Hedgehog.Internal.Seed as Seed
 import Test.Sandwich
 import Test.Sandwich.Internal
+import UnliftIO.Exception
 
 #ifndef mingw32_HOST_OS
 import Test.Sandwich.Hedgehog.Render
@@ -97,6 +96,7 @@ data HedgehogParams = HedgehogParams {
 #endif
   } deriving (Show)
 
+defaultHedgehogParams :: HedgehogParams
 defaultHedgehogParams = HedgehogParams {
   hedgehogSize = Nothing
   , hedgehogSeed = Nothing
@@ -111,41 +111,42 @@ defaultHedgehogParams = HedgehogParams {
 
 newtype HedgehogContext = HedgehogContext HedgehogParams
   deriving Show
-hedgehogContext = Label :: Label "hedgehogContext" HedgehogContext
+hedgehogContext :: Label "hedgehogContext" HedgehogContext
+hedgehogContext = Label
 type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext
 
 -- | Same as 'introduceHedgehog'' but with default 'HedgehogParams'.
-introduceHedgehog :: (MonadIO m, MonadBaseControl IO m)
+introduceHedgehog :: (MonadIO m)
   => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
 introduceHedgehog = introduceHedgehog'' "Introduce Hedgehog context" defaultHedgehogParams
 
 -- | Same as 'introduceHedgehog''' but with a default message.
-introduceHedgehog' :: (MonadIO m, MonadBaseControl IO m)
+introduceHedgehog' :: (MonadIO m)
   => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
 introduceHedgehog' = introduceHedgehog'' "Introduce Hedgehog context"
 
 -- | Introduce 'HedgehogParams' with configurable message.
-introduceHedgehog'' :: (MonadIO m, MonadBaseControl IO m)
+introduceHedgehog'' :: (MonadIO m)
   => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
 introduceHedgehog'' msg params = introduce msg hedgehogContext (return $ HedgehogContext params) (const $ return ())
 
 
 -- | Same as 'introduceHedgehogCommandLineOptions'' but with default 'HedgehogParams'.
-introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
 introduceHedgehogCommandLineOptions = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options" defaultHedgehogParams
 
 -- | Same as 'introduceHedgehogCommandLineOptions''' but with a default message.
-introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
 introduceHedgehogCommandLineOptions' = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options"
 
 -- | Introduce 'HedgehogParams' with configurable message, overriding those parameters with any command line options passed.
-introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
-introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext (const $ return ())
+introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext' (const $ return ())
   where
-    getContext = do
+    getContext' = do
       clo <- getCommandLineOptions @a
       return $ HedgehogContext $ addCommandLineOptions clo args
 
@@ -170,7 +171,7 @@ prop msg p = it msg $ do
   let size = fromMaybe 0 hedgehogSize
   seed <- maybe Seed.random return hedgehogSeed
 
-  finalReport <- checkReport config size seed p $ \progressReport@(Report {..}) -> do
+  finalReport <- checkReport config size seed p $ \progressReport@(Report {}) -> do
     -- image <- (return . renderHedgehogToImage) =<< ppProgress Nothing progressReport
 
     progress <- renderProgress DisableColor Nothing progressReport

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

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
 module Test.Sandwich.Hedgehog.Render (
   renderHedgehogToImage
@@ -11,7 +11,7 @@ module Test.Sandwich.Hedgehog.Render (
 import Data.Function
 import qualified Data.List as L
 import qualified Data.Text as T
-import Graphics.Vty.Attributes
+import Graphics.Vty.Attributes hiding (currentAttr)
 import Graphics.Vty.Image
 import Hedgehog.Internal.Report
 import Text.PrettyPrint.Annotated.WL (Doc)
@@ -39,7 +39,7 @@ renderHedgehogToTokens doc =
     joinAdjacentStrings [] = []
 
     splitNewlines :: [Token] -> [Token]
-    splitNewlines ((Str s):xs) = [Str s | s <- parts, s /= ""] <> splitNewlines xs
+    splitNewlines ((Str s):xs) = [Str s' | s' <- parts, s' /= ""] <> splitNewlines xs
       where parts = L.intersperse "\n" $ T.splitOn "\n" s
     splitNewlines (x:xs) = x : splitNewlines xs
     splitNewlines [] = []

sandwich-quickcheck/package.yaml

@@ -23,6 +23,7 @@ dependencies:
 - text
 - time
 - unliftio
+- unliftio-core
 
 default-extensions:
 - OverloadedStrings

sandwich-quickcheck/sandwich-quickcheck.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6f60d0ac0ceda196b8e70c79a5da77af10c4d52a9cba4791ffb053f667b9600f
+-- hash: c5b28ce371e2107a70ce7c86f1dd571d891de77ba47c359fb9de1030286263aa
 
 name:           sandwich-quickcheck
 version:        0.1.0.7
@@ -52,6 +52,7 @@ library
     , text
     , time
     , unliftio
+    , unliftio-core
   default-language: Haskell2010
 
 test-suite sandwich-quickcheck-test
@@ -81,4 +82,5 @@ test-suite sandwich-quickcheck-test
     , text
     , time
     , unliftio
+    , unliftio-core
   default-language: Haskell2010

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

@@ -32,11 +32,9 @@ module Test.Sandwich.QuickCheck (
   , modifyMaxShrinks
   ) where
 
-import UnliftIO.Exception
 import Control.Monad.Free
 import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.IO.Unlift
 import Data.Maybe
 import qualified Data.Text as T
 import GHC.Stack
@@ -44,11 +42,13 @@ import Test.QuickCheck as QC
 import Test.QuickCheck.Random as QC
 import Test.Sandwich
 import Test.Sandwich.Internal
+import UnliftIO.Exception
 
 
 data QuickCheckContext = QuickCheckContext Args
   deriving Show
-quickCheckContext = Label :: Label "quickCheckContext" QuickCheckContext
+quickCheckContext :: Label "quickCheckContext" QuickCheckContext
+quickCheckContext = Label
 type HasQuickCheckContext context = HasLabel context "quickCheckContext" QuickCheckContext
 
 data QuickCheckException = QuickCheckException
@@ -56,43 +56,43 @@ data QuickCheckException = QuickCheckException
 instance Exception QuickCheckException
 
 -- | Same as 'introduceQuickCheck'' but with default args.
-introduceQuickCheck :: (MonadIO m, MonadBaseControl IO m)
+introduceQuickCheck :: (MonadIO m)
   => SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
 introduceQuickCheck = introduceQuickCheck'' "Introduce QuickCheck context" stdArgs
 
 -- | Same as 'introduceQuickCheck''' but with a default message.
-introduceQuickCheck' :: (MonadIO m, MonadBaseControl IO m)
+introduceQuickCheck' :: (MonadIO m)
   => Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
 introduceQuickCheck' = introduceQuickCheck'' "Introduce QuickCheck context"
 
 -- | Introduce QuickCheck args with configurable message.
-introduceQuickCheck'' :: (MonadIO m, MonadBaseControl IO m)
+introduceQuickCheck'' :: (MonadIO m)
   => String -> Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
 introduceQuickCheck'' msg args = introduce msg quickCheckContext (return $ QuickCheckContext args) (const $ return ())
 
 
 -- | Same as 'introduceQuickCheckCommandLineOptions'' but with default args.
-introduceQuickCheckCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceQuickCheckCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
 introduceQuickCheckCommandLineOptions = introduceQuickCheckCommandLineOptions'' @a "Introduce QuickCheck context with command line options" stdArgs
 
 -- | Same as 'introduceQuickCheckCommandLineOptions''' but with a default message.
-introduceQuickCheckCommandLineOptions' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceQuickCheckCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
 introduceQuickCheckCommandLineOptions' = introduceQuickCheckCommandLineOptions'' @a "Introduce QuickCheck context with command line options"
 
 -- | Introduce QuickCheck args with configurable message, overriding those args with any command line options passed.
-introduceQuickCheckCommandLineOptions'' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
+introduceQuickCheckCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
   => String -> Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
-introduceQuickCheckCommandLineOptions'' msg args = introduce msg quickCheckContext getContext (const $ return ())
+introduceQuickCheckCommandLineOptions'' msg args = introduce msg quickCheckContext getContext' (const $ return ())
   where
-    getContext = do
+    getContext' = do
       clo <- getCommandLineOptions @a
       return $ QuickCheckContext $ addCommandLineOptions clo args
 
 
 -- | Similar to 'it'. Runs the given prop with QuickCheck using the currently introduced 'Args'. Throws an appropriate exception on failure.
-prop :: (HasCallStack, HasQuickCheckContext context, MonadIO m, MonadThrow m, Testable prop) => String -> prop -> Free (SpecCommand context m) ()
+prop :: (HasCallStack, HasQuickCheckContext context, MonadUnliftIO m, Testable prop) => String -> prop -> Free (SpecCommand context m) ()
 prop msg p = it msg $ do
   QuickCheckContext args <- getContext quickCheckContext
   liftIO (quickCheckWithResult (args { QC.chatty = False }) p) >>= \case

sandwich-slack/package.yaml

@@ -29,6 +29,7 @@ dependencies:
 - text
 - time
 - unliftio
+- unliftio-core
 - vector
 - wreq
 

sandwich-slack/sandwich-slack.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: edb46ab628d2fbd67e7d2aaf706c9613379157b0dc955e7dc14e7793778b163e
+-- hash: fcdf5ae347bc0a4c0ad7121ecde0a71859cb7369fa2fe48e8e16a82ecc86b628
 
 name:           sandwich-slack
 version:        0.1.2.0
@@ -66,6 +66,7 @@ library
     , text
     , time
     , unliftio
+    , unliftio-core
     , vector
     , wreq
   default-language: Haskell2010
@@ -105,6 +106,7 @@ executable sandwich-slack-exe
     , text
     , time
     , unliftio
+    , unliftio-core
     , vector
     , wreq
   default-language: Haskell2010
@@ -144,6 +146,7 @@ test-suite sandwich-slack-test
     , text
     , time
     , unliftio
+    , unliftio-core
     , vector
     , wreq
   default-language: Haskell2010

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

@@ -30,9 +30,9 @@ module Test.Sandwich.Formatters.Slack (
 import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
-import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logError)
 import qualified Data.Aeson as A
 import Data.Foldable
@@ -50,6 +50,7 @@ import Test.Sandwich.Formatters.Slack.Internal.Markdown
 import Test.Sandwich.Formatters.Slack.Internal.ProgressBar
 import Test.Sandwich.Formatters.Slack.Internal.Types
 import Test.Sandwich.Internal
+import UnliftIO.Exception
 
 
 data SlackFormatter = SlackFormatter {
@@ -121,7 +122,7 @@ addCommandLineOptions (CommandLineOptions {optSlackOptions=(CommandLineSlackOpti
   , slackFormatterMaxMessageSize = optSlackMaxMessageSize <|> slackFormatterMaxMessageSize
   }
 
-runApp :: (MonadIO m, MonadCatch m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
+runApp :: (MonadUnliftIO m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
 runApp sf@(SlackFormatter {..}) rts _bc = do
   startTime <- liftIO getCurrentTime
 
@@ -159,12 +160,13 @@ runApp sf@(SlackFormatter {..}) rts _bc = do
              loop
 
 
+publishTree :: SlackFormatter -> M.Map Int (T.Text, Int) -> NominalDiffTime -> [RunNodeWithStatus context Status l t] -> ProgressBarInfo
 publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi
   where
     pbi = ProgressBarInfo {
       progressBarInfoTopMessage = T.pack <$> (slackFormatterTopMessage sf)
       , progressBarInfoBottomMessage = Just fullBottomMessage
-      , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending + failed) / (fromIntegral total)))
+      , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending' + failed) / (fromIntegral total)))
       , progressBarInfoAttachments = Nothing
       , progressBarInfoBlocks = Just $ case slackFormatterMaxFailures sf of
           Nothing -> mconcat blocks
@@ -179,7 +181,7 @@ publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi
     fullBottomMessage = case runningMessage of
       Nothing -> bottomMessage
       Just t -> T.pack t <> "\n" <> bottomMessage
-    bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|]
+    bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending'} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|]
 
     blocks = catMaybes $ flip concatMap tree $ extractValuesControlRecurse $ \case
       -- Recurse into grouping nodes, because their failures are actually just derived from child failures
@@ -192,12 +194,13 @@ publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi
 
     total = countWhere isItBlock tree
     succeeded = countWhere isSuccessItBlock tree
-    pending = countWhere isPendingItBlock tree
+    pending' = countWhere isPendingItBlock tree
     failed = countWhere isFailedItBlock tree
     totalRunningTests = countWhere isRunningItBlock tree
     -- totalNotStartedTests = countWhere isNotStartedItBlock tree
 
 
+singleFailureBlocks :: SlackFormatter -> M.Map Int (T.Text, Int) -> RunNodeWithStatus context s l t -> FailureReason -> [A.Value]
 singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [
   Just $ markdownSectionWithLines [":red_circle: *" <> label <> "*"]
 
@@ -235,10 +238,13 @@ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [
         _ -> Just l
     label = T.intercalate ", " $ mapMaybe filterFn $ toList $ runTreeAncestors $ runNodeCommon node
 
+extraFailuresBlock :: Int -> A.Value
 extraFailuresBlock numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]]
 
+markdownBlockWithLines :: [T.Text] -> A.Value
 markdownBlockWithLines ls = A.object [("type", A.String "mrkdwn"), ("text", A.String $ T.unlines ls)]
 
+markdownSectionWithLines :: [T.Text] -> A.Value
 markdownSectionWithLines ls = A.object [("type", A.String "section"), ("text", markdownBlockWithLines ls)]
 
 addToLastLine :: [T.Text] -> T.Text -> [T.Text]

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

@@ -19,7 +19,7 @@ toMarkdown (DidNotExpectButGot {..}) = [i|Did not expect *#{failureValue1}*|]
 toMarkdown (GotException {..}) = case failureMessage of
   Just msg -> [i|Got exception (_#{msg}_): #{failureException}|]
   Nothing -> [i|Got exception (no message): #{failureException}|]
-toMarkdown (Pending {..}) = "Example was pending"
+toMarkdown (Pending {}) = "Example was pending"
 toMarkdown (GetContextException {..}) = [i|Context exception: #{failureException}|]
 toMarkdown (GotAsyncException {..}) = case failureMessage of
   Just msg -> [i|Got async exception (_#{msg}_): #{failureAsyncException}|]
@@ -30,6 +30,7 @@ callStackToMarkdown SlackFormatterNoCallStacks _cs = ""
 callStackToMarkdown (SlackFormatterTopNCallStackFrames n) cs = "\n\n" <> showCallStack (fromCallSiteList $ L.take n $ getCallStack cs)
 callStackToMarkdown SlackFormatterFullCallStack cs = "\n\n" <> showCallStack cs
 
+showCallStack :: CallStack -> T.Text
 showCallStack (getCallStack -> rows) = ["> *" <> (T.pack name) <> "*, called at "
                                         <> [i|_#{srcLocPackage}_:*#{srcLocFile}*:#{srcLocStartLine}:#{srcLocStartCol}|]
                                        | (name, SrcLoc {..}) <- rows]

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

@@ -79,5 +79,5 @@ barSized n = (T.replicate darkBlocks $ T.singleton $ chr 9608)
         lightBlocks = round $ (100 - n) * multiplier
         multiplier = 0.5
 
-        roundTo :: (Fractional a, RealFrac a) => Integer -> a -> a
+        roundTo :: (RealFrac a) => Integer -> a -> a
         roundTo places num = (fromInteger $ round $ num * (10^places)) / (10.0^^places)

sandwich-webdriver/linux-src/Test/Sandwich/WebDriver/Resolution.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Test.Sandwich.WebDriver.Resolution (
   getResolution
@@ -9,6 +10,7 @@ import Data.Function
 import qualified Data.List as L
 import Data.String.Interpolate
 import qualified Data.Text as T
+import GHC.Stack
 import Safe
 import System.Directory
 import System.Exit
@@ -27,14 +29,14 @@ import Text.Regex
 -- https://github.com/rr-/screeninfo/blob/master/screeninfo/enumerators/xinerama.py
 -- but again, that would require users to install those libraries. xrandr itself seems like an easier
 -- dependency.
-getResolution :: IO (Int, Int, Int, Int)
+getResolution :: (HasCallStack) => IO (Int, Int, Int, Int)
 getResolution = getResolution' Nothing
 
 getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int)
 getResolutionForDisplay n = getResolution' (Just [("DISPLAY", ":" <> show n)])
 
 -- | Note: this doesn't pick up display scaling on Ubuntu 20.04.
-getResolution' :: Maybe [(String, String)] -> IO (Int, Int, Int, Int)
+getResolution' :: (HasCallStack) => Maybe [(String, String)] -> IO (Int, Int, Int, Int)
 getResolution' xrandrEnv = do
   xrandrPath <- findExecutable "xrandr" >>= \case
     Just x -> return x

sandwich-webdriver/package.yaml

@@ -42,6 +42,7 @@ dependencies:
 - time
 - transformers
 - unliftio
+- unliftio-core
 - unordered-containers
 - vector
 - webdriver

sandwich-webdriver/sandwich-webdriver.cabal

@@ -91,6 +91,7 @@ library
     , time
     , transformers
     , unliftio
+    , unliftio-core
     , unordered-containers
     , vector
     , webdriver
@@ -168,6 +169,7 @@ executable sandwich-webdriver-exe
     , time
     , transformers
     , unliftio
+    , unliftio-core
     , unordered-containers
     , vector
     , webdriver
@@ -246,6 +248,7 @@ test-suite sandwich-webdriver-test
     , time
     , transformers
     , unliftio
+    , unliftio-core
     , unordered-containers
     , vector
     , webdriver

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

@@ -35,7 +35,6 @@ module Test.Sandwich.WebDriver (
   ) where
 
 import Control.Applicative
-import Control.Concurrent.MVar.Lifted
 import Control.Monad.IO.Class
 import Control.Monad.Logger
 import Control.Monad.Reader
@@ -54,6 +53,7 @@ import Test.Sandwich.WebDriver.Types
 import qualified Test.WebDriver as W
 import qualified Test.WebDriver.Config as W
 import qualified Test.WebDriver.Session as W
+import UnliftIO.MVar
 
 
 -- | This is the main 'introduce' method for creating a WebDriver.
@@ -81,7 +81,7 @@ allocateWebDriver' runRoot wdOptions = do
   runNoLoggingT $ startWebDriver wdOptions runRoot
 
 -- | Clean up the given WebDriver.
-cleanupWebDriver :: (HasBaseContext context, BaseMonad m) => WebDriver -> ExampleT context m ()
+cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m ()
 cleanupWebDriver sess = do
   closeAllSessions sess
   stopWebDriver sess
@@ -94,7 +94,7 @@ cleanupWebDriver' sess = do
     stopWebDriver sess
 
 -- | Run a given example using a given Selenium session.
-withSession :: forall m context a. WebDriverMonad m context => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a
+withSession :: forall m context a. (WebDriverMonad m context) => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a
 withSession session (ExampleT readerMonad) = do
   WebDriver {..} <- getContext webdriver
   -- Create new session if necessary (this can throw an exception)
@@ -124,7 +124,7 @@ withSession2 :: WebDriverMonad m context => ExampleT (ContextWithSession context
 withSession2 = withSession "session2"
 
 -- | Get all existing session names
-getSessions :: (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriver" WebDriver) => m [Session]
+getSessions :: (MonadReader context m, WebDriverMonad m context) => m [Session]
 getSessions = do
   WebDriver {..} <- getContext webdriver
   M.keys <$> liftIO (readMVar wdSessionMap)

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

@@ -3,12 +3,10 @@
 module Test.Sandwich.WebDriver.Internal.Action where
 
 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)
 import qualified Data.Map as M
 import Data.String.Interpolate
 import GHC.Stack

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

@@ -12,11 +12,9 @@ module Test.Sandwich.WebDriver.Internal.Binaries (
 
 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
 import Data.String.Interpolate
 import qualified Data.Text as T

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

@@ -91,7 +91,7 @@ getChromeDriverVersion' (ChromeVersion (w, x, y, z))
              (do
                  result :: T.Text <- (TL.toStrict . TL.decodeUtf8) <$> simpleHttp url
                  case T.splitOn "." result of
-                   [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ ChromeDriverVersionTuple (w, x, y, z)
+                   [tReadMay -> Just w', tReadMay -> Just x', tReadMay -> Just y', tReadMay -> Just z'] -> return $ Right $ ChromeDriverVersionTuple (w', x', y', z')
                    _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]
              )
   | otherwise = do
@@ -107,15 +107,15 @@ getChromeDriverVersion' (ChromeVersion (w, x, y, z))
                      let matchingVersions = [v | v@(Version {..}) <- versions response
                                                , [i|#{w}.#{x}.#{y}.|] `T.isPrefixOf` version]
 
-                     let exactMatch = headMay [x | x@(Version {..}) <- matchingVersions
-                                               , [i|#{w}.#{x}.#{y}.#{z}|] == version]
+                     let exactMatch = headMay [v | v@(Version {..}) <- matchingVersions
+                                                 , [i|#{w}.#{x}.#{y}.#{z}|] == version]
 
                      let versionList :: [Version]
-                         versionList = (case exactMatch of Nothing -> id; Just x -> (x :)) matchingVersions
+                         versionList = (case exactMatch of Nothing -> id; Just v -> (v :)) matchingVersions
 
                      case headMay (mapMaybe extractSuitableChromeDriver versionList) of
                        Nothing -> return $ Left [i|Couldn't find chromedriver associated with any Chrome release|]
-                       Just (tup, url) -> return $ Right $ ChromeDriverVersionExactUrl tup url
+                       Just (tup, url') -> return $ Right $ ChromeDriverVersionExactUrl tup url'
              )
 
 extractSuitableChromeDriver :: Version -> Maybe ((Int, Int, Int, Int), Text)
@@ -154,4 +154,5 @@ getChromeDriverDownloadUrl (ChromeDriverVersionExactUrl _ url) _ = url
 
 -- * Util
 
+tReadMay :: T.Text -> Maybe Int
 tReadMay = readMay . T.unpack

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

@@ -74,4 +74,5 @@ getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Windows = [i|https://gi
 
 -- * Util
 
+tReadMay :: T.Text -> Maybe Int
 tReadMay = readMay . T.unpack

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

@@ -8,7 +8,6 @@ module Test.Sandwich.WebDriver.Internal.Screenshots where
 import Control.Concurrent
 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
@@ -26,5 +25,5 @@ saveScreenshots screenshotName (WebDriver {..}) resultsDir = do
   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}'|])
+               e' -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e'}'|])
            (runWD sess $ saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])

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

@@ -13,6 +13,7 @@ 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
@@ -57,7 +58,7 @@ fromText = id
 #endif
 
 
-type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)
+type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
 
 -- | Spin up a Selenium WebDriver and create a WebDriver
 startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
@@ -117,6 +118,9 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do
     liftIO $ createDirectoryIfMissing True webdriverProcessRoot
     startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv
 
+startWebDriver' :: (
+  MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m
+  ) => WdOptions -> T.Text -> [Char] -> [Char] -> [Char] -> [String] -> Maybe XvfbSession -> Maybe [(String, String)] -> m WebDriver
 startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do
   port <- liftIO findFreePortOrException
   let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath
@@ -150,7 +154,7 @@ startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriver
         t | readyMessage `T.isInfixOf` t -> return True
         _ -> return False
   unless success $ liftIO $ do
-    interruptProcessGroupOf p >> waitForProcess p
+    _ <- interruptProcessGroupOf p >> waitForProcess p
     error [i|Selenium server failed to start after 60 seconds|]
 
   capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities'
@@ -211,18 +215,18 @@ configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps
     (w, h) = fromMaybe (1920, 1080) headlessResolution
 
 -- | Add headless configuration to the Firefox capabilities
-configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })
+configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })
   where
     additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of
       Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac
-      Just i -> let ffOptions' = snd (ac !! i)
-                               & ensureKeyExists "args" (A.Array [])
-                               & ((key "args" . _Array) %~ addHeadlessArg) in
+      Just i' -> let ffOptions' = snd (ac !! i')
+                                & ensureKeyExists "args" (A.Array [])
+                                & ((key "args" . _Array) %~ addHeadlessArg) in
         L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)
 
     ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value
-    ensureKeyExists key _ val@(A.Object (HM.lookup (fromText key) -> Just _)) = val
-    ensureKeyExists key defaultVal (A.Object m@(HM.lookup (fromText key) -> Nothing)) = A.Object (HM.insert (fromText key) defaultVal m)
+    ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val
+    ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m)
     ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"
 
     addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value
@@ -233,6 +237,9 @@ configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mod
 configureHeadlessCapabilities _ _ browser = return browser
 
 
+configureDownloadCapabilities :: (
+  MonadIO m, MonadBaseControl IO m
+  ) => [Char] -> W.Capabilities -> m W.Capabilities
 configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do
   case ffProfile of
     Nothing -> return ()

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

@@ -25,8 +25,11 @@ import qualified Test.WebDriver.Session as W
 type Session = String
 
 -- * Labels
-webdriver = Label :: Label "webdriver" WebDriver
-webdriverSession = Label :: Label "webdriverSession" WebDriverSession
+webdriver :: Label "webdriver" WebDriver
+webdriver = Label
+
+webdriverSession :: Label "webdriverSession" WebDriverSession
+webdriverSession = Label
 
 type WebDriverContext context wd = (HasLabel context "webdriver" WebDriver, W.WebDriver (ExampleT context wd))
 
@@ -136,6 +139,7 @@ data HeadlessConfig = HeadlessConfig {
   }
 
 -- | Default headless config.
+defaultHeadlessConfig :: HeadlessConfig
 defaultHeadlessConfig = HeadlessConfig Nothing
 
 data XvfbConfig = XvfbConfig {
@@ -147,6 +151,7 @@ data XvfbConfig = XvfbConfig {
   }
 
 -- | Default Xvfb settings.
+defaultXvfbConfig :: XvfbConfig
 defaultXvfbConfig = XvfbConfig Nothing False
 
 -- | The default 'WdOptions' object.
@@ -213,6 +218,7 @@ instance Show XvfbSession where
 -- * Video stuff
 
 -- | Default options for fast X11 video recording.
+fastX11VideoOptions :: [String]
 fastX11VideoOptions = ["-an"
                       , "-r", "30"
                       , "-vcodec"
@@ -221,6 +227,7 @@ fastX11VideoOptions = ["-an"
                       , "-threads", "0"]
 
 -- | Default options for quality X11 video recording.
+qualityX11VideoOptions :: [String]
 qualityX11VideoOptions = ["-an"
                          , "-r", "30"
                          , "-vcodec", "libx264"
@@ -229,6 +236,7 @@ qualityX11VideoOptions = ["-an"
                          , "-threads", "0"]
 
 -- | Default options for AVFoundation recording (for Darwin).
+defaultAvfoundationOptions :: [String]
 defaultAvfoundationOptions = ["-r", "30"
                              , "-an"
                              , "-vcodec", "libxvid"
@@ -236,6 +244,7 @@ defaultAvfoundationOptions = ["-r", "30"
                              , "-threads", "0"]
 
 -- | Default options for gdigrab recording (for Windows).
+defaultGdigrabOptions :: [String]
 defaultGdigrabOptions = ["-framerate", "30"]
 
 data VideoSettings = VideoSettings {
@@ -252,6 +261,7 @@ data VideoSettings = VideoSettings {
   }
 
 -- | Default video settings.
+defaultVideoSettings :: VideoSettings
 defaultVideoSettings = VideoSettings {
   x11grabOptions = fastX11VideoOptions
   , avfoundationOptions = defaultAvfoundationOptions

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

@@ -3,9 +3,7 @@
 module Test.Sandwich.WebDriver.Internal.Util where
 
 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

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

@@ -17,6 +17,7 @@ getMacScreenNumber = undefined
 #endif
 
 
+getVideoArgs :: (MonadIO m) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m CreateProcess
 getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do
 #ifdef linux_HOST_OS
   displayNum <- case maybeXvfbSession of

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Test.Sandwich.WebDriver.Types (
   ExampleWithWebDriver
@@ -23,8 +24,9 @@ module Test.Sandwich.WebDriver.Types (
   , WebDriverSessionMonad
   ) where
 
-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
+import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.IORef
@@ -49,7 +51,7 @@ instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession) => W.
     liftIO $ writeIORef sessVar sess
 
 -- Implementation copied from that of the WD monad implementation
-instance (MonadIO m, MonadThrow m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where
+instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where
   doCommand method path args = WI.mkRequest method path args
     >>= WI.sendHTTPRequest
     >>= either throwIO return
@@ -64,7 +66,7 @@ hoistExample :: ExampleT context IO a -> ExampleT (ContextWithSession context) I
 hoistExample (ExampleT r) = ExampleT $ transformContext r
   where transformContext = withReaderT (\(_ :> ctx) -> ctx)
 
-type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadIO m, MonadBaseControl IO m)
+type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadUnliftIO m, MonadBaseControl IO m)
 type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriverSession" WebDriverSession)
-type BaseMonad m = (HasCallStack, MonadIO m, MonadCatch m, MonadBaseControl IO m, MonadMask m)
+type BaseMonad m = (HasCallStack, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
 type BaseMonadContext m context = (BaseMonad m, HasBaseContext context)

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

@@ -19,6 +19,7 @@ module Test.Sandwich.WebDriver.Video (
   ) where
 
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logError)
 import Control.Monad.Reader
 import Data.String.Interpolate
@@ -36,11 +37,11 @@ import Test.WebDriver.Commands
 import UnliftIO.Exception
 
 
-type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context)
+type BaseVideoConstraints context m = (MonadLoggerIO m, MonadUnliftIO m, MonadReader context m, HasWebDriverContext context)
 
 -- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
 startFullScreenVideoRecording :: (
-  BaseVideoConstraints context m, MonadMask m
+  BaseVideoConstraints context m
   ) => FilePath -> VideoSettings -> m ProcessHandle
 startFullScreenVideoRecording path videoSettings = do
   sess <- getContext webdriver
@@ -54,7 +55,7 @@ startFullScreenVideoRecording path videoSettings = do
 
 -- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser.
 startBrowserVideoRecording :: (
-  BaseVideoConstraints context m, MonadThrow m, HasWebDriverSessionContext context, W.WebDriver m
+  BaseVideoConstraints context m, W.WebDriver m
   ) => FilePath -> VideoSettings -> m ProcessHandle
 startBrowserVideoRecording path videoSettings = do
   (x, y) <- getWindowPos
@@ -86,7 +87,7 @@ startVideoRecording path (width, height, x, y) vs = do
 
 -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
 endVideoRecording :: (
-  MonadLoggerIO m, MonadCatch m
+  MonadLoggerIO m, MonadUnliftIO m
   ) => ProcessHandle -> m ()
 endVideoRecording p = do
   catchAny (liftIO $ interruptProcessGroupOf p)

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

@@ -1,5 +1,5 @@
--- | Functions for manipulating browser windows.
 
+-- | Functions for manipulating browser windows.
 
 module Test.Sandwich.WebDriver.Windows (
   -- * Window positioning
@@ -11,9 +11,7 @@ module Test.Sandwich.WebDriver.Windows (
   , getScreenResolution
   ) where
 
-import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
-import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Reader
 import Data.Bits as B
 import Data.Maybe
@@ -23,11 +21,10 @@ 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.
-setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
+setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd ()
 setWindowLeftSide = do
   sess <- getContext webdriver
   (x, y, width, height) <- case runMode $ wdOptions sess of
@@ -38,7 +35,7 @@ setWindowLeftSide = do
   setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height)
 
 -- | Position the window on the right 50% of the screen.
-setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
+setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd ()
 setWindowRightSide = do
   sess <- getContext webdriver
   (x, y, width, height) <- case runMode $ wdOptions sess of
@@ -50,7 +47,7 @@ setWindowRightSide = do
   setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height)
 
 -- | Fullscreen the browser window.
-setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
+setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd ()
 setWindowFullScreen = do
   sess <- getContext webdriver
   (x, y, width, height) <- case runMode $ wdOptions sess of
@@ -61,7 +58,7 @@ setWindowFullScreen = do
   setWindowSize (fromIntegral width, fromIntegral height)
 
 -- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.)
-getScreenResolution :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int)
+getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)
 getScreenResolution (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of
   Nothing -> liftIO getResolution
   Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum

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

@@ -1,7 +1,7 @@
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (
@@ -13,7 +13,6 @@ 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.List as L
 import Data.Maybe