hedgehog-extras 0.6.5.1 → 0.10.1.0
raw patch · 20 files changed
Files
- CHANGELOG.md +369/−0
- LICENSE +1/−1
- NOTICE +1/−1
- README.md +73/−0
- hedgehog-extras.cabal +55/−40
- src/Hedgehog/Extras/Internal/Orphans.hs +25/−0
- src/Hedgehog/Extras/Internal/Plan.hs +17/−3
- src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc +0/−1
- src/Hedgehog/Extras/Test.hs +2/−0
- src/Hedgehog/Extras/Test/Base.hs +132/−47
- src/Hedgehog/Extras/Test/Concurrent.hs +2/−15
- src/Hedgehog/Extras/Test/Golden.hs +93/−19
- src/Hedgehog/Extras/Test/MonadAssertion.hs +45/−1
- src/Hedgehog/Extras/Test/Network.hs +1/−1
- src/Hedgehog/Extras/Test/Prim.hs +30/−0
- src/Hedgehog/Extras/Test/Process.hs +38/−19
- src/Hedgehog/Extras/Test/Unit.hs +55/−0
- test/Hedgehog/Extras/Test/TestExpectFailure.hs +37/−0
- test/Hedgehog/Extras/Test/UnitSpec.hs +13/−0
- test/Hedgehog/Extras/Test/WorkspaceSpec.hs +257/−0
+ CHANGELOG.md view
@@ -0,0 +1,369 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the [Package Versioning Policy (PVP)](https://pvp.haskell.org/).++## *Unreleased*++## [0.10.1.0] - 2025-11-03++### Changed+- Updated dependency on tar ^>= 0.7++## [0.10.0.0] - 2025-09-09++### Added+- Comprehensive CHANGELOG.md with complete project history+- Descriptive error messages for workspace test failures+- Sum type `WorkspacePolicy` to replace boolean blindness in `workspaceWithConfig`++### Changed+- `workspaceWithConfig` now uses `WorkspacePolicy` instead of `Bool` parameter+- Improved error messages in workspace tests with specific failure contexts+- Updated documentation to reference Package Versioning Policy (PVP) instead of SemVer++## [0.9.0.0] - 2025-06-24++### Changed+- Fix hanging problem with moduleWorkspace++### Added+- Workspace behavior tests and improved workspace API+- Directory dependency to test suite+- GHC 9.8 to GHA build matrix+- Claude IDE command templates for git operations++### Fixed +- Preserve workspace directories on test failure for debugging++## [0.8.0.0] - 2025-06-14++### Added+- New `testUnitIO` function++### Changed+- Make binDist search components recursively++### Removed+- Delete unused 'h' file++## [0.7.2.0] - 2025-06-07++### Added+- MonadAssertion instance to UnitIO++## [0.7.1.0] - 2025-06-06++### Added+- New assertion functions: `tryAssertion`, `assertFailure` and `assertFailure_`+- Re-export MonadBaseControl, bracket_ and bracket++## [0.7.0.0] - 2024-12-24++### Added+- Add `expectFailure` combinator+- Add `expectFailureWith` combinator and tests+- New UnitIO monad+- Thread safe golden test support+- Add diffVsGoldenFileExcludeTrace function+- Re-export Golden module from Test module+- Move orphans to own file++### Changed+- Generalize resulting monad in `expectFailure`+- Define `expectFailure` in terms of `expectFailureWith`+- Haskell CI: reduce number of shellcheck warnings+- Haskell CI: simplify build workflow, using cardano-cli's CI as guidance+- Loosen base version, to allow building with GHC 9.12+- Align haddock pipeline with Haskell pipeline+- Make the GitHub page workflow manually triggerable (workflow_dispatch)++### Fixed+- Fix haddock for `threadDelay`+- Fix haddock for `byDeadline` and `byDuration`+- Process: more informative error message when plan.json does not exist+- Detail: fix a warning in the Haskell pipeline++## [0.6.5.1] - 2024-11-20++### Changed+- Enforce UTF-8 encoding on reading and writing files++## [0.6.5.0] - 2024-07-27++### Added+- Make it build with ghc-9.10+- CI: Add ghc-9.10 to the build matrix++## [0.6.4.0] - 2024-05-16++### Added+- Add missing `HasCallStack` to writeGoldenFile, reportGoldenFileMissing, checkAgainstGoldenFile++### Changed+- Use removePathForcibly to remove directories++## [0.6.3.0] - 2024-05-03++### Added+- Add TestWatchdog and Tripwire with their tests+- Add test for asyncRegister_++### Changed+- Switch to using haskell-actions/setup+- Allow the port to be reused immediately after it is closed++## [0.6.2.0] - 2024-04-23++### Added+- New randomPort, reserveRandomPort and portInUse functions++### Changed+- Apply suggestions from code review+- Remove double space and add quotes++## [0.6.1.0] - 2024-02-13++### Added+- Add test to ensure a directory doesn't exist (`assertDirectoryMissing`)+- Add test to ensure a directory exists (`assertDirectoryExists`)++### Changed+- Allow reading files into any FromJSON+- Lower aeson bound+- #39 Lower bound on aeson+- Remove double printing of a command with its arguments++## [0.6.0.2] - 2024-01-29++### Fixed+- Fix missing call sites for short-circuiting functions++## [0.6.0.1] - 2024-01-23++### Fixed+- Fix missing stderr in failed commands++## [0.6.0.0] - 2024-01-16++### Added+- Add exec variant that allows a negative call (#55)+- Add concurrency abstractions from lifted-async and lifted-base++## [0.5.1.0] - 2024-01-04++### Added+- New RECREATE_GOLDEN_FILES which will causes golden tests to always create golden files replacing any existing golden files++### Changed+- Use MultiwayIf to simplify code++## [0.5.0.0] - 2023-11-23++### Added+- Add upper bound to tar++### Changed+- Make it build with ghc-9.8+- CI: Add ghc-9.8.1 to build matrix++### Removed+- Remove unused import++## [0.4.8.0] - 2023-11-21++### Changed+- Make it build with ghc-9.8+- CI: Add ghc-9.8.1 to build matrix++### Removed+- Remove unused import++## [0.4.7.1] - 2023-10-05++### Removed+- Remove dependency on hw-aeson++## [0.4.7.0] - 2023-06-27++### Added+- New indexM function++## [0.4.6.0] - 2023-06-19++### Added+- Add a way to log golden files+- Create new process groups for newly spawned processes (#42)++## [0.4.5.1] - 2023-05-10++### Fixed+- Fix empty case for diffVsGoldenFile++### Changed+- Put the golden-file filename in the failure message of diffVsGoldenFile++## [0.4.5.0] - 2023-05-09++### Added+- New downloadToFile function+- New downloadAndExtractGithubCommitToTemp++### Fixed+- Fix annotation for renameFile++## [0.4.4.1] - 2023-05-05++### Added+- Make it build with ghc-9.6+- CI: Add ghc-9.6.1 to build matrix++## [0.4.4.0] - 2023-05-04++### Added+- Add extra assertion functions, fix readM to show correct line (#33)++### Changed+- Tidy up imports++## [0.4.3.0] - 2023-05-03++### Added+- Add assertWithinTolerance and readM++## [0.4.2.0] - 2023-04-28++### Added+- New functions assertFileExists assertFileMissing assertFilesMissing+- New Hedgehog.Extras.Test.Golden module++### Removed+- Delete assertFileExists from Network module because it doesn't belong here++### Changed+- Use filepath operator (</>) over (<>) with "/"++## [0.4.1.0] - 2023-04-12++### Added+- New Ok versions of functions that require the operation to succeed+- New createSubdirectoryIfMissing function++### Changed+- Modify createDirectoryIfMissing to return its argument. createDirectoryIfMissing_ will be the version that returns ()++### Fixed+- Fix compile errors++## [0.4.0.1] - 2023-03-06++### Fixed+- Fix retry function++## [0.4.0.0] - 2023-03-06++### Changed+- Pass retry count to retry function++## [0.3.0.3] - 2023-01-09++### Fixed+- Fix moduleWorkspace++## [0.3.0.2] - 2023-01-07++### Added+- Generic instance++## [0.3.0.1] - 2023-01-07++### Changed+- Don't create an intermediate workspace directory+- Find the nearest plan.json+- Restructure cabal file+- Update copyright+- Copy over waitNamedPipe from Win32-network++### Removed+- Remove unused dependency on Win32-network++### Fixed+- Use setup-haskell action++## [0.3.0.0] - 2022-12-13++### Added+- Add errorMessage to argument of deadline functions+- getProjectBase: explore up the dir hierarchy to find cabal.project+- New fromJustM function+- Add .gitignore file++### Changed+- Update GH actions versions+- Relax bounds on aeson++## Early Versions (0.1.0.0 - 0.2.x)++### 2022+- New rewriteArrayElements function+- Update to support aeson >= 2.0.0 (#8)+- Replace waitByDeadlineX functions to byDeadlineX functions that trigger retries by assertion failure (#7)+- Add retry support (#6)++### 2021+- Module re-exports (#5)+- Generic error handling functions (#4)+- New exec, binFlex functions. New execConfigCwd field (#3)+- Add support for YAML (#2)+- Force evaluation of string for cat (#1)+- Setup Github Actions CI+- Downgrade cabal file version to 2.4 because 3.0 is incompatible with stack+- Drop support for ghc-8.6.5+- Harmonise component versions and remove redundant conditionals+- Import cardano-submit-api from cardano-rest repo+- Test support for running CLI commands with environment variables+- Run golden tests at the value level rather than the text level+- Update copyright to 2021+- Cabal 3.4 in Github Actions++### 2020+- New copyRewriteJsonFile function to work around permissioning issues on Hydra+- Remove redundant imports+- General chairman test code quality changes+- Chairman test running on Windows and Linux+- Report all log files on any test failure+- Bump versions to 1.21.0 and update the change logs+- Run byron-shelley testnet+- Run a chairman process per node+- Increase test code re-use by moving test support code into separate common hedgehog-extras library++[Unreleased]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.10.0.0...HEAD+[0.10.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.9.0.0...v0.10.0.0+[0.9.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.8.0.0...v0.9.0.0+[0.8.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.7.2.0...v0.8.0.0+[0.7.2.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.7.1.0...v0.7.2.0+[0.7.1.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.7.0.0...v0.7.1.0+[0.7.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.5.1...v0.7.0.0+[0.6.5.1]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.5.0...v0.6.5.1+[0.6.5.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.4.0...v0.6.5.0+[0.6.4.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.3.0...v0.6.4.0+[0.6.3.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.2.0...v0.6.3.0+[0.6.2.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.1.0...v0.6.2.0+[0.6.1.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.0.2...v0.6.1.0+[0.6.0.2]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.0.1...v0.6.0.2+[0.6.0.1]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.6.0.0...v0.6.0.1+[0.6.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.5.1.0...v0.6.0.0+[0.5.1.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.5.0.0...v0.5.1.0+[0.5.0.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.8.0...v0.5.0.0+[0.4.8.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.7.1...v0.4.8.0+[0.4.7.1]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.7.0...v0.4.7.1+[0.4.7.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.6.0...v0.4.7.0+[0.4.6.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.5.1...v0.4.6.0+[0.4.5.1]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.5.0...v0.4.5.1+[0.4.5.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.4.1...v0.4.5.0+[0.4.4.1]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.4.0...v0.4.4.1+[0.4.4.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.3.0...v0.4.4.0+[0.4.3.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.4.2.0...v0.4.3.0+[0.4.2.0]: https://github.com/input-output-hk/hedgehog-extras/compare/v0.3.0.2...v0.4.2.0
LICENSE view
@@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright 2021 Input Output (Hong Kong) Ltd.+ Copyright 2025 Input Output (Hong Kong) Ltd. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
NOTICE view
@@ -1,4 +1,4 @@-Copyright 2021-2023 Input Output (Hong Kong) Ltd.+Copyright 2021-2025 Input Output (Hong Kong) Ltd. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
+ README.md view
@@ -0,0 +1,73 @@+# hedgehog-extras+++[](https://github.com/input-output-hk/hedgehog-extras/actions/workflows/haskell.yml)++Supplemental library for hedgehog.++## About++This library provides additional utilities and helpers for working with the [Hedgehog](https://hackage.haskell.org/package/hedgehog) property-based testing framework.++## Installation++Add to your `package.yaml` or `.cabal` file:++```yaml+dependencies:+ - hedgehog-extras+```++## Releasing++This project has a hybrid automated/manual release flow:++### Automatic Tagging (on main branch)++When you push a version bump to main, CI automatically creates a git tag:++1. Update [CHANGELOG.md] to include the *Unreleased* changes in the changelog for the new version.+1. Update `hedgehog-extras.cabal` and set `version:` to the new version+1. Commit and push to main: `git commit -m "Bump version to X.Y.Z.W" && git push origin main`+1. CI automatically creates and pushes tag `vX.Y.Z.W`+1. The release workflow then runs automatically++### Manual Tagging++Alternatively, you can manually create and push tags:++1. Update `hedgehog-extras.cabal` with the new version+2. Commit changes: `git commit -m "Release X.Y.Z.W"`+3. Create tag: `git tag -a vX.Y.Z.W -m "Release version X.Y.Z.W"`+4. Push both: `git push origin main && git push origin vX.Y.Z.W`++### What Happens Automatically++When a tag is pushed (either automatically or manually), GitHub Actions:+- Runs the full test suite across all platforms and GHC versions+- Validates the cabal project with `cabal check`+- Creates source distributions (`cabal v2-sdist`)+- **Uploads to Hackage as a candidate** (requires `HACKAGE_USER` and `HACKAGE_PASS` secrets)+- Generates release notes from git commit history+- Creates a GitHub Release++### Publishing the Hackage Candidate++After the workflow completes:+1. Check the candidate at https://hackage.haskell.org/package/hedgehog-extras/candidates+2. Test the candidate package+3. When ready, publish it from the Hackage candidate page++### Notes++- The workflow is defined in `.github/workflows/haskell.yml`+- Packages are uploaded as **candidates**, not published releases+- Release notes are auto-generated from git commits since the last tag+- The workflow requires `HACKAGE_USER` and `HACKAGE_PASS` repository secrets+- Workflow requires `contents: write` permission (already configured)++## License++Copyright 2025 Input Output Global, Inc.++Licensed under the Apache License, Version 2.0. See [LICENSE](LICENSE) for details.
hedgehog-extras.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras-version: 0.6.5.1+version: 0.10.1.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test@@ -11,52 +11,55 @@ license-files: LICENSE NOTICE build-type: Simple-+extra-doc-files: CHANGELOG.md+ README.md source-repository head type: git location: https://github.com/input-output-hk/hedgehog-extras -common aeson { build-depends: aeson >= 2.0.0.0 }-common aeson-pretty { build-depends: aeson-pretty >= 0.8.5 }-common async { build-depends: async }-common base { build-depends: base >= 4.12 && < 4.21 }-common bytestring { build-depends: bytestring }-common deepseq { build-depends: deepseq }-common Diff { build-depends: Diff }-common directory { build-depends: directory }-common exceptions { build-depends: exceptions }-common filepath { build-depends: filepath }-common hedgehog { build-depends: hedgehog }-common hedgehog-quickcheck { build-depends: hedgehog-quickcheck }-common http-conduit { build-depends: http-conduit }-common lifted-async { build-depends: lifted-async }-common lifted-base { build-depends: lifted-base }-common mmorph { build-depends: mmorph }-common monad-control { build-depends: monad-control }-common mtl { build-depends: mtl }-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 }-common tasty-hedgehog { build-depends: tasty-hedgehog }-common tasty-quickcheck { build-depends: tasty-quickcheck }-common temporary { build-depends: temporary }-common text { build-depends: text }-common time { build-depends: time >= 1.9.1 }-common transformers { build-depends: transformers }-common transformers-base { build-depends: transformers-base }-common unliftio { build-depends: unliftio }-common yaml { build-depends: yaml }-common zlib { build-depends: zlib }+common aeson { build-depends: aeson >= 2.0.0.0 && < 2.3 }+common aeson-pretty { build-depends: aeson-pretty >= 0.8.5 && < 0.9 }+common async { build-depends: async < 2.3 }+common base { build-depends: base >= 4.12 && < 4.22 }+common bytestring { build-depends: bytestring < 0.13 }+common containers { build-depends: containers < 0.9 }+common deepseq { build-depends: deepseq < 1.6 }+common Diff { build-depends: Diff < 1.1 }+common directory { build-depends: directory < 1.4 }+common exceptions { build-depends: exceptions < 0.11 }+common filepath { build-depends: filepath < 1.6 }+common hedgehog { build-depends: hedgehog < 1.8 }+common hedgehog-quickcheck { build-depends: hedgehog-quickcheck < 0.2 }+common http-conduit { build-depends: http-conduit < 2.4 }+common lifted-async { build-depends: lifted-async < 0.12 }+common lifted-base { build-depends: lifted-base < 0.3 }+common mmorph { build-depends: mmorph < 1.3 }+common monad-control { build-depends: monad-control < 1.1 }+common mtl { build-depends: mtl < 2.4 }+common network { build-depends: network < 3.3 }+common process { build-depends: process < 1.7 }+common resourcet { build-depends: resourcet < 1.4 }+common retry { build-depends: retry >= 0.9 && < 0.10 }+common stm { build-depends: stm < 2.6 }+common tar { build-depends: tar >= 0.7 && < 0.8 }+common tasty { build-depends: tasty < 1.6 }+common tasty-discover { build-depends: tasty-discover >= 5.0.2 && < 5.3 }+common tasty-hedgehog { build-depends: tasty-hedgehog < 1.5 }+common tasty-quickcheck { build-depends: tasty-quickcheck < 0.11 }+common temporary { build-depends: temporary < 1.4 }+common text { build-depends: text < 2.2 }+common time { build-depends: time >= 1.9.1 && < 1.16 }+common transformers { build-depends: transformers < 0.7 }+common transformers-base { build-depends: transformers-base < 0.5 }+common unliftio { build-depends: unliftio < 0.3 }+common yaml { build-depends: yaml < 0.12 }+common zlib { build-depends: zlib < 0.8 } common hedgehog-extras { build-depends: hedgehog-extras } common Win32 if os(windows)- build-depends: Win32 >= 2.5.4.1+ build-depends: Win32 >= 2.5.4.1 && < 2.15 common project-config default-language: Haskell2010@@ -75,6 +78,7 @@ aeson, async, bytestring,+ containers, deepseq, Diff, directory,@@ -84,15 +88,17 @@ http-conduit, lifted-async, lifted-base,- monad-control, mmorph,+ monad-control, mtl, network, process, resourcet,- retry, stm, tar,+ tasty,+ tasty-discover,+ tasty-hedgehog, temporary, text, time,@@ -110,6 +116,7 @@ exposed-modules: Hedgehog.Extras Hedgehog.Extras.Aeson Hedgehog.Extras.Internal.Cli+ Hedgehog.Extras.Internal.Orphans Hedgehog.Extras.Internal.Plan Hedgehog.Extras.Internal.Test.Integration Hedgehog.Extras.Stock@@ -132,18 +139,23 @@ Hedgehog.Extras.Test.Golden Hedgehog.Extras.Test.MonadAssertion Hedgehog.Extras.Test.Network+ Hedgehog.Extras.Test.Prim Hedgehog.Extras.Test.Process Hedgehog.Extras.Test.TestWatchdog Hedgehog.Extras.Test.Tripwire+ Hedgehog.Extras.Test.Unit test-suite hedgehog-extras-test import: base, project-config,+ directory, hedgehog, hedgehog-extras,+ lifted-base, network, process, resourcet, tasty,+ tasty-discover, tasty-hedgehog, transformers, time,@@ -152,7 +164,10 @@ type: exitcode-stdio-1.0 other-modules: Hedgehog.Extras.Stock.IO.Network.PortSpec+ 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"
+ src/Hedgehog/Extras/Internal/Orphans.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Hedgehog.Extras.Internal.Orphans () where++import Control.Applicative+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import System.IO (IO)+import UnliftIO qualified++instance MonadBase IO (ResourceT IO) where+ liftBase = liftIO++instance MonadBaseControl IO (ResourceT IO) where+ type StM (ResourceT IO) a = a+ liftBaseWith = UnliftIO.withRunInIO+ restoreM = pure+
src/Hedgehog/Extras/Internal/Plan.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-} module Hedgehog.Extras.Internal.Plan ( Plan(..)@@ -7,7 +9,10 @@ ) where import Control.Applicative+import Control.Monad import Data.Aeson+import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as M import Data.Eq import Data.Function import Data.Maybe@@ -18,6 +23,7 @@ data Component = Component { componentName :: Maybe Text , binFile :: Maybe Text+ , components :: [Component] } deriving (Generic, Eq, Show) @@ -31,6 +37,14 @@ <$> v .: "install-plan" instance FromJSON Component where- parseJSON = withObject "Plan" $ \v -> Component- <$> v .:? "component-name"- <*> v .:? "bin-file"+ parseJSON = withObject "Plan" $ \v -> do+ componentName <- v .:? "component-name"+ binFile <- v .:? "bin-file"+ componentsTuples <- join . maybeToList . fmap M.toAscList <$> v .:? "components"+ -- sub-components are an object with components name as a key+ components <- forM componentsTuples $ \(subComponentName, subComponent) ->+ parseJSON $+ A.Object $+ M.insert "component-name" (toJSON subComponentName) subComponent+ pure Component{..}+
src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc view
@@ -23,7 +23,6 @@ import Data.String (String) import Foreign.C.String (withCString) import System.IO (IO)-import System.Win32.File import System.Win32.Types hiding (try) -- | Timeout in milliseconds.
src/Hedgehog/Extras/Test.hs view
@@ -5,8 +5,10 @@ import Hedgehog.Extras.Test.Base as X import Hedgehog.Extras.Test.Concurrent as X import Hedgehog.Extras.Test.File as X+import Hedgehog.Extras.Test.Golden as X import Hedgehog.Extras.Test.MonadAssertion as X import Hedgehog.Extras.Test.Network as X import Hedgehog.Extras.Test.Process as X import Hedgehog.Extras.Test.TestWatchdog as X import Hedgehog.Extras.Test.Tripwire as X+import Hedgehog.Extras.Test.Unit as X
src/Hedgehog/Extras/Test/Base.hs view
@@ -6,6 +6,8 @@ ( propertyOnce , workspace+ , workspaceWithConfig+ , WorkspacePolicy(..) , moduleWorkspace , note@@ -60,6 +62,11 @@ , failWithCustom , failMessage+ , expectFailure+ , expectFailureWith+ , tryAssertion+ , assertFailure+ , assertFailure_ , assertByDeadlineM , assertByDeadlineIO@@ -85,36 +92,41 @@ , retry , retry'++ , MonadBaseControl+ , bracket+ , bracket_ ) where import Control.Applicative (Applicative (..))-import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when)+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) import Control.Monad.Catch (MonadCatch) import Control.Monad.Morph (hoist) import Control.Monad.Reader (MonadIO (..), MonadReader (ask))-import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register, runResourceT)+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 ((<$>)) import Data.Int (Int) import Data.Maybe (Maybe (..), listToMaybe, maybe)-import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Data.String (String) import Data.Time.Clock (NominalDiffTime, UTCTime) 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)-import Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)-import Hedgehog.Internal.Property (Diff, liftTest, mkTest)+import Hedgehog.Extras.Test.MonadAssertion+import Hedgehog.Extras.Test.Prim import Hedgehog.Internal.Source (getCaller) import Prelude (Num (..), Ord (..), floor) import System.FilePath ((</>))@@ -123,10 +135,7 @@ 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@@ -140,21 +149,35 @@ 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 propertyOnce = H.withTests 1 . H.property . hoist runResourceT . hoist H.runIntegrationReaderT --- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.-failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a-failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)+-- | Invert the behavior of a property: success becomes failure and vice versa.+expectFailure :: (MonadTest m, MonadIO m, HasCallStack) => H.TestT IO a -> m ()+expectFailure = GHC.withFrozenCallStack $ expectFailureWith (pure . const ()) --- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.-failMessage :: MonadTest m => CallStack -> String -> m a-failMessage cs = failWithCustom cs Nothing+-- | Invert the behavior of a property: success becomes failure and vice versa.+-- This function behaves like 'expectFailure' but it allows to check the failure+-- is as expected. The function takes a 'Failure' and should itself be a test+-- that fails if the failure is not as expected.+expectFailureWith :: (MonadTest m, MonadIO m, HasCallStack) => (H.Failure -> m ()) -> H.TestT IO b -> m ()+expectFailureWith checkFailure prop = GHC.withFrozenCallStack $ do+ (res, _) <- H.evalIO $ H.runTestT prop+ case res of+ Left e -> checkFailure e+ _ -> H.failWith Nothing "Expected the test to fail but it passed" -- Property pased but we expected a failure -- | Create a workspace directory which will exist for at least the duration of -- the supplied block.@@ -165,32 +188,85 @@ -- The directory will be deleted if the block succeeds, but left behind if -- the block fails. workspace- :: MonadTest m- => HasCallStack+ :: HasCallStack+ => MonadCatch m+ => MonadBaseControl IO m => MonadResource m+ => MonadTest m+ => H.MonadAssertion 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"+ 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- f ws- when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do- -- 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+ + 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+ removeWorkspaceRetries+ :: MonadBaseControl IO m+ => MonadResource m+ => MonadTest m+ => FilePath+ -> Int+ -> m ()+ removeWorkspaceRetries ws retries = GHC.withFrozenCallStack $ do+ result <- try (liftIO (IO.removePathForcibly ws))+ case result of+ Right () -> return ()+ Left (_ :: IOException) -> do+ if retries > 0+ then do+ liftIO (IO.threadDelay 100000) -- wait 100ms before retrying+ removeWorkspaceRetries ws (retries - 1)+ else do+ failMessage GHC.callStack "Failed to remove workspace directory after multiple attempts" + -- | Create a workspace directory which will exist for at least the duration of -- the supplied block. --@@ -201,7 +277,16 @@ -- the block fails. -- -- The 'prefix' argument should not contain directory delimeters.-moduleWorkspace :: (MonadTest m, MonadResource m, HasCallStack) => String -> (FilePath -> m ()) -> m ()+moduleWorkspace+ :: HasCallStack+ => MonadCatch m+ => MonadBaseControl IO m+ => MonadResource m+ => MonadTest m+ => H.MonadAssertion m+ => 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@@ -482,13 +567,13 @@ jsonErrorFailM :: (MonadTest m, HasCallStack) => m (Result a) -> m a jsonErrorFailM f = GHC.withFrozenCallStack $ f >>= jsonErrorFail --- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the deadline expires. -- -- Expiration of the deadline results in an assertion failure byDeadlineIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> IO a -> m a byDeadlineIO period deadline errorMessage f = GHC.withFrozenCallStack $ byDeadlineM period deadline errorMessage $ liftIO f --- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the deadline expires. -- -- Expiration of the deadline results in an assertion failure byDeadlineM :: forall m a. (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> m a -> m a@@ -510,13 +595,13 @@ void $ failMessage GHC.callStack $ "Condition not met by deadline: " <> errorMessage H.throwAssertion e --- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the duration expires. -- -- Expiration of the duration results in an assertion failure byDurationIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> IO a -> m a byDurationIO period duration errorMessage f = GHC.withFrozenCallStack $ byDurationM period duration errorMessage $ liftIO f --- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+-- | Run the operation 'f' once per 'period' until it returns 'True' or the duration expires. -- -- Expiration of the duration results in an assertion failure byDurationM :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> m a -> m a@@ -529,8 +614,8 @@ -- Expiration of the deadline results in an assertion failure assertByDeadlineIO :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m () assertByDeadlineIO deadline f = GHC.withFrozenCallStack $ do- success <- liftIO f- unless success $ do+ succeeded <- liftIO f+ unless succeeded $ do currentTime <- liftIO DTC.getCurrentTime if currentTime < deadline then do@@ -545,8 +630,8 @@ -- Expiration of the deadline results in an assertion failure assertByDeadlineM :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m () assertByDeadlineM deadline f = GHC.withFrozenCallStack $ do- success <- f- unless success $ do+ succeeded <- f+ unless succeeded $ do currentTime <- liftIO DTC.getCurrentTime if currentTime < deadline then do@@ -564,8 +649,8 @@ -- Expiration of the deadline results in an assertion failure assertByDeadlineIOFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m () -> m () assertByDeadlineIOFinally deadline f g = GHC.withFrozenCallStack $ do- success <- liftIO f- unless success $ do+ succeeded <- liftIO f+ unless succeeded $ do currentTime <- liftIO DTC.getCurrentTime if currentTime < deadline then do@@ -584,8 +669,8 @@ -- Expiration of the deadline results in an assertion failure assertByDeadlineMFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m () -> m () assertByDeadlineMFinally deadline f g = GHC.withFrozenCallStack $ do- success <- f- unless success $ do+ succeeded <- f+ unless succeeded $ do currentTime <- liftIO DTC.getCurrentTime if currentTime < deadline then do
src/Hedgehog/Extras/Test/Concurrent.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wno-orphans #-} - {- | This modules provides concurrency abstractions for hedgehog tests. Using "lifted-base" one can execute expensive test actions concurrently. @@ -73,20 +71,17 @@ , module System.Timeout.Lifted ) where -import Control.Applicative import Control.Concurrent.Async.Lifted import qualified Control.Concurrent.Lifted as IO import Control.Concurrent.MVar.Lifted-import Control.Monad.Base import Control.Monad.IO.Class-import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.Function import Data.Int import qualified GHC.Stack as GHC import System.IO (IO) import System.Timeout.Lifted-import qualified UnliftIO+import Hedgehog.Extras.Internal.Orphans () import Control.Monad import Control.Monad.Catch (MonadCatch)@@ -94,7 +89,7 @@ import Hedgehog import qualified Hedgehog as H --- | Delay the thread by 'n' milliseconds.+-- | Delay the thread by 'n' microseconds. threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m () threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n @@ -109,11 +104,3 @@ where cleanUp :: Async a -> IO () cleanUp a = cancel a >> void (link a)--instance MonadBase IO (ResourceT IO) where- liftBase = liftIO--instance MonadBaseControl IO (ResourceT IO) where- type StM (ResourceT IO) a = a- liftBaseWith = UnliftIO.withRunInIO- restoreM = pure
src/Hedgehog/Extras/Test/Golden.hs view
@@ -1,44 +1,59 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-} module Hedgehog.Extras.Test.Golden ( diffVsGoldenFile, diffFileVsGoldenFile,+ diffVsGoldenFileExcludeTrace, ) where import Control.Applicative-import Control.Exception (bracket_)+import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Control import Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff) import Data.Algorithm.DiffOutput (ppDiff) import Data.Bool import Data.Eq import Data.Function+import Data.Map (Map) import Data.Maybe import Data.Monoid import Data.String import GHC.Stack (HasCallStack, callStack) import Hedgehog (MonadTest) import Hedgehog.Extras.Test.Base (failMessage)+import System.Directory (canonicalizePath, getCurrentDirectory) import System.FilePath (takeDirectory)+import System.FilePath.Posix (makeRelative) import System.IO (FilePath, IO) import qualified Control.Concurrent.QSem as IO+import qualified Control.Concurrent.STM as STM import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Text as Text import qualified GHC.Stack as GHC-import qualified Hedgehog.Extras.Test as H+import qualified Hedgehog.Extras.Test.Base as H+import qualified Hedgehog.Extras.Test.File as H import qualified Hedgehog.Internal.Property as H import qualified System.Directory as IO import qualified System.Environment as IO import qualified System.IO as IO import qualified System.IO.Unsafe as IO -sem :: IO.QSem-sem = IO.unsafePerformIO $ IO.newQSem 1-{-# NOINLINE sem #-}--semBracket :: IO a -> IO a-semBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)+semBracket :: ()+ => MonadIO m+ => MonadBaseControl IO m+ => IO.QSem+ -> m a+ -> m a+semBracket sem =+ bracket_+ (liftIO (IO.waitQSem sem))+ (liftIO (IO.signalQSem sem)) -- | The file to log whenever a golden file is referenced. mGoldenFileLogFile :: Maybe FilePath@@ -103,6 +118,23 @@ ] failMessage callStack $ ppDiff difference +tvGoldenFileSems :: STM.TVar (Map FilePath IO.QSem)+tvGoldenFileSems = IO.unsafePerformIO $ STM.newTVarIO mempty+{-# NOINLINE tvGoldenFileSems #-}++getGoldenFileSem :: FilePath -> IO IO.QSem+getGoldenFileSem filePath = do+ newSem <- IO.newQSem 1++ STM.atomically $ do+ sems <- STM.readTVar tvGoldenFileSems+ case Map.lookup filePath sems of+ Just sem -> return sem+ Nothing -> do+ let newGoldenFileSems = Map.insert filePath newSem sems+ STM.writeTVar tvGoldenFileSems newGoldenFileSems+ return newSem+ -- | Diff contents against the golden file. If CREATE_GOLDEN_FILES environment is -- set to "1", then should the golden file not exist it would be created. If -- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would@@ -120,22 +152,33 @@ -- each input. diffVsGoldenFile :: HasCallStack- => (MonadIO m, MonadTest m)+ => MonadIO m+ => MonadBaseControl IO m+ => MonadTest m => String -- ^ Actual content -> FilePath -- ^ Reference file -> m ()-diffVsGoldenFile actualContent goldenFile = GHC.withFrozenCallStack $ do- forM_ mGoldenFileLogFile $ \logFile ->- liftIO $ semBracket $ IO.appendFile logFile $ goldenFile <> "\n"+diffVsGoldenFile actualContent goldenFile =+ GHC.withFrozenCallStack $ do+ realPath <- liftIO $ canonicalizePath goldenFile+ cwd <- liftIO getCurrentDirectory - fileExists <- liftIO $ IO.doesFileExist goldenFile+ let relativeGoldenPath = makeRelative cwd realPath - if- | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent- | fileExists -> checkAgainstGoldenFile goldenFile actualLines- | createGoldenFiles -> writeGoldenFile goldenFile actualContent- | otherwise -> reportGoldenFileMissing goldenFile+ sem <- liftIO $ getGoldenFileSem relativeGoldenPath + GHC.withFrozenCallStack $ semBracket sem $ do+ forM_ mGoldenFileLogFile $ \logFile ->+ liftIO $ IO.appendFile logFile $ goldenFile <> "\n"++ fileExists <- liftIO $ IO.doesFileExist goldenFile++ if+ | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent+ | fileExists -> checkAgainstGoldenFile goldenFile actualLines+ | createGoldenFiles -> writeGoldenFile goldenFile actualContent+ | otherwise -> reportGoldenFileMissing goldenFile+ where actualLines = List.lines actualContent @@ -152,10 +195,41 @@ -- files are never overwritten. diffFileVsGoldenFile :: HasCallStack- => (MonadIO m, MonadTest m)+ => MonadBaseControl IO m+ => MonadIO m+ => MonadTest m => FilePath -- ^ Actual file -> FilePath -- ^ Reference file -> m () diffFileVsGoldenFile actualFile referenceFile = GHC.withFrozenCallStack $ do contents <- H.readFile actualFile diffVsGoldenFile contents referenceFile++-- | Diff contents against the golden file, excluding the trace. If CREATE_GOLDEN_FILES environment is+-- set to "1", then should the golden file not exist it would be created. If+-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would+-- be recreated. If GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file+-- path will be logged to the specified file.+--+-- Set the environment variable when you intend to generate or re-generate the golden+-- file for example when running the test for the first time or if the golden file+-- genuinely needs to change.+--+-- To re-generate a golden file you must also delete the golden file because golden+-- files are never overwritten.+diffVsGoldenFileExcludeTrace+ :: MonadBaseControl IO m+ => MonadIO m+ => MonadTest m+ => HasCallStack+ => String -> FilePath -> m ()+diffVsGoldenFileExcludeTrace inputString refFile =+ GHC.withFrozenCallStack $ do+ case List.uncons $ Text.splitOn "CallStack" $ Text.pack inputString of+ Just (stackTraceRemoved, _) -> diffVsGoldenFile (Text.unpack stackTraceRemoved) refFile+ Nothing ->+ H.failWith Nothing $+ List.unlines+ [ "Input string was empty"+ , "Reference file: " <> refFile+ ]
src/Hedgehog/Extras/Test/MonadAssertion.hs view
@@ -3,17 +3,27 @@ module Hedgehog.Extras.Test.MonadAssertion ( MonadAssertion(..)+ , assertFailure+ , assertFailure_+ , tryAssertion ) where +import Control.Applicative (Applicative(..)) import Control.Monad import Control.Monad.Trans.Class import Data.Either import Data.Function-import Data.Monoid (mempty)+import Data.Functor ((<$>))+import Data.Monoid+import GHC.Stack (HasCallStack)+import Hedgehog (MonadTest(..))+import Hedgehog.Extras.Test.Prim+import Text.Show (Show(..)) import qualified Control.Monad.Trans.Except as E import qualified Control.Monad.Trans.Resource as IO import qualified Control.Monad.Trans.Resource.Internal as IO+import qualified GHC.Stack as GHC import qualified Hedgehog as H import qualified Hedgehog.Internal.Property as H @@ -30,3 +40,37 @@ catchAssertion r h = IO.ResourceT $ \i -> IO.unResourceT r i `catchAssertion` \e -> IO.unResourceT (h e) i deriving instance Monad m => MonadAssertion (H.PropertyT m)++-- | Attempt to run a function that may assert, returning either a failure or the result of the assertion.+tryAssertion :: ()+ => MonadAssertion m+ => m a+ -> m (Either H.Failure a)+tryAssertion m =+ catchAssertion (Right <$> m) (pure . Left)++-- | Run the given action and succeed if the action fails, but fail if it succeeds.+assertFailure :: ()+ => HasCallStack+ => Show a+ => MonadAssertion m+ => MonadTest m+ => m a+ -> m H.Failure+assertFailure f = do+ result <- tryAssertion f+ case result of+ Left e -> pure e+ Right a -> failMessage GHC.callStack $ show a++-- | Run the given action and succeed if the action fails, but fail if it succeeds.+assertFailure_ :: ()+ => HasCallStack+ => Show a+ => MonadAssertion m+ => MonadTest m+ => m a+ -> m ()+assertFailure_ f =+ GHC.withFrozenCallStack $+ void $ assertFailure f
src/Hedgehog/Extras/Test/Network.hs view
@@ -86,7 +86,7 @@ H.note_ $ "Downloading " <> url <> " to " <> path H.evalIO $ HTTP.simpleHttp url >>= LBS.writeFile path -tarErrors :: TAR.GenEntries tarPath linkTarget e -> [e]+tarErrors :: TAR.GenEntries content tarPath linkTarget e -> [e] tarErrors entries = TAR.foldEntries (flip const) id (:) entries [] -- | Download a github commit to a temporary directory, extract it and return the path to the extracted directory.
+ src/Hedgehog/Extras/Test/Prim.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Extras.Test.Prim+ ( failWithCustom+ , failMessage++ ) where++import Data.Either (Either (..))+import Data.Function+import Data.Maybe+import Data.Monoid (Monoid (..))+import Data.String (String)+import GHC.Stack+import Hedgehog (MonadTest)+import Hedgehog.Internal.Property (Diff, liftTest, mkTest)+import Hedgehog.Internal.Source (getCaller)++import qualified Hedgehog.Internal.Property as H++{- HLINT ignore "Reduce duplication" -}++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a+failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failMessage :: MonadTest m => CallStack -> String -> m a+failMessage cs = failWithCustom cs Nothing
src/Hedgehog/Extras/Test/Process.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -25,20 +27,21 @@ , defaultExecConfig ) where -import Control.Monad (Monad (..), MonadFail (fail), void, unless)+import Control.Applicative (pure, (<|>))+import Control.Monad (Monad (..), MonadFail (fail), unless, void) import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) import Data.Aeson (eitherDecode)-import Data.Bool (Bool (..))+import Data.Bool (Bool (True), otherwise) import Data.Either (Either (..)) import Data.Eq (Eq (..))-import Data.Function (($), (&), (.))+import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (Maybe (..)) import Data.Monoid (Last (..), mempty, (<>))-import Data.String (String)+import Data.String (IsString (..), String) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Hedgehog (MonadTest)@@ -55,6 +58,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L+import Data.Text (Text) import qualified Data.Text as T import qualified GHC.Stack as GHC import qualified Hedgehog as H@@ -284,7 +288,7 @@ maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv case maybeEnvBin of Just envBin -> return envBin- Nothing -> binDist pkg+ Nothing -> binDist pkg binaryEnv -- | 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@@ -294,25 +298,40 @@ :: (HasCallStack, MonadTest m, MonadIO m) => String -- ^ Package name+ -> String+ -- ^ Environment variable pointing to the binary to run (used for error messages only) -> m FilePath -- ^ Path to executable-binDist pkg = do+binDist pkg binaryEnv = do doesPlanExist <- liftIO $ IO.doesFileExist planJsonFile unless doesPlanExist $- error $ "Could not find plan.json in the path: " <> planJsonFile- contents <- H.evalIO . LBS.readFile $ planJsonFile+ error $ "Could not find plan.json in the path: "+ <> planJsonFile+ <> ". Please run \"cabal build "+ <> pkg+ <> "\" if you are working with sources. Otherwise define "+ <> binaryEnv+ <> " and have it point to the executable you want." - 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\" 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- Nothing -> False+ Plan{installPlan} <- eitherDecode <$> H.evalIO (LBS.readFile planJsonFile)+ >>= \case+ Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message+ Right plan -> pure plan++ let componentName = "exe:" <> fromString pkg+ case findComponent componentName installPlan of+ Just Component{binFile=Just binFilePath} -> pure . addExeSuffix $ T.unpack binFilePath+ Just component@Component{binFile=Nothing} ->+ error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile+ Nothing ->+ error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile+ where+ findComponent :: Text -> [Component] -> Maybe Component+ findComponent _ [] = Nothing+ findComponent needle (c@Component{componentName, components}:topLevelComponents)+ | componentName == Just needle = Just c+ | otherwise = findComponent needle topLevelComponents <|> findComponent needle components+ -- | Create a 'CreateProcess' describing how to start a process given the Cabal package name -- corresponding to the executable, an environment variable pointing to the executable,
+ src/Hedgehog/Extras/Test/Unit.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Hedgehog.Extras.Test.Unit+ ( UnitIO(..)+ , testUnitIO+ ) where++import Control.Monad.Base+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Morph+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Resource+import Data.Maybe+import Data.Monoid+import Hedgehog+import Hedgehog.Extras.Internal.Orphans ()+import Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)+import Hedgehog.Internal.Property qualified as H+import Prelude+import Test.Tasty.Discover+import Test.Tasty.Discover.TastyInfo qualified as TastyInfo+import Test.Tasty.Hedgehog (testProperty)++import qualified Test.Tasty as T++newtype UnitIO a = UnitIO { runTestIO :: TestT (ResourceT IO) a }+ deriving newtype (Applicative)+ deriving newtype (Functor)+ deriving newtype (Monad)+ deriving newtype (MonadAssertion)+ deriving newtype (MonadBase IO)+ deriving newtype (MonadBaseControl IO)+ deriving newtype (MonadCatch)+ deriving newtype (MonadFail)+ deriving newtype (MonadIO)+ deriving newtype (MonadResource)+ deriving newtype (MonadTest)+ deriving newtype (MonadThrow)++instance Tasty (UnitIO ()) where+ tasty info = pure . testUnitIO testName+ where testName = fromMaybe "" . getLast $ TastyInfo.name info++testUnitIO :: T.TestName -> UnitIO () -> T.TestTree+testUnitIO testName =+ testProperty testName . H.withTests 1 . H.property . hoist runResourceT . H.test . runTestIO
+ test/Hedgehog/Extras/Test/TestExpectFailure.hs view
@@ -0,0 +1,37 @@+module Hedgehog.Extras.Test.TestExpectFailure where++import Prelude+import Hedgehog (property, Property, MonadTest, (===), success)+import Hedgehog.Extras.Test.Base (expectFailureWith, expectFailure)+import Hedgehog.Internal.Property (Failure (..), failWith)+import GHC.Stack (HasCallStack)+import Control.Monad.IO.Class (MonadIO)++hprop_expect_always_fails_prop :: Property+hprop_expect_always_fails_prop = property $ do+ expectFailureWith failureCheck alwaysFailsProp+ where+ failureCheck :: (MonadTest m, HasCallStack) => Failure -> m ()+ failureCheck (Failure _ reason _) =+ reason === "This property always fails"++ alwaysFailsProp :: (MonadTest m, HasCallStack) => m ()+ alwaysFailsProp = failWith Nothing "This property always fails"++hprop_bad_expect_always_fails_fails_prop :: Property+hprop_bad_expect_always_fails_fails_prop = property $ do+ expectFailure badExpectFailure+ where+ badExpectFailure :: (MonadIO m, MonadTest m, HasCallStack) => m ()+ badExpectFailure = expectFailureWith badFailureCheck alwaysFailsProp++ badFailureCheck :: (MonadTest m, HasCallStack) => Failure -> m ()+ badFailureCheck (Failure _ reason _) =+ reason === "This property sometimes fails"++ alwaysFailsProp :: (MonadTest m, HasCallStack) => m ()+ alwaysFailsProp = failWith Nothing "This property always fails"++hprop_bad_expect_failure_fails_prop :: Property+hprop_bad_expect_failure_fails_prop = property $ do+ expectFailure (expectFailure success)
+ test/Hedgehog/Extras/Test/UnitSpec.hs view
@@ -0,0 +1,13 @@+module Hedgehog.Extras.Test.UnitSpec where++import Control.Exception.Lifted+import Data.Bool+import Hedgehog+import Hedgehog.Extras.Test.Unit++tasty_unit :: UnitIO ()+tasty_unit = do+ bracket_+ (True === True)+ (True === True)+ (True === True)
+ test/Hedgehog/Extras/Test/WorkspaceSpec.hs view
@@ -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