hedgehog-extras 0.9.0.0 → 0.10.0.0

raw patch · 4 files changed

+341/−50 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +3/−1
• src/Hedgehog/Extras/Test/Base.hs +65/−17
• src/Hedgehog/Extras/Test/TestWatchdog.hs +16/−32
• test/Hedgehog/Extras/Test/WorkspaceSpec.hs +257/−0

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:                   hedgehog-extras-version:                0.9.0.0+version:                0.10.0.0 synopsis:               Supplemental library for hedgehog description:            Supplemental library for hedgehog. category:               Test@@ -152,6 +152,7 @@  test-suite hedgehog-extras-test   import:               base, project-config,+                        directory,                         hedgehog,                         hedgehog-extras,                         lifted-base,@@ -171,6 +172,7 @@                         Hedgehog.Extras.Test.TestExpectFailure                         Hedgehog.Extras.Test.TestWatchdogSpec                         Hedgehog.Extras.Test.UnitSpec+                        Hedgehog.Extras.Test.WorkspaceSpec    build-tool-depends:   tasty-discover:tasty-discover   ghc-options:          -threaded -rtsopts "-with-rtsopts=-N -T"

@@ -6,6 +6,8 @@   ( propertyOnce    , workspace+  , workspaceWithConfig+  , WorkspacePolicy(..)   , moduleWorkspace    , note@@ -100,15 +102,15 @@ import           Control.Exception (IOException) import           Control.Exception.Lifted (bracket, bracket_, try) import           Control.Monad.Trans.Control (MonadBaseControl)-import           Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when)+import           Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void) import           Control.Monad.Catch (MonadCatch) import           Control.Monad.Morph (hoist) import           Control.Monad.Reader (MonadIO (..), MonadReader (ask)) import           Control.Monad.Trans.Resource (MonadResource, ReleaseKey, 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.Eq (Eq ((==))) import           Data.Foldable (for_) import           Data.Function (const, ($), (.)) import           Data.Functor ((<$>))@@ -120,7 +122,6 @@ import           Data.Traversable (Traversable) import           Data.Tuple (snd) import           GHC.Stack-import           Hedgehog (MonadTest) import           Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) import           Hedgehog.Extras.Stock.CallStack (callerModuleName) import           Hedgehog.Extras.Stock.Monad (forceM)@@ -148,9 +149,16 @@ import qualified System.Info as IO import qualified System.IO as IO import qualified System.IO.Temp as IO+import Hedgehog.Internal.Property  {- HLINT ignore "Reduce duplication" -} +-- | Policy for workspace directory cleanup behavior+data WorkspacePolicy+  = PreserveWorkspace    -- ^ Always preserve workspace directories, even on success+  | CleanupOnSuccess     -- ^ Clean up workspace directories only when tests succeed+  deriving (Eq, Show)+ -- | Run a property with only one test.  This is intended for allowing hedgehog -- to run unit tests. propertyOnce :: HasCallStack => Integration () -> H.Property@@ -181,26 +189,64 @@ -- the block fails. workspace   :: HasCallStack+  => MonadCatch m   => MonadBaseControl IO m   => MonadResource m   => MonadTest m+  => H.MonadAssertion m   => FilePath   -> (FilePath -> m ())   -> m ()-workspace prefixPath f =-  withFrozenCallStack $-    bracket init fini $ \ws -> do-      H.annotate $ "Workspace: " <> ws-      H.evalIO $ IO.writeFile (ws </> "module") callerModuleName-      f ws+workspace prefixPath f = withFrozenCallStack $ do+  maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE"+  let policy = if IO.os == "mingw32" || maybeKeepWorkspace == Just "1"+              then PreserveWorkspace+              else CleanupOnSuccess+  workspaceWithConfig policy prefixPath f++-- | Create a workspace directory with explicit configuration for cleanup behavior.+--+-- The directory will have the supplied prefix but contain a generated random+-- suffix to prevent interference between tests+--+-- The directory will be deleted if the block succeeds, but left behind if+-- the block fails (unless policy is PreserveWorkspace, in which case it's always preserved).+workspaceWithConfig+  :: HasCallStack+  => MonadCatch m+  => MonadBaseControl IO m+  => MonadResource m+  => MonadTest m+  => H.MonadAssertion m+  => WorkspacePolicy  -- ^ Cleanup policy: PreserveWorkspace always preserves, CleanupOnSuccess deletes on success only+  -> FilePath+  -> (FilePath -> m ())+  -> m ()+workspaceWithConfig policy prefixPath f = withFrozenCallStack $ evalM $ do+  ws <- do+    systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory+    H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test"+  +  H.annotate $ "Workspace: " <> ws+  H.evalIO $ IO.writeFile (ws </> "module") callerModuleName+  +  result <- H.catchAssertion (fmap Right (f ws)) (return . Left)+  +  case result of+    Right _ -> do+      -- Test succeeded, clean up if policy allows+      case policy of+        CleanupOnSuccess -> removeWorkspaceRetries ws 20+        PreserveWorkspace -> pure ()+    Left assertion -> do+      -- Test failed, preserve workspace for debugging (unless policy forces cleanup)+      case policy of+        CleanupOnSuccess -> do+          H.annotate $ "Test failed, preserving workspace for debugging: " <> ws+        PreserveWorkspace -> pure ()+      -- Re-throw the original assertion failure+      H.throwAssertion assertion   where-    init = do-      systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory-      H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test"-    fini ws = do-      maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE"-      when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $-        removeWorkspaceRetries ws 20     removeWorkspaceRetries       :: MonadBaseControl IO m       => MonadResource m@@ -233,9 +279,11 @@ -- The 'prefix' argument should not contain directory delimeters. moduleWorkspace   :: HasCallStack+  => MonadCatch m   => MonadBaseControl IO m   => MonadResource m   => MonadTest m+  => H.MonadAssertion m   => String   -> (FilePath -> m ())   -> m ()

@@ -95,40 +95,24 @@   kickWatchdog watchdog   pure watchdog -getCallerLocation :: HasCallStack => String-getCallerLocation =-  case getCallStack callStack of-    (_funcName, _) : (_callerName, callerLoc) : _ ->-      srcLocFile callerLoc ++ ":" ++ show (srcLocStartLine callerLoc)-    _ -> "<no call stack>"- -- | Run watchdog in a loop in the current thread. Usually this function should be used with 'H.withAsync' -- to run it in the background.-runWatchdog-  :: HasCallStack-  => MonadBase IO m-  => Watchdog-  -> m ()-runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} =-  withFrozenCallStack $ liftBase $ do-    atomically (tryReadTChan kickChan) >>= \case-      Just PoisonPill ->-        -- deactivate watchdog-        pure ()-      Just (Kick timeout) -> do-        -- got a kick, wait for another period-        threadDelay $ timeout * 1_000_000-        runWatchdog w-      Nothing -> do-        -- we are out of scheduled timeouts, kill the monitored thread-        currentTime <- getCurrentTime-        liftIO $ appendFile "/tmp/watchdog.log" $ mconcat-          [ "Watchdog: killing thread " <> show watchedThreadId-          , " after " <> show (diffUTCTime currentTime startTime)-          , "at " <> getCallerLocation-          , "\n"-          ]-        throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime+runWatchdog :: MonadBase IO m+            => Watchdog+            -> m ()+runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} = liftBase $ do+  atomically (tryReadTChan kickChan) >>= \case+    Just PoisonPill ->+      -- deactivate watchdog+      pure ()+    Just (Kick timeout) -> do+      -- got a kick, wait for another period+      threadDelay $ timeout * 1_000_000+      runWatchdog w+    Nothing -> do+      -- we are out of scheduled timeouts, kill the monitored thread+      currentTime <- getCurrentTime+      throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime  -- | Watchdog command data WatchdogCommand

@@ -0,0 +1,257 @@+{-# LANGUAGE BangPatterns #-}+module Hedgehog.Extras.Test.WorkspaceSpec where++import Control.Applicative+import Control.Exception (throwIO)+import Control.Monad.IO.Class+import Data.Bool+import Data.Either+import Data.Function (($))+import Data.IORef+import Data.Maybe+import Data.Semigroup ((<>))+import GHC.Err (error)+import Hedgehog+import Hedgehog.Extras.Test.Base+import Hedgehog.Extras.Test.Unit+import System.IO.Error (userError)+import Text.Show++import qualified System.Directory as IO+import qualified Hedgehog.Internal.Property as H++-- | Test that workspace directories are removed on successful completion when keepWorkspace=False+tasty_workspace_removed_on_success_on_keepWorkspace_False :: UnitIO ()+tasty_workspace_removed_on_success_on_keepWorkspace_False = do+  workspacePath <- liftIO $ newIORef Nothing+  +  -- This workspace operation will succeed+  workspaceWithConfig CleanupOnSuccess "test-success" $ \ws -> do+    liftIO $ writeIORef workspacePath (Just ws)+    -- Successful operation - no failing assertions+    True === True+  +  -- After successful completion, workspace should be removed+  maybePath <- liftIO $ readIORef workspacePath+  case maybePath of+    Nothing -> do+      H.failWith Nothing "Expected workspace path to be recorded, but got Nothing"+    Just path -> do+      exists <- liftIO $ IO.doesDirectoryExist path+      annotate $ "Workspace path: " <> path+      annotate $ "Directory exists after success: " <> show exists+      -- On success, directory should be removed+      exists === False++-- | Test that workspace directories are preserved when assertion fails (keepWorkspace=False)+tasty_workspace_kept_on_assertion_on_keepWorkspace_False :: UnitIO ()+tasty_workspace_kept_on_assertion_on_keepWorkspace_False = do+  -- This test will intentionally trigger an assertion failure to verify+  -- that the workspace directory is preserved for debugging+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-failure" $ \ws -> do+    -- Store the workspace path so we can check it later+    liftIO $ writeIORef workspacePath (Just ws)+    -- Intentionally trigger assertion failure+    False === True+  +  case result of+    Left _ -> do+      -- Assertion failed as expected, now check if workspace was correctly preserved+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing -> do+          H.failWith Nothing "Expected workspace path to be recorded after failed assertion, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          -- Correct behavior: directory is preserved on assertion failure for debugging+          annotate $ "Workspace path: " <> path+          annotate $ "Directory exists: " <> show exists+          -- Directory should be preserved when assertion fails+          exists === True+          -- Clean up manually since assertion failed and we preserved it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      -- Assertion unexpectedly passed, this shouldn't happen+      annotate "Test was supposed to fail but didn't"+      failure++-- | Test that workspace directories are preserved when pure exception occurs (keepWorkspace=False)+tasty_workspace_kept_on_pure_exception_on_keepWorkspace_False :: UnitIO ()+tasty_workspace_kept_on_pure_exception_on_keepWorkspace_False = do+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-pure-exception" $ \ws -> do+    -- Store the workspace path so we can check it later+    liftIO $ writeIORef workspacePath (Just ws)+    -- Force evaluation of pure code that throws an exception+    let !_ = error "Pure code exception in workspace" :: ()+    pure ()+  +  case result of+    Left _ -> do+      -- Exception was thrown as expected, now check if workspace was correctly preserved+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing ->+          H.failWith Nothing "Expected workspace path to be recorded after pure exception, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          annotate $ "Workspace path after pure exception: " <> path+          annotate $ "Directory exists after pure exception: " <> show exists+          -- Correct behavior: directory is preserved when pure code throws exception+          exists === True+          -- Clean up manually since exception occurred and we preserved it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      -- Pure code unexpectedly didn't throw exception+      annotate "Pure code was supposed to throw exception but didn't"+      failure++-- | Test that workspace directories are preserved when IO exception occurs (keepWorkspace=False)+tasty_workspace_kept_on_io_exception_on_keepWorkspace_False :: UnitIO ()+tasty_workspace_kept_on_io_exception_on_keepWorkspace_False = do+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-io-exception" $ \ws -> do+    -- Store the workspace path so we can check it later+    liftIO $ writeIORef workspacePath (Just ws)+    -- Throw an IO exception within the workspace+    liftIO $ throwIO (userError "IO exception in workspace")+  +  case result of+    Left _ -> do+      -- Exception was thrown as expected, now check if workspace was correctly preserved+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing ->+          H.failWith Nothing "Expected workspace path to be recorded after IO exception, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          annotate $ "Workspace path after IO exception: " <> path+          annotate $ "Directory exists after IO exception: " <> show exists+          -- Correct behavior: directory is preserved when IO exception is thrown+          exists === True+          -- Clean up manually since exception occurred and we preserved it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      -- IO operation unexpectedly didn't throw exception+      annotate "IO operation was supposed to throw exception but didn't"+      failure++-- | Test that workspace directories are preserved on successful completion when keepWorkspace=True+tasty_workspace_kept_on_success_on_keepWorkspace_True :: UnitIO ()+tasty_workspace_kept_on_success_on_keepWorkspace_True = do+  workspacePath <- liftIO $ newIORef Nothing+  +  -- This workspace operation will succeed+  workspaceWithConfig PreserveWorkspace "test-keep-success" $ \ws -> do+    liftIO $ writeIORef workspacePath (Just ws)+    -- Successful operation - no failing assertions+    True === True+  +  -- After successful completion, workspace should still be preserved due to keepWorkspace=True+  maybePath <- liftIO $ readIORef workspacePath+  case maybePath of+    Nothing -> do+      H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True, but got Nothing"+    Just path -> do+      exists <- liftIO $ IO.doesDirectoryExist path+      annotate $ "Workspace path with keepWorkspace=True (success): " <> path+      annotate $ "Directory exists after success with keepWorkspace=True: " <> show exists+      -- With keepWorkspace=True, directory should be preserved even on success+      exists === True+      -- Clean up manually since we kept it+      liftIO $ IO.removeDirectoryRecursive path++-- | Test that workspace directories are preserved when assertion fails (keepWorkspace=True)+tasty_workspace_kept_on_assertion_on_keepWorkspace_True :: UnitIO ()+tasty_workspace_kept_on_assertion_on_keepWorkspace_True = do+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep" $ \ws -> do+    liftIO $ writeIORef workspacePath (Just ws)+    -- This assertion will fail, but workspace should be kept due to keepWorkspace=True+    False === True+  +  case result of+    Left _ -> do+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing -> do+          H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after failed assertion, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          annotate $ "Workspace path: " <> path+          annotate $ "Directory exists with keepWorkspace=True: " <> show exists+          -- With keepWorkspace=True, directory should always be preserved+          exists === True+          -- Clean up manually since we kept it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      annotate "Test was supposed to fail but didn't"+      failure++-- | Test that workspace directories are preserved when pure exception occurs (keepWorkspace=True)+tasty_workspace_kept_on_pure_exception_on_keepWorkspace_True :: UnitIO ()+tasty_workspace_kept_on_pure_exception_on_keepWorkspace_True = do+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep-pure-exception" $ \ws -> do+    -- Store the workspace path so we can check it later+    liftIO $ writeIORef workspacePath (Just ws)+    -- Force evaluation of pure code that throws an exception+    let !_ = error "Pure code exception with keepWorkspace=True" :: ()+    pure ()+  +  case result of+    Left _ -> do+      -- Exception was thrown as expected, now check if workspace was correctly preserved+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing -> do+          H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after pure exception, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          annotate $ "Workspace path after pure exception with keepWorkspace=True: " <> path+          annotate $ "Directory exists after pure exception with keepWorkspace=True: " <> show exists+          -- With keepWorkspace=True, directory should always be preserved+          exists === True+          -- Clean up manually since we kept it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      -- Pure code unexpectedly didn't throw exception+      annotate "Pure code was supposed to throw exception but didn't"+      failure++-- | Test that workspace directories are preserved when IO exception occurs (keepWorkspace=True)+tasty_workspace_kept_on_io_exception_on_keepWorkspace_True :: UnitIO ()+tasty_workspace_kept_on_io_exception_on_keepWorkspace_True = do+  workspacePath <- liftIO $ newIORef Nothing+  +  result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep-io-exception" $ \ws -> do+    -- Store the workspace path so we can check it later+    liftIO $ writeIORef workspacePath (Just ws)+    -- Throw an IO exception within the workspace+    liftIO $ throwIO (userError "IO exception with keepWorkspace=True")+  +  case result of+    Left _ -> do+      -- Exception was thrown as expected, now check if workspace was correctly preserved+      maybePath <- liftIO $ readIORef workspacePath+      case maybePath of+        Nothing -> do+          H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after IO exception, but got Nothing"+        Just path -> do+          exists <- liftIO $ IO.doesDirectoryExist path+          annotate $ "Workspace path after IO exception with keepWorkspace=True: " <> path+          annotate $ "Directory exists after IO exception with keepWorkspace=True: " <> show exists+          -- With keepWorkspace=True, directory should always be preserved+          exists === True+          -- Clean up manually since we kept it+          liftIO $ IO.removeDirectoryRecursive path+    Right _ -> do+      -- IO operation unexpectedly didn't throw exception+      annotate "IO operation was supposed to throw exception but didn't"+      failure