codedownio/sandwich
1
1
Fork 0
mirror of https://github.com/codedownio/sandwich.git synced 2024-07-14 15:10:30 +03:00
Code Issues Projects Releases Wiki Activity

Halfway through unliftio switch

Browse Source
This commit is contained in:
Tom McLaughlin 2024-02-29 02:19:40 -08:00
parent 057b11f5f8
commit db5671f14c
40 changed files with 140 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
sandwich-hedgehog/package.yaml
View File

@ -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

4
sandwich-hedgehog/sandwich-hedgehog.cabal
View File

@ -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

2
sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs
View File

@ -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

2
sandwich-quickcheck/package.yaml
View File

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

8
sandwich-quickcheck/sandwich-quickcheck.cabal
View File

@ -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

2
sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs
View File

@ -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

2
sandwich-slack/package.yaml
View File

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

10
sandwich-slack/sandwich-slack.cabal
View File

@ -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

2
sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs
View File

@ -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)

3
sandwich-webdriver/package.yaml
View File

@ -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

8
sandwich-webdriver/sandwich-webdriver.cabal
View File

@ -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

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

@ -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

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

@ -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)

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

@ -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|])

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

@ -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

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

@ -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

3
sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs
View File

@ -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

5
sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
View File

@ -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 :: (

3
sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs
View File

@ -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.

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

@ -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)])

2
sandwich/app/Main.hs
View File

@ -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(..))

3
sandwich/package.yaml
View File

@ -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

15
sandwich/sandwich.cabal
View File

@ -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

2
sandwich/src/Test/Sandwich.hs
View File

@ -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

42
sandwich/src/Test/Sandwich/Expectations.hs
View File

@ -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)

2
sandwich/src/Test/Sandwich/Formatters/Print/FailureReason.hs
View File

@ -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

2
sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
View File

@ -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)

2
sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs
View File

@ -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

4
sandwich/src/Test/Sandwich/Golden.hs
View File

@ -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

2
sandwich/src/Test/Sandwich/Golden/Update.hs
View File

@ -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

2
sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
View File

@ -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

28
sandwich/src/Test/Sandwich/Logging.hs
View File

@ -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

17
sandwich/src/Test/Sandwich/ParallelN.hs
View File

@ -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

9
sandwich/src/Test/Sandwich/TestTimer.hs
View File

@ -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

5
sandwich/src/Test/Sandwich/Types/Spec.hs
View File

@ -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)

2
sandwich/test/Around.hs
View File

@ -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

2
sandwich/test/Before.hs
View File

@ -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

2
sandwich/test/Describe.hs
View File

@ -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

2
sandwich/test/Introduce.hs
View File

@ -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

2
sandwich/test/TestUtil.hs
View File

@ -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