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,67 +32,67 @@ 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
 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
   deriving (Show)
 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]