hedgehog-extras 0.6.5.0 → 0.6.5.1

raw patch · 4 files changed

+157/−25 lines, 4 filesdep +retrydep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: retry

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +3/−1
• src/Hedgehog/Extras/Test/Base.hs +132/−13
• src/Hedgehog/Extras/Test/File.hs +9/−3
• src/Hedgehog/Extras/Test/Process.hs +13/−8

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:                   hedgehog-extras-version:                0.6.5.0+version:                0.6.5.1 synopsis:               Supplemental library for hedgehog description:            Supplemental library for hedgehog. category:               Test@@ -37,6 +37,7 @@ common network                      { build-depends: network                                                      } common process                      { build-depends: process                                                      } common resourcet                    { build-depends: resourcet                                                    }+common retry                        { build-depends: retry                             >= 0.9                     } common stm                          { build-depends: stm                                                          } common tar                          { build-depends: tar                              ^>= 0.6                     } common tasty                        { build-depends: tasty                                                        }@@ -89,6 +90,7 @@                         network,                         process,                         resourcet,+                        retry,                         stm,                         tar,                         temporary,

@@ -16,18 +16,30 @@   , noteIO_    , noteShow-  , noteShow_-  , noteShowM-  , noteShowM_+  , noteShowPretty   , noteShowIO+  , noteShowPrettyIO   , noteShowIO_+  , noteShowPrettyIO_+  , noteShowM+  , noteShowPrettyM+  , noteShowM_+  , noteShowPrettyM_+  , noteShow_+  , noteShowPretty_    , noteEach-  , noteEach_-  , noteEachM-  , noteEachM_+  , noteEachPretty   , noteEachIO+  , noteEachPrettyIO   , noteEachIO_+  , noteEachPrettyIO_+  , noteEachM+  , noteEachPrettyM+  , noteEachM_+  , noteEachPrettyM_+  , noteEach_+  , noteEachPretty_    , noteTempFile @@ -80,9 +92,9 @@ import           Control.Monad.Catch (MonadCatch) import           Control.Monad.Morph (hoist) import           Control.Monad.Reader (MonadIO (..), MonadReader (ask))-import           Control.Monad.Trans.Resource (ReleaseKey, runResourceT)+import           Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register, runResourceT) import           Data.Aeson (Result (..))-import           Data.Bool (Bool, (&&), otherwise)+import           Data.Bool (Bool (..), otherwise, (&&)) import           Data.Either (Either (..), either) import           Data.Eq (Eq ((/=))) import           Data.Foldable (for_)@@ -96,7 +108,7 @@ import           Data.Time.Clock (NominalDiffTime, UTCTime) import           Data.Traversable (Traversable) import           Data.Tuple (snd)-import           GHC.Stack (CallStack, HasCallStack)+import           GHC.Stack import           Hedgehog (MonadTest) import           Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) import           Hedgehog.Extras.Stock.CallStack (callerModuleName)@@ -111,7 +123,10 @@  import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM+import           Control.Exception (IOException)+import           Control.Monad.Catch (Handler (..)) import qualified Control.Monad.Trans.Resource as IO+import qualified Control.Retry as R import qualified Data.List as L import qualified Data.Time.Clock as DTC import qualified GHC.Stack as GHC@@ -119,6 +134,7 @@ import qualified Hedgehog.Extras.Internal.Test.Integration as H import qualified Hedgehog.Extras.Test.MonadAssertion as H import qualified Hedgehog.Internal.Property as H+import qualified Hedgehog.Internal.Show as H import qualified System.Directory as IO import qualified System.Environment as IO import qualified System.Info as IO@@ -148,8 +164,14 @@ -- -- The directory will be deleted if the block succeeds, but left behind if -- the block fails.-workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()-workspace prefixPath f = GHC.withFrozenCallStack $ do+workspace+  :: MonadTest m+  => HasCallStack+  => MonadResource m+  => FilePath+  -> (FilePath -> m ())+  -> m ()+workspace prefixPath f = withFrozenCallStack $ do   systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory   maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE"   ws <- H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test"@@ -157,7 +179,17 @@   H.evalIO $ IO.writeFile (ws </> "module") callerModuleName   f ws   when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do-    H.evalIO $ IO.removePathForcibly ws+    -- try to delete the directory 20 times, 100ms apart+    let retryPolicy = R.constantDelay 100000 <> R.limitRetries 20+        -- retry only on IOExceptions+        ioExH _ = Handler $ \(_ :: IOException) -> pure True+    -- For some reason, the temporary directory removal sometimes fails.+    -- Lets wrap this in MonadResource to try multiple times, during the cleanup, before we fail.+    void+      . register+      . R.recovering retryPolicy [ioExH]+      . const+      $ IO.removePathForcibly ws  -- | Create a workspace directory which will exist for at least the duration of -- the supplied block.@@ -169,7 +201,7 @@ -- the block fails. -- -- The 'prefix' argument should not contain directory delimeters.-moduleWorkspace :: (MonadTest m, MonadIO m, HasCallStack) => String -> (FilePath -> m ()) -> m ()+moduleWorkspace :: (MonadTest m, MonadResource m, HasCallStack) => String -> (FilePath -> m ()) -> m () moduleWorkspace prefix f = GHC.withFrozenCallStack $ do   let srcModule = maybe "UnknownModule" (GHC.srcLocModule . snd) (listToMaybe (GHC.getCallStack GHC.callStack))   workspace (prefix <> "-" <> srcModule) f@@ -224,10 +256,23 @@   noteWithCallstack GHC.callStack (show b)   return b +-- | Annotate the given value, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPretty :: (MonadTest m, HasCallStack, Show a) => a -> m a+noteShowPretty a = GHC.withFrozenCallStack $ do+  !b <- H.eval a+  noteWithCallstack GHC.callStack (H.showPretty b)+  return b+ -- | Annotate the given value returning unit. noteShow_ :: (MonadTest m, HasCallStack, Show a) => a -> m () noteShow_ a = GHC.withFrozenCallStack $ noteWithCallstack GHC.callStack (show a) +-- | Annotate the given value returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPretty_ :: (MonadTest m, HasCallStack, Show a) => a -> m ()+noteShowPretty_ a = GHC.withFrozenCallStack $ noteWithCallstack GHC.callStack (H.showPretty a)+ -- | Annotate the given value in a monadic context. noteShowM :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m a noteShowM a = GHC.withFrozenCallStack $ do@@ -235,6 +280,14 @@   noteWithCallstack GHC.callStack (show b)   return b +-- | Annotate the given value in a monadic context, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPrettyM :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m a+noteShowPrettyM a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack (H.showPretty b)+  return b+ -- | Annotate the given value in a monadic context returning unit. noteShowM_ :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m () noteShowM_ a = GHC.withFrozenCallStack $ do@@ -242,6 +295,14 @@   noteWithCallstack GHC.callStack (show b)   return () +-- | Annotate the given value in a monadic context returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPrettyM_ :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m ()+noteShowPrettyM_ a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack (H.showPretty b)+  return ()+ -- | Annotate the given value in IO. noteShowIO :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m a noteShowIO f = GHC.withFrozenCallStack $ do@@ -249,6 +310,14 @@   noteWithCallstack GHC.callStack (show a)   return a +-- | Annotate the given value in IO, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPrettyIO :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m a+noteShowPrettyIO f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack (H.showPretty a)+  return a+ -- | Annotate the given value in IO returning unit. noteShowIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m () noteShowIO_ f = GHC.withFrozenCallStack $ do@@ -256,16 +325,36 @@   noteWithCallstack GHC.callStack (show a)   return () +-- | Annotate the given value in IO returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteShowPrettyIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m ()+noteShowPrettyIO_ f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack (H.showPretty a)+  return ()+ -- | Annotate the each value in the given traversable. noteEach :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m (f a) noteEach as = GHC.withFrozenCallStack $ do   for_ as $ noteWithCallstack GHC.callStack . show   return as +-- | Annotate the each value in the given traversable, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPretty :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m (f a)+noteEachPretty as = GHC.withFrozenCallStack $ do+  for_ as $ noteWithCallstack GHC.callStack . H.showPretty+  return as+ -- | Annotate the each value in the given traversable returning unit. noteEach_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m () noteEach_ as = GHC.withFrozenCallStack $ for_ as $ noteWithCallstack GHC.callStack . show +-- | Annotate the each value in the given traversable returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPretty_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m ()+noteEachPretty_ as = GHC.withFrozenCallStack $ for_ as $ noteWithCallstack GHC.callStack . H.showPretty+ -- | Annotate the each value in the given traversable in a monadic context. noteEachM :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m (f a) noteEachM f = GHC.withFrozenCallStack $ do@@ -273,12 +362,27 @@   for_ as $ noteWithCallstack GHC.callStack . show   return as +-- | Annotate the each value in the given traversable in a monadic context, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPrettyM :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m (f a)+noteEachPrettyM f = GHC.withFrozenCallStack $ do+  !as <- f+  for_ as $ noteWithCallstack GHC.callStack . H.showPretty+  return as+ -- | Annotate the each value in the given traversable in a monadic context returning unit. noteEachM_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m () noteEachM_ f = GHC.withFrozenCallStack $ do   !as <- f   for_ as $ noteWithCallstack GHC.callStack . show +-- | Annotate the each value in the given traversable in a monadic context returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPrettyM_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m ()+noteEachPrettyM_ f = GHC.withFrozenCallStack $ do+  !as <- f+  for_ as $ noteWithCallstack GHC.callStack . H.showPretty+ -- | Annotate the each value in the given traversable in IO. noteEachIO :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m (f a) noteEachIO f = GHC.withFrozenCallStack $ do@@ -286,11 +390,26 @@   for_ as $ noteWithCallstack GHC.callStack . show   return as +-- | Annotate the each value in the given traversable in IO, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPrettyIO :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m (f a)+noteEachPrettyIO f = GHC.withFrozenCallStack $ do+  !as <- H.evalIO f+  for_ as $ noteWithCallstack GHC.callStack . H.showPretty+  return as+ -- | Annotate the each value in the given traversable in IO returning unit. noteEachIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m () noteEachIO_ f = GHC.withFrozenCallStack $ do   !as <- H.evalIO f   for_ as $ noteWithCallstack GHC.callStack . show++-- | Annotate the each value in the given traversable in IO returning unit, pretty printing it with indentation. Note that large data structures will take+-- a significant amount of vertical screen space.+noteEachPrettyIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m ()+noteEachPrettyIO_ f = GHC.withFrozenCallStack $ do+  !as <- H.evalIO f+  for_ as $ noteWithCallstack GHC.callStack . H.showPretty  -- | Return the test file path after annotating it relative to the project root directory noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath

@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}  module Hedgehog.Extras.Test.File   ( createDirectoryIfMissing@@ -65,6 +65,8 @@ import           Data.Semigroup import           Data.String (String) import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text import           Data.Time.Clock (UTCTime) import           GHC.Stack (HasCallStack) import           Hedgehog (MonadTest)@@ -158,7 +160,9 @@ writeFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> m () writeFile filePath contents = GHC.withFrozenCallStack $ do   void . H.annotate $ "Writing file: " <> filePath-  H.evalIO $ IO.writeFile filePath contents+  H.evalIO $ IO.withFile filePath IO.WriteMode $ \handle -> do+    IO.hSetEncoding handle IO.utf8+    IO.hPutStr handle contents  -- | Open a handle to the 'filePath' file. openFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> IOMode -> m Handle@@ -170,7 +174,9 @@ readFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m String readFile filePath = GHC.withFrozenCallStack $ do   void . H.annotate $ "Reading file: " <> filePath-  H.evalIO $ IO.readFile filePath+  liftIO $ IO.withFile filePath IO.ReadMode $ \handle -> do+             IO.hSetEncoding handle IO.utf8+             Text.unpack <$> Text.hGetContents handle  -- | Write 'contents' to the 'filePath' file. lbsWriteFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> LBS.ByteString -> m ()

@@ -25,7 +25,7 @@   , defaultExecConfig   ) where -import           Control.Monad (Monad (..), MonadFail (fail), void)+import           Control.Monad (Monad (..), MonadFail (fail), void, unless) import           Control.Monad.Catch (MonadCatch) import           Control.Monad.IO.Class (MonadIO, liftIO) import           Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register)@@ -84,14 +84,15 @@ findDefaultPlanJsonFile = IO.getCurrentDirectory >>= go   where go :: FilePath -> IO FilePath         go d = do-          let file = d </> "dist-newstyle/cache/plan.json"+          let planRelPath = "dist-newstyle/cache/plan.json"+              file = d </> planRelPath           exists <- IO.doesFileExist file           if exists             then return file             else do               let parent = takeDirectory d               if parent == d-                then return "dist-newstyle/cache/plan.json"+                then return planRelPath                 else go parent  -- | Discover the location of the plan.json file.@@ -272,7 +273,7 @@  -- | Compute the path to the binary given a package name or an environment variable override. binFlex-  :: (MonadTest m, MonadIO m)+  :: (HasCallStack, MonadTest m, MonadIO m)   => String   -- ^ Package name   -> String@@ -288,22 +289,26 @@ -- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding. -- to a haskell package.  It is assumed that the project has already been configured and the -- executable has been built.+-- Throws an exception on failure. binDist-  :: (MonadTest m, MonadIO m)+  :: (HasCallStack, MonadTest m, MonadIO m)   => String   -- ^ Package name   -> m FilePath   -- ^ Path to executable binDist pkg = do+  doesPlanExist <- liftIO $ IO.doesFileExist planJsonFile+  unless doesPlanExist $+    error $ "Could not find plan.json in the path: " <> planJsonFile   contents <- H.evalIO . LBS.readFile $ planJsonFile    case eitherDecode contents of     Right plan -> case L.filter matching (plan & installPlan) of       (component:_) -> case component & binFile of         Just bin -> return $ addExeSuffix (T.unpack bin)-        Nothing -> error $ "missing bin-file in: " <> show component-      [] -> error $ "Cannot find exe:" <> pkg <> " in plan"-    Left message -> error $ "Cannot decode plan: " <> message+        Nothing -> error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile+      [] -> error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile+    Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message   where matching :: Component -> Bool         matching component = case componentName component of           Just name -> name == "exe:" <> T.pack pkg