tasty-discover 4.2.4 → 5.2.0
raw patch · 20 files changed
Files
- CHANGELOG.md +84/−0
- README.md +553/−63
- app/Main.hs +50/−0
- executable/Main.hs +0/−43
- src/Test/Tasty/Discover.hs +314/−2
- src/Test/Tasty/Discover/Internal/Config.hs +89/−2
- src/Test/Tasty/Discover/Internal/Driver.hs +55/−20
- src/Test/Tasty/Discover/Internal/Generator.hs +13/−6
- src/Test/Tasty/Discover/Internal/Unsafe.hs +37/−0
- src/Test/Tasty/Discover/TastyInfo.hs +2/−1
- tasty-discover.cabal +72/−27
- test-no-main/Main.hs +19/−0
- test-no-main/Tests.hs +36/−0
- test-no-main/Tests/Simple.hs +17/−0
- test/BackupFiles/ValidTest.hs +8/−0
- test/ConfigTest.hs +293/−3
- test/DiscoverTest.hs +308/−11
- test/Driver.hs +149/−22
- test/ModulesGlob/Sub/OneTest.hs +4/−0
- test/ModulesGlob/TwoTest.hs +4/−0
CHANGELOG.md view
@@ -8,6 +8,90 @@ [Keep a Changelog]: http://keepachangelog.com/ [Semantic Versioning]: http://semver.org/ +## [Unreleased]++### Added++### Fixed++### Changed++### Removed++# 5.2.0 [2025-10-25]++### Added+- `applySkips` function for skipping entire test trees with individual test visibility+ - Traverses test trees and replaces tests with skipped placeholders+ - Shows each test as `[SKIPPED]` in yellow when skip condition is met+ - Useful for platform-specific test suites with `Flavored (IO TestTree)`+ - Preserves test group structure while showing which tests would run+- Comprehensive platform expression tests covering all operators and edge cases+ - Added tests for `!darwin`, `!mingw32`, `!unix` negations+ - Added tests for complex AND/OR expressions+ - Added tests for edge cases like unknown platforms (freebsd)++### Changed+- Migrated release process to tag-triggered workflow+ - Release workflow now triggers when version tags (e.g., v5.2.0) are pushed+ - Removed automatic tag creation from CI+ - Updated release documentation to reflect tag-based process+- `--inplace` option now only overwrites file if content has changed+ - Prevents unnecessary file modification timestamps+ - Reduces build system churn when generated file is identical++# 5.1.0 [2025-08-10]++### Added+- Assertion newtype wrapper for HUnit-style assertions with comprehensive documentation and examples (see #74)+- Platform-specific test examples and documentation showing skip/platform usage (see #69)+- Support for GHC 9.12.2 in tested configurations (see #53)+- Reproduction test for symlink crash issue (see #38)+- New `--no-main` option for generating modules without main function (see #54)+- Support for custom tests with `Tasty` instances using `tasty_` prefix+- New `TastyInfo` type providing access to test metadata in custom tests+- **`Flavored` type**: General-purpose mechanism for transforming `TestTree`s generated by `tasty_` functions+ - Allows applying transformations like skipping, timeouts, metadata, grouping, etc.+ - Extensible design with `flavoring :: TestTree -> TestTree` transformation function+ - Integrates seamlessly with custom test types through `Tasty` instances+- **Skip test functionality**: Added `SkipTest` option type and `skip` function+ - `SkipTest` newtype with `IsOption` instance for Tasty options+ - `skip :: TestTree -> TestTree` function to skip any test tree+ - Skipped tests show as `[SKIPPED]` in yellow in test output+ - Works with `Flavored` type for advanced skip patterns+- Comprehensive documentation for all test type variations+- Step-by-step testing support for HUnit tests+- IO-based test generation for TestTrees+- AI development guidelines in AI_GUIDELINES.md+- Comprehensive coding style guide in CODING_STYLE.md+- Multiline block comment handling in test discovery (resolves #10)++### Fixed+- Fixed backup file import generation bug - prevents `.hs.orig` and `.hs.bak` files from being processed (see #58)+- Fixed directory handling in glob patterns - directories are now filtered out when using `--modules` flag (resolves #12)+- Fixed HLint warnings in generated code+- Fixed warnings in Generator.hs and added Unsafe.hs module+- Fixed broken links in documentation+- Fixed test discovery incorrectly finding tests inside `{- -}` block comments (resolves #10)++### Changed+- Enhanced documentation for skip and platform guidance (see #72)+- Cleaned up cabal file configuration+- Improved test discovery patterns from `*.hs*` to `*.hs` to avoid backup files+- Enhanced documentation with more test type examples+- Added regression tests for backup file handling and directory filtering+- Added preprocessing step to remove block comments before test discovery+- Enhanced test discovery with proper nested block comment support++### Removed+- Removed `project.sh` build script++# 5.0.0 [2022-07-08]++- Fix tasty-hedgehog `testProperty` deprecation warning++# 4.2.4 [2022-05-22]+ - Support for custom test libraries - Version module - Deduplicate imports in generated code
README.md view
@@ -2,7 +2,7 @@ [](http://stackage.org/nightly/package/tasty-discover) [](http://stackage.org/lts/package/tasty-discover) [](http://hackage.haskell.org/package/tasty-discover)-[](https://raw.githubusercontent.com/lwm/tasty-discover/master/LICENSE)+[](https://raw.githubusercontent.com/haskell-works/tasty-discover/main/LICENSE) # tasty-discover @@ -10,16 +10,27 @@ * [Create Test Driver File](#create-test-driver-file) * [Configure Cabal or Hpack Test Suite](#configure-cabal-or-hpack-test-suite) - [Write Tests](#write-tests)+ * [Test Transformations (Flavored, skip, platform)](#test-transformations-flavored-skip-platform)+ - [Flavored (test transformations)](#flavored-test-transformations)+ - [Skipping Tests](#skipping-tests)+ - [Platform-Specific Tests](#platform-specific-tests)+ - [Combining skip and platform](#combining-skip-and-platform)+ - [Using skip and platform (guidelines)](#using-skip-and-platform-guidelines)+ * [Comment Handling](#comment-handling) - [Customise Discovery](#customise-discovery) * [No Arguments](#no-arguments) * [With Arguments](#with-arguments)+ * [Custom Main Function](#custom-main-function) - [Example Project](#example-project) - [Change Log](#change-log) - [Deprecation Policy](#deprecation-policy) - [Contributing](#contributing) - [FAQ](#frequently-asked-questions) - [Maintenance](#maintenance)+- [Releasing](#releasing) - [Acknowledgements](#acknowledgements)+- [AI Guidelines](AI_GUIDELINES.md)+- [Coding Style](CODING_STYLE.md) Haskell auto-magic test discovery and runner for the [tasty test framework]. @@ -31,6 +42,16 @@ files. Tasty ingredients are included along with various configuration options for different use cases. +**Recent improvements include:**+- New `--no-main` option for custom test runners+- **Platform-specific test filtering** with `platform` function and logical expressions+- **Skip test functionality** with `skip` function and yellow `[SKIPPED]` output+- **`Flavored` type** for general-purpose test transformations with extensible design+- Enhanced support for custom test types with `Tasty` instances+- Better handling of backup files and directories in test discovery+- Intelligent block comment handling to prevent false test discovery+- Comprehensive documentation with more test examples+ See below for full documentation and examples. # Getting Started@@ -55,15 +76,11 @@ ``` {-# OPTIONS_GHC -F -pgmF tasty-discover #-} ```--## Configure Cabal or Hpack Test Suite--In order for Cabal/Stack to know where the tests are, you'll need to configure-the `main-is` option of your test-suite to point to the driver file. In the following example, the test driver file is called `Driver.hs`: ``` test-suite test+ type: exitcode-stdio-1.0 main-is: Driver.hs hs-source-dirs: test build-depends: base@@ -71,7 +88,7 @@ If you use [hpack], that might look like: -[hpack]: https://git.coop/sol/hpack+[hpack]: https://github.com/sol/hpack ``` yaml tests:@@ -103,7 +120,7 @@ - **unit_**: [HUnit](http://hackage.haskell.org/package/tasty-hunit) test cases. - **spec_**: [Hspec](http://hackage.haskell.org/package/tasty-hspec) specifications. - **test_**: [Tasty](http://hackage.haskell.org/package/tasty) TestTrees.- - **tasty_**: Custom tests+ - **tasty_**: Custom tests with [Tasty](http://hackage.haskell.org/package/tasty) instances. Here is an example test module with a bunch of different tests: @@ -118,11 +135,27 @@ import Test.Tasty.HUnit import Test.Tasty.Hspec import Test.Tasty.QuickCheck+import Test.Tasty.SmallCheck+import qualified Test.Tasty.Hedgehog as TH+import qualified Hedgehog as H+import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R -- HUnit test case unit_listCompare :: IO () unit_listCompare = [1, 2, 3] `compare` [1,2] @?= GT +-- HUnit test case with additional info+unit_listInfo :: IO String+unit_listInfo = return "This test provides info"++-- HUnit test case with steps+unit_listSteps :: (String -> IO ()) -> IO ()+unit_listSteps step = do+ step "Setting up test data"+ step "Running the test"+ [1, 2, 3] `compare` [1,2] @?= GT+ -- QuickCheck property prop_additionCommutative :: Int -> Int -> Bool prop_additionCommutative a b = a + b == b + a@@ -131,23 +164,46 @@ scprop_sortReverse :: [Int] -> Bool scprop_sortReverse list = sort list == sort (reverse list) +-- Hedgehog property+hprop_reverseReverse :: H.Property+hprop_reverseReverse = H.property $ do+ xs <- H.forAll $ G.list (R.linear 0 100) G.alpha+ reverse (reverse xs) H.=== xs+ -- Hspec specification spec_prelude :: Spec spec_prelude = describe "Prelude.head" $ do it "returns the first element of a list" $ do head [23 ..] `shouldBe` (23 :: Int) --- Custom test+-- Simple Tasty TestTree+test_addition :: TestTree+test_addition = testProperty "Addition commutes" $ \(a :: Int) (b :: Int) -> a + b == b + a++-- List of Tasty TestTrees+test_multiplication :: [TestTree]+test_multiplication =+ [ testProperty "Multiplication commutes" $ \(a :: Int) (b :: Int) -> a * b == b * a+ , testProperty "One is identity" $ \(a :: Int) -> a * 1 == a+ ]++-- IO Tasty TestTree+test_generateTree :: IO TestTree+test_generateTree = do+ input <- pure "Some input"+ pure $ testCase input $ pure ()++-- IO List of Tasty TestTrees+test_generateTrees :: IO [TestTree]+test_generateTrees = do+ inputs <- pure ["First input", "Second input"]+ pure $ map (\s -> testCase s $ pure ()) inputs++-- Custom test with Tasty instance -- -- Write a test for anything with a Tasty instance--- --- In order to use this feature, you must add tasty-discover as a library dependency--- to your test component in the cabal file.------ The instance defined should not be an orphaned instance. A future version of--- tasty-discover may choose to define orphaned instances for popular test libraries.-import Test.Tasty (testCase)-import Test.Tasty.Discover (TestCase(..), descriptionOf)+-- In order to use Flavored with tasty_ functions, add tasty-discover as a library+-- dependency to your test component in the cabal file. data CustomTest = CustomTest String Assertion @@ -158,23 +214,391 @@ tasty_myTest :: CustomTest tasty_myTest = CustomTest "Custom: " $ pure () --- Tasty TestTree-test_multiplication :: [TestTree]-test_multiplication = [testProperty "One is identity" $ \(a :: Int) -> a * 1 == a]+-- Custom Tasty TestTree (can be any TestTree)+tasty_customGroup :: TestTree+tasty_customGroup = testGroup "Custom Test Group"+ [ testCase "nested test 1" $ return ()+ , testCase "nested test 2" $ (1 + 1) @?= (2 :: Int)+ ]+``` --- Tasty IO TestTree-test_generateTree :: IO TestTree-test_generateTree = do- input <- pure "Some input"- pure $ testCase input $ pure ()+## Test Transformations (Flavored, skip, platform) --- Tasty IO [TestTree]-test_generateTrees :: IO [TestTree]-test_generateTrees = do- inputs <- pure ["First input", "Second input"]- pure $ map (\s -> testCase s $ pure ()) inputs+This section covers how to transform tests using the Flavored pattern and how to apply skip and platform filters effectively.++### Flavored (test transformations)++The `Flavored` type provides a general-purpose mechanism for transforming `TestTree`s generated by `tasty_` functions before they are added to the test suite. This allows you to apply various options and modifications to your tests.++You can create flavored tests using the `flavored` constructor:++```haskell+flavored :: (TestTree -> TestTree) -> a -> Flavored a ``` +#### Examples++```haskell+import Test.Tasty.Discover (Flavored, flavored, skip)++-- Skip a custom property test+tasty_skipProperty :: Flavored Property+tasty_skipProperty = flavored skip $ property $ do+ -- This test will be skipped and show as [SKIPPED] in yellow+ H.failure+```++When tests are skipped, they will show as `[SKIPPED]` in yellow in the test output and won't actually execute.++### Skipping Tests++You can skip tests using the skip functionality provided by tasty-discover. There are multiple ways to skip tests:++For a high-level overview of when to use flavored vs direct application, see+[Using skip and platform (guidelines)](#using-skip-and-platform-guidelines).++#### Using the `skip` function++You can use the `skip` function to skip any TestTree:++```haskell+import Test.Tasty.Discover (skip)++-- Skip a simple test+test_skipThis :: TestTree+test_skipThis = skip $ testCase "this will be skipped" $ pure ()++-- Skip a property test+prop_skipThis :: Property -> TestTree+prop_skipThis p = skip $ testProperty "skipped property" p+```++**Potential future uses:**+The `Flavored` mechanism is designed to be extensible and could be used for other `TestTree` transformations such as:+- Setting test timeouts+- Adding test metadata or descriptions+- Grouping tests under custom names+- Setting resource dependencies+- Applying multiple transformations in sequence++#### Important: How to skip a tasty_ test++Guideline (TL;DR): To skip a `tasty_` test so it shows `[SKIPPED]` and doesn’t run, wrap it with `flavored skip`:++```haskell+import Test.Tasty.Discover (Flavored, flavored, skip)++-- Skips at the TestTree level (preferred for tasty_ tests)+tasty_mySkipped :: Flavored TestTree+tasty_mySkipped = flavored skip $ testCase "will be skipped" $ pure ()+```++Details (why this matters): Applying `skip` directly to an already-constructed+`TestTree` marks only that subtree as skipped. The test body can detect it via+`askOption`, but the outer `Tasty` instance (used by `tasty_` functions) may not+render a top-level `[SKIPPED]` placeholder because the option is applied after+the instance decides how to wrap the node. Using `flavored skip` applies the+transformation early so the instance can short-circuit and substitute a skipped+placeholder.++For completeness, a direct `skip` example that observes the option inside the test:++```haskell+-- Direct skip on a TestTree: the test can read SkipTest via askOption, but the+-- outer instance may not show a top-level [SKIPPED] marker for this node.+test_directSkip :: TestTree+test_directSkip = skip $ askOption $ \(TD.SkipTest shouldSkip) ->+ testCase "observes SkipTest inside" $ assertBool "expected SkipTest" shouldSkip+```++Using `Flavored` ensures the `skip` is visible to the `Tasty` instance early enough to short-circuit with a skipped placeholder.++```++### Platform-Specific Tests++You can conditionally run tests based on the current operating platform using the `platform` function provided by tasty-discover. This is useful for tests that only work on specific operating systems or need to be excluded from certain platforms.++For general guidance and composition patterns with `skip`, see+[Using skip and platform (guidelines)](#using-skip-and-platform-guidelines).++The `platform` function takes a platform expression string and a `TestTree`, returning a `TestTree` that will only run if the expression evaluates to true for the current platform:++```haskell+import Test.Tasty.Discover (platform)++-- Run only on Linux+tasty_linuxOnly :: TestTree+tasty_linuxOnly = platform "linux" $ testCase "Linux-specific functionality" $ do+ -- This test only runs on Linux+ pure ()++-- Run on all platforms except Windows +tasty_notWindows :: TestTree +tasty_notWindows = platform "!windows" $ testCase "Non-Windows functionality" $ do+ -- This test runs on all platforms except Windows+ pure ()++-- Run on Unix-like systems (Linux or Darwin)+tasty_unixLike :: TestTree+tasty_unixLike = platform "unix" $ testCase "Unix-like systems" $ do+ -- This test runs on Linux and Darwin (Unix-like systems)+ pure ()+```++#### Platform Expression Syntax++Platform expressions support the following syntax:++**Platform Names:**+- `"linux"` - Linux systems+- `"darwin"` - macOS systems +- `"windows"` - Windows systems (mapped to "mingw32" internally)+- `"mingw32"` - Windows systems (actual System.Info.os value)+- `"unix"` - Unix-like systems (matches both "linux" and "darwin")++**Logical Operators:**+- `"!"` (NOT) - Negation, e.g., `"!windows"` means "not Windows"+- `"&"` (AND) - Conjunction, e.g., `"!windows & !darwin"` means "neither Windows nor Darwin"+- `"|"` (OR) - Disjunction, e.g., `"linux | darwin"` means "Linux or Darwin"++**Complex Examples:**+```haskell+-- Run on platforms that are neither Windows nor Darwin (e.g., Linux)+tasty_complexPlatform1 :: TestTree+tasty_complexPlatform1 = platform "!windows & !darwin" $ testCase "Neither Windows nor Darwin" $ do+ pure ()++-- Run on either Linux or Darwin, but not Windows+tasty_complexPlatform2 :: TestTree+tasty_complexPlatform2 = platform "linux | darwin" $ testCase "Linux or Darwin only" $ do+ pure ()+```++#### Using `Flavored` with Platform Filtering++You can combine platform filtering with other test transformations using the `Flavored` type:++```haskell+import Test.Tasty.Discover (Flavored, flavored, platform)++-- Apply platform filtering to custom test types+tasty_platformFlavored :: Flavored TestTree+tasty_platformFlavored = flavored (platform "!windows") $ testCase "Advanced platform test" $ do+ pure ()++-- Platform-specific property test+tasty_platformProperty :: Flavored Property +tasty_platformProperty = flavored (platform "unix") $ property $ do+ -- This hedgehog property only runs on Unix-like systems+ x <- H.forAll $ G.int (R.linear 1 100)+ x H.=== x+```++#### Combining skip and platform++Platform filtering can be combined with other tasty-discover features:++```haskell+-- Platform filtering with test skipping+tasty_platformAndSkip :: TestTree+tasty_platformAndSkip = platform "linux" $ skip $ testCase "Linux test that's also skipped" $ do+ -- This would only run on Linux, but it's also skipped+ pure ()++-- Platform filtering with test groups+tasty_platformGroup :: TestTree+tasty_platformGroup = platform "unix" $ testGroup "Unix-only tests"+ [ testCase "Unix test 1" $ pure ()+ , testCase "Unix test 2" $ pure ()+ , testProperty "Unix property" $ \(x :: Int) -> x >= 0 || x < 0+ ]+```++Platform filtering works by checking the current platform against the expression at runtime. If the expression evaluates to `False`, the test is automatically skipped using the same mechanism as the `skip` function.++#### Skipping entire test trees with `applySkips`++When you want to skip an entire test tree (such as a group of tests) and have each individual test show as `[SKIPPED]` in the output, use the `applySkips` function:++```haskell+import Test.Tasty.Discover (Flavored, flavored, platform, applySkips)++-- Skip an entire test group on Darwin+tasty_testTree_no_darwin :: Flavored (IO TestTree)+tasty_testTree_no_darwin =+ flavored (platform "!darwin") $ pure $+ applySkips $ testGroup "Non-Darwin group"+ [ testProperty "Test 1" $ \(x :: Int) -> x == x+ , testCase "Test 2" $ pure ()+ , testProperty "Test 3" $ \(x :: Int) -> x >= 0 || x < 0+ ]+```++On Darwin, this will display all tests as skipped in yellow:++```+Non-Darwin group+ Test 1 [SKIPPED]: OK+ Test 2 [SKIPPED]: OK+ Test 3 [SKIPPED]: OK+```++The `applySkips` function:+- Checks the `SkipTest` option (set by functions like `skip` or `platform`)+- Traverses the entire test tree and replaces each individual test with a skipped placeholder+- Preserves the test group structure+- Shows `[SKIPPED]` in yellow for each test++This is particularly useful for platform-specific test suites where you want to see which tests would run on other platforms, rather than hiding the entire group.++### Using skip and platform (guidelines)++TL;DR:+- For tests exposed via `tasty_` functions, prefer the `Flavored` pattern to apply+ transformations like `skip` and `platform` so they take effect at the TestTree level and can short-circuit execution.+- Applying `skip` directly to an already-constructed `TestTree` marks the subtree as skipped. The test can observe this via `askOption`, but the outer `Tasty` instance may not show a top-level `[SKIPPED]` placeholder.++Examples:++```haskell+import Test.Tasty.Discover (Flavored, flavored, skip, platform)+import Test.Tasty (TestTree, testCase)++-- Skip (preferred for tasty_ tests):+tasty_mySkipped :: Flavored TestTree+tasty_mySkipped = flavored skip $ testCase "will be skipped" $ pure ()++-- Platform filter with Flavored:+tasty_linuxOnly :: Flavored TestTree+tasty_linuxOnly = flavored (platform "linux") $ testCase "Linux only" $ pure ()++-- Compose platform and skip:+tasty_linuxButSkipped :: Flavored TestTree+tasty_linuxButSkipped = flavored (platform "linux") $ flavored skip $ testCase "won't run" $ pure ()++-- Direct skip on a TestTree (observed inside the test):+test_directSkip :: TestTree+test_directSkip = skip $ askOption $ \(TD.SkipTest shouldSkip) ->+ testCase "observes SkipTest inside" $ assertBool "expected SkipTest" shouldSkip+```++Platform expressions:+- Names: "linux", "darwin", "windows" (mapped to "mingw32"), "mingw32", and "unix" (matches both linux and darwin)+- Operators: `!` (NOT), `&` (AND), `|` (OR)+- Examples:+ - `platform "!windows & !darwin"` — neither Windows nor Darwin+ - `platform "linux | darwin"` — Linux or Darwin+ - `platform "unix"` — Linux or Darwin++## Test Type Variations++### HUnit Tests (`unit_` prefix)++The `unit_` prefix supports three different function signatures:+ ### Tasty TestTrees (`test_` prefix)+- `unit_testName :: IO ()` - Basic test case+- `unit_testName :: IO String` - Test case that provides additional info+- `unit_testName :: (String -> IO ()) -> IO ()` - Test case with steps++### Tasty TestTrees (`test_` prefix)++The `test_` prefix supports four different function signatures:++- `test_testName :: TestTree` - A single test tree+- `test_testName :: [TestTree]` - A list of test trees (automatically grouped)+- `test_testName :: IO TestTree` - A test tree generated in IO+- `test_testName :: IO [TestTree]` - A list of test trees generated in IO++### Custom Tests (`tasty_` prefix)++The `tasty_` prefix works with any type that has a `Tasty` instance:++- Built-in instances for `TestTree`, `[TestTree]`, `IO TestTree`, `IO [TestTree]`+- Custom instances for your own data types+- Provides access to test metadata through `TastyInfo`++### Organizing Tests with `testGroup`++The `testGroup` function is Tasty's way of organizing tests into hierarchical groups. You can use it in several ways:++**In `test_` functions:**+```haskell+test_arithmeticTests :: TestTree+test_arithmeticTests = testGroup "Arithmetic Operations"+ [ testCase "addition" $ 2 + 2 @?= 4+ , testCase "multiplication" $ 3 * 4 @?= 12+ , testProperty "commutativity" $ \a b -> a + b == b + (a :: Int)+ ]+```++**In `tasty_` functions:**+```haskell+tasty_myTestSuite :: TestTree+tasty_myTestSuite = testGroup "My Test Suite"+ [ testGroup "Unit Tests"+ [ testCase "test 1" $ pure ()+ , testCase "test 2" $ pure ()+ ]+ , testGroup "Properties"+ [ testProperty "prop 1" $ \x -> x == (x :: Int)+ ]+ ]+```++**In list form with `test_` functions:**+```haskell+test_groupedTests :: [TestTree]+test_groupedTests =+ [ testGroup "Group 1" [testCase "test A" $ pure ()]+ , testGroup "Group 2" [testCase "test B" $ pure ()]+ ]+```++This creates nested test hierarchies that make test output more organized and easier to navigate.++## Comment Handling++`tasty-discover` intelligently handles Haskell comments during test discovery to prevent false positives:++### Block Comments++Tests inside multiline block comments are automatically ignored:++```haskell+module MyTest where++-- This test will be discovered+unit_validTest :: IO ()+unit_validTest = pure ()++{- This test will be ignored+unit_commentedOut :: IO ()+unit_commentedOut = pure ()+-}++{- Nested comments are also handled correctly+{- Even deeply nested ones+unit_deeplyNested :: IO ()+unit_deeplyNested = pure ()+-}+unit_alsoIgnored :: IO ()+unit_alsoIgnored = pure ()+-}+```++### Line Comments++Line comments (starting with `--`) are handled by the Haskell lexer and don't interfere with test discovery:++```haskell+-- unit_thisIsIgnored :: IO ()+unit_thisIsFound :: IO () -- This test will be discovered+unit_thisIsFound = pure ()+```++This feature prevents compilation errors that would occur if `tasty-discover` tried to reference tests that are commented out, making it easier to temporarily disable tests during development.+ # Customise Discovery You configure `tasty-discover` by passing options to the test driver file.@@ -185,6 +609,7 @@ - **--debug**: Output the contents of the generated module while testing. - **--tree-display**: Display the test output results hierarchically.+ - **--no-main**: Generate a module without a main function, exporting `tests` and `ingredients` instead. ## With Arguments @@ -201,17 +626,68 @@ It is also possible to override [tasty test options] with `-optF`: -[tasty test options]: https://git.coop/feuerbach/tasty#options+[tasty test options]: https://github.com/feuerbach/tasty#options ``` bash {-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-} ``` +## Custom Main Function++The `--no-main` option allows you to write your own custom main function while still using tasty-discover for test discovery. This is useful when you need to:++- Apply custom test transformations or wrappers+- Add custom logging or output formatting+- Integrate with custom test runners or CI systems+- Control exactly how tests are executed++### Example Usage++Create your test discovery file (e.g., `test/Tests.hs`):++```haskell+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --no-main -optF --generated-module -optF Tests #-}+```++Then create your custom main file (e.g., `test/Main.hs`):++```haskell+module Main where++import qualified Tests+import qualified Test.Tasty as T++main :: IO ()+main = do+ putStrLn "=== Custom Test Runner ==="++ -- Get discovered tests and ingredients+ discoveredTests <- Tests.tests++ -- Apply custom transformations+ let wrappedTests = T.testGroup "My Custom Tests" [discoveredTests]++ -- Run with custom configuration+ T.defaultMainWithIngredients Tests.ingredients wrappedTests+```++Configure your cabal test suite to use the custom main:++```+test-suite my-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Tests+ hs-source-dirs: test+ build-depends: base, tasty+ build-tool-depends: tasty-discover:tasty-discover+```+ # Example Project See the [testing for this package] for a fully configured example. -[testing for this package]: https://git.coop/lwm/tasty-discover/tree/master/test+[testing for this package]: https://github.com/haskell-works/tasty-discover/tree/main/test # Change Log @@ -219,9 +695,46 @@ We try to keep [tagged releases] in our release process, if you care about that. -[CHANGELOG.md]: https://git.coop/lwm/tasty-discover/blob/master/CHANGELOG.md-[tagged releases]: https://git.coop/lwm/tasty-discover/releases+[CHANGELOG.md]: https://github.com/haskell-works/tasty-discover/blob/main/CHANGELOG.md+[tagged releases]: https://github.com/haskell-works/tasty-discover/releases +# Releasing++This project's release flow is automated via GitHub Actions and triggered by pushing version tags.++Release checklist:++1) Prepare notes+- Update `CHANGELOG.md`: move items from "Unreleased" to a new version section with the current date.++2) Bump version+- Edit `tasty-discover.cabal` and set `version:` to the new version (e.g., `5.x.y`).++3) Commit changes+- Commit the changes: `git commit -m "Release X.Y.Z"`+- Push the commit: `git push origin main`++4) Create and push tag+- Create a git tag: `git tag -a vX.Y.Z -m "Release version X.Y.Z"`+- Push the tag: `git push origin vX.Y.Z`++5) CI does the rest (automated)+- When the tag is pushed, GitHub Actions automatically:+ - Runs the full test suite+ - Validates the cabal project with `cabal check`+ - Builds source distributions (`cabal v2-sdist`)+ - Uploads to Hackage (requires repo secrets `HACKAGE_USER`/`HACKAGE_PASS`)+ - Creates a draft GitHub Release for the tag++6) Publish release+- Go to https://github.com/haskell-works/tasty-discover/releases+- Edit the draft GitHub Release notes if needed and publish++Notes:+- The workflow is defined in `.github/workflows/haskell.yml`.+- The release workflow only triggers on tags matching `v[0-9]+.[0-9]+.[0-9]+` (e.g., v5.2.0).+- Keep `tested-with` in the cabal file up to date with CI's GHC matrix.+ # Deprecation Policy If a breaking change is implemented, you'll see a major version increase, an@@ -229,7 +742,7 @@ and clear instructions on how to upgrade. Please do complain if we're doing this too much. -[change log]: https://git.coop/lwm/tasty-discover/blob/master/CHANGELOG.md+[change log]: https://github.com/haskell-works/tasty-discover/blob/main/CHANGELOG.md # Contributing @@ -237,40 +750,17 @@ comprehensive, so just get hacking and add a test case - there are *plenty* of examples, so this should be simple - and I'll get to review your change ASAP. +Please follow the guidelines in [CODING_STYLE.md](CODING_STYLE.md) for consistent code formatting and patterns.++For AI assistants and detailed development guidelines, see [AI_GUIDELINES.md](AI_GUIDELINES.md).+ # Frequently Asked Questions ## Deleting Tests Breaks The Test Run This is a known limitation and has been reported. No fix is planned unless you have time. -Please see [#145](https://git.coop/lwm/tasty-discover/issues/145) for more information.--## Deprecation warnings--If you see the `testProperty` deprecation warnings like the following:--```-test/Driver.hs:77:17: warning: [-Wdeprecations]- In the use of ‘testProperty’ (imported from Test.Tasty.Hedgehog):- Deprecated: "testProperty will cause Hedgehog to provide incorrect instructions for re-checking properties"- |-77 | t16 <- pure $ H.testProperty "reverse" DiscoverTest.hprop_reverse- | ^^^^^^^^^^^^^^-```--There are two ways to fix it:--One is to suppress the warning. This can be done for example with an adjustment to the-Driver preprocessing with the `-Wno-deprecations` option:--```-{-# OPTIONS_GHC -Wno-deprecations -F -pgmF tasty-discover -optF --hide-successes #-}-```--Taking this option, whilst quick an easy, risks missing important deprecation warnings however.--The recommended option is define a `Tasty` type class instance for hedgehog. An example can be-found in `DiscoverTest` module.+Please see [#145](https://github.com/haskell-works/tasty-discover/issues/145) for more information. # Maintenance
+ app/Main.hs view
@@ -0,0 +1,50 @@+-- | Main executable module.++module Main where++import Control.Monad (when)+import Data.Maybe (fromMaybe)+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)+import System.FilePath (takeDirectory)+import System.IO (IOMode(ReadMode), hGetContents, hPutStrLn, withFile, stderr)+import Test.Tasty.Discover.Internal.Config (Config (..), parseConfig)+import Test.Tasty.Discover.Internal.Driver (findTests, generateTestDriver)++-- | Main function.+main :: IO ()+main = do+ args <- getArgs+ name <- getProgName+ case args of+ src:_:dst:opts ->+ case parseConfig (takeDirectory src) name opts of+ Left err -> do+ hPutStrLn stderr err+ exitFailure+ Right config -> do+ tests <- findTests config+ let ingredients = tastyIngredients config+ moduleName = fromMaybe "Main" (generatedModuleName config)+ header <- readHeader src+ let output = generateTestDriver config moduleName ingredients src tests+ when (debug config) $ hPutStrLn stderr output+ -- Write in-place only when content differs (no temp file)+ when (inPlace config) $ do+ let newContent = unlines $ header ++ [marker, output]+ -- Strictly read the existing file so the handle is closed before we write (important on Windows)+ oldContent <- withFile src ReadMode $ \h -> do+ s <- hGetContents h+ length s `seq` return s+ when (oldContent /= newContent) $ writeFile src newContent+ writeFile dst $+ "{-# LINE " ++ show (length header + 2) ++ " " ++ show src ++ " #-}\n"+ ++ output+ _ -> do+ hPutStrLn stderr "Usage: tasty-discover src _ dst [OPTION...]"+ exitFailure+ where+ marker = "-- GENERATED BY tasty-discover"+ readHeader src = withFile src ReadMode $ \h -> do+ header <- takeWhile (marker /=) . lines <$> hGetContents h+ seq (length header) (return header)
− executable/Main.hs
@@ -1,43 +0,0 @@--- | Main executable module.--module Main where--import Control.Monad (when)-import Data.Maybe (fromMaybe)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure)-import System.FilePath (takeDirectory)-import System.IO (IOMode(ReadMode), hGetContents, hPutStrLn, withFile, stderr)-import Test.Tasty.Discover.Internal.Config (Config (..), parseConfig)-import Test.Tasty.Discover.Internal.Driver (findTests, generateTestDriver)---- | Main function.-main :: IO ()-main = do- args <- getArgs- name <- getProgName- case args of- src:_:dst:opts ->- case parseConfig (takeDirectory src) name opts of- Left err -> do- hPutStrLn stderr err- exitFailure- Right config -> do- tests <- findTests config- let ingredients = tastyIngredients config- moduleName = fromMaybe "Main" (generatedModuleName config)- header <- readHeader src- let output = generateTestDriver config moduleName ingredients src tests- when (debug config) $ hPutStrLn stderr output- when (inPlace config) $ writeFile src $ unlines $ header ++ [marker, output]- writeFile dst $- "{-# LINE " ++ show (length header + 2) ++ " " ++ show src ++ " #-}\n"- ++ output- _ -> do- hPutStrLn stderr "Usage: tasty-discover src _ dst [OPTION...]"- exitFailure- where- marker = "-- GENERATED BY tasty-discover"- readHeader src = withFile src ReadMode $ \h -> do- header <- takeWhile (marker /=) . lines <$> hGetContents h- seq (length header) (return header)
src/Test/Tasty/Discover.hs view
@@ -1,21 +1,77 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} module Test.Tasty.Discover ( Tasty(..) , TastyInfo+ , SkipTest(..)+ , Flavored(..)+ , flavored , name , description , nameOf , descriptionOf+ , skip+ , applySkips+ , platform+ , evaluatePlatformExpression ) where import Data.Maybe import Data.Monoid+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode)+import System.Info (os) import Test.Tasty.Discover.TastyInfo (TastyInfo)+import Test.Tasty.Discover.Internal.Config (SkipTest(..)) import qualified Test.Tasty as TT+import qualified Test.Tasty.Runners as TR+import qualified Test.Tasty.Providers as TP import qualified Test.Tasty.Discover.TastyInfo as TI +{- $skipPlatform+Guidelines for using 'skip' and 'platform'+-----------------------------------------++TL;DR:+- For tests exposed via @tasty_@ functions, prefer using the 'Flavored' pattern to apply+ transformations like 'skip' and 'platform' so they take effect at the TestTree level.+- Directly applying 'skip' to an already-constructed 'TT.TestTree' marks the subtree as+ skipped (the test can observe 'SkipTest' via 'TT.askOption'), but the outer 'Tasty'+ instance may not replace it with a top-level "[SKIPPED]" node.++Patterns:+- Skip with 'Flavored':++@+tasty_mySkipped :: Flavored TT.TestTree+tasty_mySkipped = flavored skip $ TT.testCase "will be skipped" $ pure ()+@++-+@+tasty_linuxOnly :: Flavored TT.TestTree+tasty_linuxOnly = flavored (platform "linux") $ TT.testCase "Linux only" $ pure ()+@++Platform expressions:+- Names: @"linux"@, @"darwin"@, @"windows"@ (mapped to @"mingw32"@), @"mingw32"@, and @"unix"@ (matches linux|darwin)+- Operators: NOT @!@, AND @&@, OR @|@+-- Examples:++@+platform "!windows & !darwin" -- neither Windows nor Darwin+platform "linux | darwin" -- Linux or Darwin+platform "unix" -- Linux or Darwin+@++Combining:+- You can compose transformations: e.g., @flavored (platform "linux") . flavored skip@+ or wrap once with a composed function @flavored (platform "linux" . skip)@.++See 'skip' and 'platform' for function-specific details.+-}+ class Tasty a where tasty :: TastyInfo -> a -> IO TT.TestTree @@ -31,11 +87,44 @@ instance Tasty (IO [TT.TestTree]) where tasty info a = TT.testGroup (descriptionOf info) <$> a +-- | A general-purpose wrapper for transforming TestTrees generated by tasty_ functions.+--+-- The Flavored type allows you to apply transformations to test trees before they+-- are added to the test suite. This enables applying various options and modifications+-- such as skipping tests, setting timeouts, adding metadata, grouping, etc.+--+-- Example usage:+-- @+-- -- Skip a test+-- tasty_skipThis :: Flavored Property+-- tasty_skipThis = flavored skip $ property $ do+-- -- This test will be skipped+-- H.failure+-- @+data Flavored a = Flavored+ { flavoring :: TT.TestTree -> TT.TestTree -- ^ Transformation function to apply+ , unFlavored :: a -- ^ The wrapped test value+ }++-- | Create a Flavored wrapper with a specific transformation function.+--+-- @flavored f a@ applies transformation @f@ to the TestTree generated from @a@.+flavored :: (TT.TestTree -> TT.TestTree) -> a -> Flavored a+flavored f a = Flavored f a++instance Tasty a => Tasty (Flavored a) where+ tasty :: TastyInfo -> Flavored a -> IO TT.TestTree+ tasty info (Flavored f a) = do+ testTree <- tasty info a+ pure $ f testTree+ nameOf :: TastyInfo -> String-nameOf info = (fromMaybe "<unnamed>" (getLast (TI.name info)))+nameOf info =+ fromMaybe "<unnamed>" (getLast (TI.name info)) descriptionOf :: TastyInfo -> String-descriptionOf info = (fromMaybe "<undescribed>" (getLast (TI.description info)))+descriptionOf info =+ fromMaybe "<undescribed>" (getLast (TI.description info)) name :: String -> TastyInfo name n = mempty@@ -46,3 +135,226 @@ description n = mempty { TI.description = Last $ Just n }++-- | Mark a test tree to be skipped by setting the SkipTest option to True.+--+-- Usage guidelines: see the @Guidelines for using 'skip' and 'platform'@ section ('skipPlatform').+-- In short, for @tasty_@ tests prefer 'flavored' 'skip' to let the outer 'Tasty' instance+-- short-circuit at the TestTree level. Direct 'skip' on a pre-built tree applies the option+-- to the subtree; the test can still observe 'SkipTest' via 'TT.askOption'.+--+-- Examples:+-- @+-- -- Direct usage on a TestTree (the test can read SkipTest via askOption)+-- test_directSkip :: TestTree+-- test_directSkip = skip $ testCase "will be skipped" $ pure ()+--+-- -- Preferred for tasty_ tests: apply at the right stage using Flavored+-- tasty_skipProperty :: Flavored Property+-- tasty_skipProperty = flavored skip $ property $ do+-- -- This property will be skipped+-- H.failure+-- @+skip :: TT.TestTree -> TT.TestTree+skip = TT.adjustOption (const (SkipTest True))++-- | Transform a TestTree to apply skipping behavior throughout the entire tree.+--+-- This function wraps a TestTree so that when the 'SkipTest' option is set to 'True',+-- all individual tests within the tree are replaced with skipped placeholder tests.+-- This is useful when you want to conditionally skip an entire group of tests while+-- still showing each test as skipped in the output.+--+-- The function works by:+--+-- * Checking the 'SkipTest' option via 'TT.askOption'+-- * If skipping is enabled, using 'TT.foldTestTree' to traverse the tree and rebuild it with:+--+-- * All single tests replaced with test cases showing "[SKIPPED]"+-- * Test groups preserved with their structure intact+-- * Resources skipped (not acquired)+--+-- * If skipping is disabled, returning the tree unchanged+--+-- This is particularly useful in combination with 'platform' for platform-specific test suites:+--+-- @+-- tasty_testTree_no_darwin :: Flavored (IO TestTree)+-- tasty_testTree_no_darwin =+-- flavored (platform "!darwin") $ pure $ applySkips $ testGroup "Non-Darwin group"+-- [ testProperty "Test 1" $ \\(x :: Int) -> x == x+-- , testCase "Test 2" $ pure ()+-- ]+-- @+--+-- On Darwin, this will show:+--+-- @+-- Non-Darwin group+-- Test 1 [SKIPPED]: OK+-- Test 2 [SKIPPED]: OK+-- @+--+-- @since 5.1.0+-- | A simple test type for skipped tests+data SkippedTest = SkippedTest+ deriving stock (Show, Eq)++instance TP.IsTest SkippedTest where+ run _ _ _ = return $ TP.testPassed ""+ testOptions = return []++applySkips :: TT.TestTree -> TT.TestTree+applySkips tree = TT.askOption $ \(SkipTest shouldSkip) ->+ if shouldSkip+ then transformTree tree+ else tree+ where+ yellowText :: String -> String+ yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]++ transformTree :: TT.TestTree -> TT.TestTree+ transformTree t = case TR.foldTestTree+ TR.TreeFold+ { TR.foldSingle = \_ testName _ -> [TP.singleTest (testName ++ " " ++ yellowText "[SKIPPED]") SkippedTest]+ , TR.foldGroup = \_ groupName trees -> [TT.testGroup groupName (concat trees)]+ , TR.foldResource = \_ _ _ -> []+ , TR.foldAfter = \_ _ _ trees -> trees+ }+ mempty+ t of+ [result] -> result+ results -> TT.testGroup "" results++-- | Conditionally run a test based on a platform expression.+--+-- Usage guidelines, syntax, and examples: see the @Guidelines for using 'skip' and 'platform'@+-- section ('skipPlatform').+--+-- The expression supports logical operations with platform names:+-- - Platform names: "linux", "darwin", "mingw32", "windows", "unix"+-- - Negation: "!platform" (not on platform) +-- - Conjunction: "platform1 & platform2" (on both platforms)+-- - Disjunction: "platform1 | platform2" (on either platform)+-- - Parentheses: "(platform1 | platform2) & !platform3"+--+-- Examples:+-- @+-- -- Only on Linux+-- test_linuxOnly :: TestTree+-- test_linuxOnly = platform "linux" $ testCase "Linux only" $ pure ()+--+-- -- Not on Windows or macOS+-- test_notWinMac :: TestTree +-- test_notWinMac = platform "!windows & !darwin" $ testCase "Unix-like only" $ pure ()+--+-- -- On Linux or macOS but not Windows+-- test_unixLike :: TestTree+-- test_unixLike = platform "(linux | darwin) & !windows" $ testCase "Unix-like" $ pure ()+-- @+platform :: String -> TT.TestTree -> TT.TestTree+platform expr testTree = + if evaluatePlatformExpression expr os+ then testTree+ else skip testTree++-- | Evaluate a platform expression against a given platform string.+--+-- Inputs:+-- - The first argument is the platform expression (e.g. @"linux | darwin"@, @"!windows"@).+-- - The second argument is the current platform, typically @System.Info.os@ (e.g. @"linux"@, @"darwin"@, @"mingw32"@).+--+-- Semantics (result is 'True' when the test should run):+-- - Supported platform names: @"linux"@, @"darwin"@, @"mingw32"@, @"windows"@ (alias for @"mingw32"@), and @"unix"@ (alias for @"linux | darwin"@).+-- - Supported operators: NOT @!@, AND @&@, OR @|@.+-- - Unknown simple names evaluate to 'False' (do not run).+-- - Malformed or empty expressions evaluate to 'True' (default to running).+-- Malformed includes the presence of operator characters without a valid parse.+-- - Parentheses characters @(@ and @)@ are tokenized but grouping is not currently implemented;+-- using parentheses in the expression will cause it to be treated as malformed and therefore+-- default to 'True' (run). Prefer composing with @&@ and @|@ without parentheses.+--+-- Examples:+--+-- @+-- evaluatePlatformExpression "linux" "linux" == True+-- evaluatePlatformExpression "linux" "darwin" == False+-- evaluatePlatformExpression "!windows" "mingw32" == False+-- evaluatePlatformExpression "linux|darwin" "darwin" == True+-- evaluatePlatformExpression "unix" "darwin" == True -- alias for linux|darwin+-- evaluatePlatformExpression "unknown" "linux" == False -- unknown simple name+-- evaluatePlatformExpression "" "linux" == True -- empty -> run+-- @+evaluatePlatformExpression :: String -> String -> Bool+evaluatePlatformExpression expr currentPlatform = + case parsePlatformExpression expr of+ Just result -> evalExpression result currentPlatform+ Nothing -> + -- If it's just a simple unknown platform name, return False+ -- If it's an empty/malformed expression, return True+ let malformedOrEmpty = null (words expr) || any (`elem` ['&', '|', '!', '(', ')']) expr+ in malformedOrEmpty++-- Parse a platform expression with logical operators+parsePlatformExpression :: String -> Maybe PlatformExpr+parsePlatformExpression expr = parseOr (tokenize expr)++-- Tokenize the expression preserving logical operators+tokenize :: String -> [String]+tokenize = words . concatMap tokenizeChar+ where+ tokenizeChar '&' = " & "+ tokenizeChar '|' = " | " + tokenizeChar '(' = " ( "+ tokenizeChar ')' = " ) "+ tokenizeChar c = [c]++-- Parse OR expressions (lowest precedence)+parseOr :: [String] -> Maybe PlatformExpr+parseOr tokens = case break (== "|") tokens of+ (left, []) -> parseAnd left+ (left, _:right) -> do+ leftExpr <- parseAnd left+ rightExpr <- parseOr right+ return $ Or leftExpr rightExpr++-- Parse AND expressions (higher precedence)+parseAnd :: [String] -> Maybe PlatformExpr+parseAnd tokens = case break (== "&") tokens of+ (left, []) -> parseAtom left+ (left, _:right) -> do+ leftExpr <- parseAtom left+ rightExpr <- parseAnd right+ return $ And leftExpr rightExpr++-- Parse atomic expressions (platform names and negation)+parseAtom :: [String] -> Maybe PlatformExpr+parseAtom [] = Nothing+parseAtom tokens = case tokens of+ ["linux"] -> Just $ PlatformName "linux"+ ["darwin"] -> Just $ PlatformName "darwin"+ ["windows"] -> Just $ PlatformName "mingw32"+ ["mingw32"] -> Just $ PlatformName "mingw32"+ ["unix"] -> Just $ Or (PlatformName "linux") (PlatformName "darwin")+ ["!linux"] -> Just $ Not (PlatformName "linux")+ ["!darwin"] -> Just $ Not (PlatformName "darwin")+ ["!windows"] -> Just $ Not (PlatformName "mingw32")+ ["!mingw32"] -> Just $ Not (PlatformName "mingw32")+ ["!unix"] -> Just $ Not (Or (PlatformName "linux") (PlatformName "darwin"))+ _ -> Nothing++-- Simple expression data type+data PlatformExpr + = PlatformName String+ | Not PlatformExpr+ | And PlatformExpr PlatformExpr + | Or PlatformExpr PlatformExpr+ deriving stock (Show, Eq)++-- Evaluate the expression against the current platform+evalExpression :: PlatformExpr -> String -> Bool+evalExpression expr currentPlatform = case expr of+ PlatformName platformName -> currentPlatform == platformName+ Not e -> not (evalExpression e currentPlatform)+ And e1 e2 -> evalExpression e1 currentPlatform && evalExpression e2 currentPlatform+ Or e1 e2 -> evalExpression e1 currentPlatform || evalExpression e2 currentPlatform
src/Test/Tasty/Discover/Internal/Config.hs view
@@ -7,6 +7,13 @@ ( -- * Configuration Options Config (..) , GlobPattern+ , SkipTest (..)+ , OnPlatform (..)+ , checkPlatform+ , onLinux+ , onDarwin + , onWindows+ , onUnix -- * Configuration Parser , parseConfig@@ -16,8 +23,11 @@ ) where import Data.Maybe (isJust)+import GHC.Generics (Generic) import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), ArgOrder (Permute), OptDescr (Option), getOpt') import System.FilePath ((</>))+import System.Info (os)+import Test.Tasty.Options (IsOption (..), safeRead) -- | A tasty ingredient. type Ingredient = String@@ -25,6 +35,79 @@ -- | A glob pattern. type GlobPattern = String +-- | Newtype wrapper for skip test option.+--+-- This option type integrates with Tasty's option system to control whether+-- tests should be skipped. When set to @SkipTest True@, tests will show as+-- @[SKIPPED]@ in yellow in the test output and won't actually execute.+--+-- Used internally by the 'skip' function and 'Flavored' type to implement+-- test skipping functionality.+newtype SkipTest = SkipTest Bool+ deriving stock (Show, Eq, Generic)++instance IsOption SkipTest where+ defaultValue = SkipTest False+ parseValue = fmap SkipTest . safeRead+ optionName = return "skip-test"+ optionHelp = return "Skip test execution (useful for debugging test discovery)"++-- | Newtype wrapper for platform-specific test filtering.+--+-- This option type allows tests to be conditionally executed based on platform+-- criteria. The wrapped function takes a platform string and returns whether+-- the test should run on that platform.+--+-- Platform values correspond to System.Info.os:+-- - "linux" for Linux systems+-- - "darwin" for macOS+-- - "mingw32" for Windows (GHC compiled)+-- - "unix" matches both "linux" and "darwin"+--+-- Example usage:+-- @+-- -- Only run on Linux+-- onLinux :: OnPlatform +-- onLinux = OnPlatform (== "linux")+--+-- -- Run on Unix-like systems+-- onUnix :: OnPlatform+-- onUnix = OnPlatform (\p -> p `elem` ["linux", "darwin"])+-- @+newtype OnPlatform = OnPlatform (String -> Bool)++instance IsOption OnPlatform where+ defaultValue = OnPlatform (const True) -- Run on all platforms by default+ parseValue s = case s of+ "linux" -> Just $ OnPlatform (== "linux")+ "darwin" -> Just $ OnPlatform (== "darwin") + "mingw32" -> Just $ OnPlatform (== "mingw32") -- Windows with GHC+ "windows" -> Just $ OnPlatform (== "mingw32") -- Alias for mingw32+ "unix" -> Just $ OnPlatform (\p -> p `elem` ["linux", "darwin"])+ _ -> Nothing+ optionName = return "on-platform"+ optionHelp = return "Run test only on specified platform (linux|darwin|mingw32|windows|unix)"++-- | Check if the current platform matches the OnPlatform criteria+checkPlatform :: OnPlatform -> Bool+checkPlatform (OnPlatform f) = f os++-- | Helper function: only run on Linux+onLinux :: OnPlatform+onLinux = OnPlatform (== "linux")++-- | Helper function: only run on macOS+onDarwin :: OnPlatform+onDarwin = OnPlatform (== "darwin")++-- | Helper function: only run on Windows (mingw32)+onWindows :: OnPlatform +onWindows = OnPlatform (== "mingw32")++-- | Helper function: only run on Unix-like systems (Linux or macOS)+onUnix :: OnPlatform+onUnix = OnPlatform (\p -> p `elem` ["linux", "darwin"])+ -- | The discovery and runner configuration. data Config = Config { modules :: Maybe GlobPattern -- ^ Glob pattern for matching modules during test discovery.@@ -39,11 +122,12 @@ , noModuleSuffix :: Bool -- ^ <<<DEPRECATED>>>: suffix and look in all modules. , debug :: Bool -- ^ Debug the generated module. , treeDisplay :: Bool -- ^ Tree display for the test results table.- } deriving (Show)+ , noMain :: Bool -- ^ Whether to generate main function.+ } deriving stock (Show, Generic) -- | The default configuration defaultConfig :: FilePath -> Config-defaultConfig theSearchDir = Config Nothing Nothing theSearchDir Nothing Nothing [] [] [] False False False False+defaultConfig theSearchDir = Config Nothing Nothing theSearchDir Nothing Nothing [] [] [] False False False False False -- | Deprecation message for old `--[no-]module-suffix` option. moduleSuffixDeprecationMessage :: String@@ -115,4 +199,7 @@ , Option [] ["tree-display"] (NoArg $ \c -> c {treeDisplay = True}) "Display test output hierarchically"+ , Option [] ["no-main"]+ (NoArg $ \c -> c {noMain = True})+ "Do not generate a main function" ]
src/Test/Tasty/Discover/Internal/Driver.hs view
@@ -10,10 +10,13 @@ , findTests , mkModuleTree , showTests+ , extractTests ) where +import Control.Monad (filterM) import Data.List (dropWhileEnd, intercalate, isPrefixOf, nub, sort, stripPrefix) import Data.Maybe (fromMaybe)+import System.Directory (doesFileExist) import System.FilePath (pathSeparator) import System.FilePath.Glob (compile, globDir1, match) import System.IO (IOMode (ReadMode), withFile)@@ -30,14 +33,6 @@ import GHC.IO.Handle (hGetContents) #endif -defaultImports :: [String]-defaultImports =- [ "import Prelude"- , "import qualified System.Environment as E"- , "import qualified Test.Tasty as T"- , "import qualified Test.Tasty.Ingredients as T"- ]- -- | Main function generator, along with all the boilerplate which -- which will run the discovered tests. generateTestDriver :: Config -> String -> [String] -> FilePath -> [Test] -> String@@ -46,13 +41,31 @@ testNumVars = map (("t"++) . show) [(0 :: Int)..] testKindImports = map generatorImports generators' :: [[String]] testImports = showImports (map ingredientImport is ++ map testModule tests) :: [String]+ exports = if noMain config+ then "(ingredients, tests)"+ else "(main, ingredients, tests)"+ mainFunction = if noMain config+ then ""+ else concat [ "main :: IO ()\n"+ , "main = do\n"+ , " args <- E.getArgs\n"+ , " E.withArgs (" ++ show (tastyOptions config) ++ " ++ args) $"+ , " tests >>= T.defaultMainWithIngredients ingredients\n"+ ]+ -- Only include System.Environment import when main function is generated+ envImport = if noMain config then [] else ["import qualified System.Environment as E"]+ baseImports = [ "import Prelude"+ , "import qualified Test.Tasty as T"+ , "import qualified Test.Tasty.Ingredients as T"+ ] ++ envImport in concat [ "{-# LANGUAGE FlexibleInstances #-}\n" , "\n"- , "module " ++ modname ++ " (main, ingredients, tests) where\n"+ , "module " ++ modname ++ " " ++ exports ++ " where\n" , "\n"- , unlines $ nub $ sort $ mconcat (defaultImports:testKindImports) ++ testImports+ , unlines $ nub $ sort $ mconcat (baseImports:testKindImports) ++ testImports , "\n"+ , "{- HLINT ignore \"Evaluate\" -}\n" , "{- HLINT ignore \"Use let\" -}\n" , "\n" , unlines $ map generatorClass generators'@@ -64,17 +77,16 @@ , "]\n" , "ingredients :: [T.Ingredient]\n" , "ingredients = " ++ ingredients is ++ "\n"- , "main :: IO ()\n"- , "main = do\n"- , " args <- E.getArgs\n"- , " E.withArgs (" ++ show (tastyOptions config) ++ " ++ args) $"- , " tests >>= T.defaultMainWithIngredients ingredients\n"+ , mainFunction ] -- | Match files by specified glob pattern. filesByModuleGlob :: FilePath -> Maybe GlobPattern -> IO [String]-filesByModuleGlob directory globPattern = globDir1 pattern directory- where pattern = compile ("**/" ++ fromMaybe "*.hs*" globPattern)+filesByModuleGlob directory globPattern = do+ allPaths <- globDir1 pattern directory+ -- Filter out directories to avoid "inappropriate type" errors+ filterM doesFileExist allPaths+ where pattern = compile ("**/" ++ fromMaybe "*.hs" globPattern) -- | Filter and remove files by specified glob pattern. ignoreByModuleGlob :: [FilePath] -> Maybe GlobPattern -> [FilePath]@@ -105,12 +117,35 @@ -- | Extract the test names from discovered modules. extractTests :: FilePath -> String -> [Test]-extractTests file = mkTestDeDuped . isKnownPrefix . parseTest- where mkTestDeDuped = map (mkTest file) . nub+extractTests file content = mkTestDeDuped . isKnownPrefix . parseTest . preprocessHaskell $ content+ where mkTestDeDuped :: [String] -> [Test]+ mkTestDeDuped = map (mkTest file) . nub++ isKnownPrefix :: [String] -> [String] isKnownPrefix = filter (\g -> any (checkPrefix g) generators)++ checkPrefix :: String -> Generator -> Bool checkPrefix g = (`isPrefixOf` g) . generatorPrefix++ parseTest :: String -> [String] parseTest = map fst . concatMap lex . lines +-- | Preprocess Haskell source to remove block comments only+preprocessHaskell :: String -> String+preprocessHaskell = removeBlockComments++-- | Remove {- -} block comments (handles nesting)+removeBlockComments :: String -> String+removeBlockComments = go (0 :: Int)+ where+ go _ [] = []+ go depth ('{':'-':rest) = go (depth + 1) rest+ go depth ('-':'}':rest) + | depth > 0 = go (depth - 1) rest+ | otherwise = '-' : '}' : go depth rest+ go 0 (c:rest) = c : go 0 rest+ go depth (_:rest) = go depth rest+ -- | Show the imports. showImports :: [String] -> [String] showImports mods = sort $ map ("import qualified " ++) mods@@ -130,7 +165,7 @@ else zipWith const testNumVars tests newtype ModuleTree = ModuleTree (M.Map String (ModuleTree, [String]))- deriving (Eq, Show)+ deriving stock (Eq, Show) showModuleTree :: ModuleTree -> [String] showModuleTree (ModuleTree mdls) = map showModule $ M.assocs mdls
src/Test/Tasty/Discover/Internal/Generator.hs view
@@ -25,13 +25,16 @@ import Data.Function (on) import Data.List (find, groupBy, isPrefixOf, sortOn) import Data.Maybe (fromJust)+import GHC.Generics (Generic) import System.FilePath (dropExtension, isPathSeparator) +import Test.Tasty.Discover.Internal.Unsafe (unsafeHead)+ -- | The test type. data Test = Test { testModule :: String -- ^ Module name. , testFunction :: String -- ^ Function name.- } deriving (Eq, Show, Ord)+ } deriving stock (Eq, Show, Generic, Ord) -- | 'Test' constructor. mkTest :: FilePath -> String -> Test@@ -44,7 +47,7 @@ , generatorImports :: [String] -- ^ Module import path. , generatorClass :: String -- ^ Generator class. , generatorSetup :: Test -> String -- ^ Generator setup.- }+ } deriving stock (Generic) -- | Module import qualifier. qualifyFunction :: Test -> String@@ -52,7 +55,7 @@ -- | Function namer. name :: Test -> String-name = chooser '_' ' ' . tail . dropWhile (/= '_') . testFunction+name = chooser '_' ' ' . drop 1 . dropWhile (/= '_') . testFunction where chooser c1 c2 = map $ \c3 -> if c3 == c1 then c2 else c3 -- | Generator retriever (single).@@ -61,9 +64,13 @@ where getPrefix = find ((`isPrefixOf` testFunction t) . generatorPrefix) -- | Generator retriever (many).+--+-- Groups tests by generator prefix and extracts one representative generator+-- from each group. Uses 'unsafeHead' because 'groupBy' never produces empty+-- groups when given a non-empty input list. getGenerators :: [Test] -> [Generator] getGenerators =- map head .+ map unsafeHead . groupBy ((==) `on` generatorPrefix) . sortOn generatorPrefix . map getGenerator@@ -89,9 +96,9 @@ hedgehogPropertyGenerator :: Generator hedgehogPropertyGenerator = Generator { generatorPrefix = "hprop_"- , generatorImports = ["import qualified Test.Tasty.Hedgehog as H"]+ , generatorImports = ["import qualified Test.Tasty.Hedgehog as H", "import Data.String (fromString)"] , generatorClass = ""- , generatorSetup = \t -> "pure $ H.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t+ , generatorSetup = \t -> "pure $ H.testPropertyNamed \"" ++ name t ++ "\" (fromString \"" ++ qualifyFunction t ++ "\") " ++ qualifyFunction t } -- | Quickcheck group generator prefix.
+ src/Test/Tasty/Discover/Internal/Unsafe.hs view
@@ -0,0 +1,37 @@+-- | Unsafe utility functions for internal use.+--+-- This module contains partial functions that are used internally+-- where we have strong invariants that guarantee they won't fail,+-- but we want to be explicit about their unsafe nature.++module Test.Tasty.Discover.Internal.Unsafe+ ( unsafeHead+ ) where++-- | Unsafe head function with descriptive error message.+-- +-- This function is partial and will throw an error on empty lists.+-- It should only be used when there's a strong invariant guaranteeing+-- the list is non-empty.+--+-- __Why use this instead of a total function?__+--+-- * Preserves existing type signatures and caller simplicity+-- * Makes invariant violations fail fast with clear error messages+-- * Avoids pushing complexity up the call chain for conditions that should never occur+-- * Used specifically in 'getGenerators' where 'groupBy' never produces empty groups+--+-- __When to use:__+--+-- * Internal functions with strong invariants+-- * Performance-critical code where the invariant is guaranteed+-- * When converting to total functions would complicate the entire call chain+--+-- __When NOT to use:__+--+-- * Public APIs where callers might pass invalid input+-- * When the input domain genuinely includes edge cases+-- * When safety is more important than performance+unsafeHead :: [a] -> a+unsafeHead [] = error "unsafeHead: empty list"+unsafeHead (x:_) = x
src/Test/Tasty/Discover/TastyInfo.hs view
@@ -3,11 +3,12 @@ ) where import Data.Monoid+import GHC.Generics (Generic) data TastyInfo = TastyInfo { name :: Last String , description :: Last String- } deriving (Eq, Show)+ } deriving stock (Eq, Show, Generic) instance Semigroup TastyInfo where a <> b = TastyInfo
tasty-discover.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.2+cabal-version: 3.0 name: tasty-discover-version: 4.2.4+version: 5.2.0 synopsis: Test discovery for the tasty framework. description: Automatic test discovery and runner for the tasty framework. @@ -21,10 +21,10 @@ author: Luke Murphy maintainer: John Ky <newhoggy@gmail.com> copyright: 2016 Luke Murphy- 2020-2021 John Ky+ 2020-2025 John Ky license: MIT license-file: LICENSE-tested-with: GHC == 9.2.2, GHC == 9.0.2, GHC == 8.10.7, GHC == 8.8.4, GHC == 8.6.5+tested-with: GHC == 9.12.2, GHC == 9.10.2, GHC == 9.8.4, GHC == 9.6.7 build-type: Simple extra-source-files: CHANGELOG.md README.md@@ -33,60 +33,83 @@ type: git location: https://github.com/haskell-works/tasty-discover +flag dev+ description: Enable development mode+ manual: True+ default: False+ common base { build-depends: base >= 4.11 && < 5 } +common ansi-terminal { build-depends: ansi-terminal >= 1.0 && < 2.0 } common bytestring { build-depends: bytestring >= 0.9 && < 1.0 } common containers { build-depends: containers >= 0.4 && < 1.0 } common directory { build-depends: directory >= 1.1 && < 2.0 } common filepath { build-depends: filepath >= 1.3 && < 2.0 } common Glob { build-depends: Glob >= 0.8 && < 1.0 } common hedgehog { build-depends: hedgehog >= 1.0 && < 2.0 }-common hspec { build-depends: hspec >= 2.7 && < 2.9 }-common hspec-core { build-depends: hspec-core >= 2.7.10 && < 2.11 }+common hspec { build-depends: hspec >= 2.7 && < 2.12 }+common hspec-core { build-depends: hspec-core >= 2.7.10 && < 2.12 } common tasty { build-depends: tasty >= 1.3 && < 2.0 }-common tasty-discover { build-depends: tasty-discover >= 4.0 && < 5.0 } common tasty-golden { build-depends: tasty-golden >= 2.0 && < 3.0 }-common tasty-hedgehog { build-depends: tasty-hedgehog >= 1.1 && < 2.0 }+common tasty-hedgehog { build-depends: tasty-hedgehog >= 1.2 && < 2.0 } common tasty-hspec { build-depends: tasty-hspec >= 1.1 && < 1.3 } common tasty-hunit { build-depends: tasty-hunit >= 0.10 && < 0.11 } common tasty-quickcheck { build-depends: tasty-quickcheck >= 0.10 && < 0.11 } common tasty-smallcheck { build-depends: tasty-smallcheck >= 0.8 && < 1.0 }+common tasty-expected-failure { build-depends: tasty-expected-failure >= 0.12 && < 0.13 }+common process { build-depends: process >= 1.6 && < 2.0 }+common temporary { build-depends: temporary >= 1.3 && < 1.4 } +common project-config+ default-extensions: DeriveGeneric+ DerivingStrategies+ if (impl(ghc >= 9.2.1))+ default-extensions: OverloadedRecordDot+ ghc-options: -Wall+ -Widentities+ -Wincomplete-uni-patterns+ -Wmissing-deriving-strategies+ -Wredundant-constraints+ -Wunused-packages+ default-language: Haskell2010+ if (flag(dev))+ ghc-options: -Werror++common tasty-discover+ build-depends: tasty-discover+ library+ import: base, project-config+ , ansi-terminal+ , containers+ , directory+ , filepath+ , Glob+ , tasty exposed-modules: Test.Tasty.Discover Test.Tasty.Discover.Internal.Config Test.Tasty.Discover.Internal.Driver Test.Tasty.Discover.Internal.Generator+ Test.Tasty.Discover.Internal.Unsafe Test.Tasty.Discover.TastyInfo Test.Tasty.Discover.Version other-modules: Paths_tasty_discover autogen-modules: Paths_tasty_discover hs-source-dirs: src- ghc-options: -Wall- build-depends: base >= 4.8 && < 5.0- , Glob >= 0.8 && < 1.0- , containers >= 0.4 && < 1.0- , directory >= 1.1 && < 2.0- , filepath >= 1.3 && < 2.0- , tasty >= 1.3 && < 2.0 default-language: Haskell2010 -executable tasty-discover- import: base- , Glob- , containers- , directory+executable tasty-discover+ import: base, project-config , filepath- main-is: executable/Main.hs+ main-is: app/Main.hs autogen-modules: Paths_tasty_discover other-modules: Paths_tasty_discover- ghc-options: -Wall build-depends: tasty-discover default-language: Haskell2010 test-suite tasty-discover-test- import: base- , Glob+ import: base, project-config+ , ansi-terminal , bytestring , containers , directory@@ -94,25 +117,47 @@ , hedgehog , hspec , hspec-core+ , process , tasty+ , tasty-expected-failure , tasty-golden , tasty-hedgehog , tasty-hspec , tasty-hunit , tasty-quickcheck , tasty-smallcheck+ , temporary type: exitcode-stdio-1.0 main-is: Driver.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N- other-modules: ConfigTest+ other-modules: BackupFiles.ValidTest+ ConfigTest DiscoverTest+ ModulesGlob.Sub.OneTest+ ModulesGlob.TwoTest SubMod.FooBaz SubMod.PropTest SubMod.SubSubMod.PropTest- Paths_tasty_discover+ other-modules: Paths_tasty_discover autogen-modules: Paths_tasty_discover hs-source-dirs: test- ghc-options: -Wall+ build-depends: tasty-discover+ default-language: Haskell2010+ build-tool-depends: tasty-discover:tasty-discover++test-suite no-main-test+ import: base, project-config+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ type: exitcode-stdio-1.0+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ other-modules: Tests+ Tests.Simple+ other-modules: Paths_tasty_discover+ autogen-modules: Paths_tasty_discover+ hs-source-dirs: test-no-main build-depends: tasty-discover default-language: Haskell2010 build-tool-depends: tasty-discover:tasty-discover
+ test-no-main/Main.hs view
@@ -0,0 +1,19 @@+module Main where++import qualified Tests+import qualified Test.Tasty as T++main :: IO ()+main = do+ putStrLn "=== No-Main Feature Test ==="+ putStrLn "This test demonstrates the --no-main option"+ putStrLn "where Tests module has no main function.\n"++ -- Get the discovered tests from the Tests module+ discoveredTests <- Tests.tests++ -- Apply a custom wrapper to demonstrate custom main functionality+ let wrappedTests = T.testGroup "Custom No-Main Wrapper" [discoveredTests]++ -- Run tests using ingredients from Tests module+ T.defaultMainWithIngredients Tests.ingredients wrappedTests
+ test-no-main/Tests.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --no-main -optF --generated-module -optF Tests -optF --in-place #-}+-- GENERATED BY tasty-discover+{-# LANGUAGE FlexibleInstances #-}++module Tests (ingredients, tests) where++import Prelude+import qualified Test.Tasty as T+import qualified Test.Tasty.Discover as TD+import qualified Test.Tasty.HUnit as HU+import qualified Test.Tasty.Ingredients as T+import qualified Test.Tasty.QuickCheck as QC+import qualified Tests.Simple++{- HLINT ignore "Evaluate" -}+{- HLINT ignore "Use let" -}++++class TestCase a where testCase :: String -> a -> IO T.TestTree+instance TestCase (IO ()) where testCase n = pure . HU.testCase n+instance TestCase (IO String) where testCase n = pure . HU.testCaseInfo n+instance TestCase ((String -> IO ()) -> IO ()) where testCase n = pure . HU.testCaseSteps n++tests :: IO T.TestTree+tests = do+ t0 <- testCase "simpleTest" Tests.Simple.unit_simpleTest++ t1 <- pure $ QC.testProperty "alwaysTrue" Tests.Simple.prop_alwaysTrue++ t2 <- TD.tasty (TD.description "customGroup" <> TD.name "Tests.Simple.tasty_customGroup") Tests.Simple.tasty_customGroup++ pure $ T.testGroup "test-no-main/Tests.hs" [t0,t1,t2]+ingredients :: [T.Ingredient]+ingredients = T.defaultIngredients+
+ test-no-main/Tests/Simple.hs view
@@ -0,0 +1,17 @@+module Tests.Simple where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HU++-- Simple test cases for the no-main feature demo+unit_simpleTest :: IO ()+unit_simpleTest = pure ()++prop_alwaysTrue :: Bool -> Bool+prop_alwaysTrue _ = True++tasty_customGroup :: T.TestTree+tasty_customGroup = T.testGroup "Custom Test Group"+ [ HU.testCase "custom test 1" $ return ()+ , HU.testCase "custom test 2" $ (1 + 1 :: Int) HU.@?= 2+ ]
+ test/BackupFiles/ValidTest.hs view
@@ -0,0 +1,8 @@+module BackupFiles.ValidTest where++-- This module is part of the regression test for spec_backupFilesIgnored+-- in ConfigTest.hs. The accompanying .hs.orig and .hs.bak files test+-- that tasty-discover only processes .hs files and ignores backup files.++prop_validTest :: Bool -> Bool+prop_validTest _ = True
test/ConfigTest.hs view
@@ -5,19 +5,32 @@ module ConfigTest where -import Data.List (isInfixOf, sort)+import Data.List (isInfixOf, isSuffixOf, sort)+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode) import Test.Tasty.Discover.Internal.Config-import Test.Tasty.Discover.Internal.Driver (ModuleTree (..), findTests, generateTestDriver, mkModuleTree, showTests)+import Test.Tasty.Discover.Internal.Driver (ModuleTree (..), findTests, generateTestDriver, mkModuleTree, showTests, extractTests) import Test.Tasty.Discover.Internal.Generator (Test (..), mkTest) -import Test.Tasty.HUnit+import Test.Tasty.HUnit hiding (Assertion) import Test.Tasty.QuickCheck import Test.Hspec.Core.Spec (Spec, describe, it) import Test.Hspec (shouldBe, shouldSatisfy)+import Test.Tasty.ExpectedFailure (expectFail)+import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HU+import qualified Test.Tasty.Discover as TD import qualified Data.Map.Strict as M +-- For symlinks test+import System.Directory (createDirectoryIfMissing, createFileLink,+ doesDirectoryExist, listDirectory)+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)+import System.IO.Temp (withSystemTempDirectory)+import System.Exit (ExitCode(..))+ spec_modules :: Spec spec_modules = describe "Test discovery" $ do it "Discovers tests" $ do@@ -42,6 +55,29 @@ discoveredTests <- findTests badGlobConfig discoveredTests `shouldBe` [] +spec_backupFilesIgnored :: Spec+spec_backupFilesIgnored = describe "Backup file filtering" $ do+ it "Only matches .hs files, not backup files containing .hs" $ do+ let config = defaultConfig "test/BackupFiles"+ discoveredTests <- findTests config+ -- Should only find ValidTest.hs, not ValidTest.hs.orig or ValidTest.hs.bak+ let moduleNames = map testModule discoveredTests+ length discoveredTests `shouldBe` 1+ moduleNames `shouldBe` ["ValidTest"]+ -- Verify no backup file patterns were found+ let hasBackupPattern name = ".hs." `isInfixOf` name || ".hs" `isInfixOf` name && not (".hs" `isSuffixOf` name)+ moduleNames `shouldSatisfy` (not . any hasBackupPattern)++spec_modulesGlobIgnoresDirectories :: Spec+spec_modulesGlobIgnoresDirectories = describe "Modules glob directory handling" $ do+ it "Ignores directories that match the glob pattern" $ do+ let config = (defaultConfig "test/ModulesGlob") { modules = Just "*" }+ discoveredTests <- findTests config+ -- Should find both test files, not fail on the Sub directory+ let moduleNames = sort $ map testModule discoveredTests+ length discoveredTests `shouldBe` 2+ moduleNames `shouldBe` ["Sub.OneTest", "TwoTest"]+ spec_customModuleName :: Spec spec_customModuleName = describe "Module name configuration" $ do it "Creates a generated main function with the specified name" $ do@@ -83,3 +119,257 @@ else resize (size `div` 2) arbitrary tVars <- listOf1 (listOf1 arbitrary) pure (mdl, (subTree, tVars))++spec_commentHandling :: Spec+spec_commentHandling = describe "Comment handling" $ do+ it "ignores tests in block comments" $ do+ let content = unlines+ [ "module Test where"+ , "{- block comment"+ , "test_ignored :: TestTree"+ , "test_ignored = testCase \"ignored\" $ pure ()"+ , "-}"+ , "test_valid :: TestTree"+ , "test_valid = testCase \"valid\" $ pure ()"+ ]+ let tests = extractTests "Test.hs" content+ testNames = map testFunction tests+ testNames `shouldBe` ["test_valid"]++ it "ignores tests in nested block comments" $ do+ let content = unlines+ [ "module Test where"+ , "{- outer comment"+ , "test_outerIgnored :: TestTree"+ , " {- inner comment"+ , "test_innerIgnored :: TestTree"+ , " -}"+ , "test_stillOuterIgnored :: TestTree"+ , "-}"+ , "test_valid :: TestTree"+ ]+ let tests = extractTests "Test.hs" content+ testNames = map testFunction tests+ testNames `shouldBe` ["test_valid"]++ it "correctly handles line comments (existing behavior)" $ do+ let content = unlines+ [ "module Test where"+ , "-- test_lineIgnored :: TestTree"+ , "-- test_lineIgnored = testCase \"ignored\" $ pure ()"+ , "test_valid :: TestTree"+ , "test_valid = testCase \"valid\" $ pure ()"+ ]+ let tests = extractTests "Test.hs" content+ testNames = map testFunction tests+ testNames `shouldBe` ["test_valid"]++ it "finds multiple valid tests correctly" $ do+ let content = unlines+ [ "module Test where"+ , "test_first :: TestTree"+ , "{-"+ , "test_ignored :: TestTree"+ , "-}"+ , "test_second :: TestTree"+ , "test_third :: TestTree"+ ]+ let tests = extractTests "Test.hs" content+ testNames = sort $ map testFunction tests+ testNames `shouldBe` sort ["test_first", "test_second", "test_third"]++{- |+= Custom Test Type Wrapping Pattern++This module demonstrates how to create custom test type wrappers using the @newtype@ pattern+to integrate external testing libraries with tasty-discover's @Tasty@ typeclass and provide+ergonomic flavor functionality (such as skipping tests).++== The Pattern++1. **Wrap external test types**: Use @newtype@ to wrap test types from other libraries+ (e.g., HUnit's @Assertion@, QuickCheck's @Property@, etc.)++2. **Implement Tasty instance**: Provide a @Tasty@ instance that handles the @SkipTest@ option+ and other flavor transformations++3. **Ergonomic skipping**: Tests can be easily skipped using the @Flavored@ pattern with+ visual feedback (yellow @[SKIPPED]@ text)++== Benefits++- **Library Integration**: Seamlessly integrate any testing library with tasty-discover+- **Consistent Interface**: All test types get the same flavor functionality (skip, platform, etc.)+- **Visual Feedback**: Skipped tests are clearly marked with colored @[SKIPPED]@ indicators+- **Type Safety**: @newtype@ provides zero-cost abstractions with compile-time guarantees++== Example Implementation++The @Assertion@ newtype below demonstrates this pattern:++@+newtype Assertion = Assertion HU.Assertion++instance TD.Tasty Assertion where+ tasty info (Assertion assertion) = do+ let yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]+ return $ T.askOption $ \\(TD.SkipTest shouldSkip) ->+ if shouldSkip+ then HU.testCase (TD.nameOf info ++ " " ++ yellowText "[SKIPPED]") (pure ())+ else HU.testCase (TD.nameOf info) assertion+@++== Usage Patterns++**Basic test:**+@+tasty_myTest :: Assertion+tasty_myTest = Assertion $ do+ result <- someComputation+ result \@?\= expectedValue+@++**Skipped test:**+@+tasty_skippedTest :: TD.Flavored Assertion+tasty_skippedTest = TD.flavored TD.skip $ Assertion $ do+ -- This will show as [SKIPPED] in yellow and won't execute+ error "This never runs"+@++**Platform-conditional test:**+@+tasty_linuxOnly :: TD.Flavored Assertion+tasty_linuxOnly = TD.flavored (TD.platform "linux") $ Assertion $ do+ -- Only runs on Linux systems+ linuxSpecificAssertion+@++== Integration with Other Libraries++This pattern can be applied to any testing library:++- **Hedgehog**: @newtype Property = Property H.Property@+- **QuickCheck**: @newtype QCProperty = QCProperty QC.Property@+- **Hspec**: @newtype SpecTest = SpecTest Spec@+- **Custom frameworks**: @newtype MyTest = MyTest MyLibrary.Test@++Each wrapper can implement the @Tasty@ instance to provide consistent flavor functionality+across all test types in your project.+-}++-- | Custom Assertion newtype that wraps HU.Assertion+--+-- This demonstrates the newtype wrapping pattern for integrating external test types+-- with tasty-discover's Tasty typeclass and flavor functionality.+newtype Assertion = Assertion HU.Assertion++-- | Tasty instance for Assertion that provides SkipTest support+--+-- Key features:+-- * Checks SkipTest option at runtime using askOption+-- * Renders skipped tests with yellow [SKIPPED] indicator+-- * Falls back to normal HUnit test execution when not skipped+-- * Maintains test name consistency through TD.nameOf+instance TD.Tasty Assertion where+ tasty info (Assertion assertion) = do+ let yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]+ return $ T.askOption $ \(TD.SkipTest shouldSkip) ->+ if shouldSkip+ then HU.testCase (TD.nameOf info ++ " " ++ yellowText "[SKIPPED]") (pure ())+ else HU.testCase (TD.nameOf info) assertion++-- | Example: Basic usage of the Assertion newtype+--+-- Shows how to create a simple test using the wrapped type.+-- The test will execute normally unless skipped via flavoring.+tasty_assertionExample :: Assertion+tasty_assertionExample = Assertion $ do+ let result = 2 + 2 :: Int+ result @?= 4++-- | Example: Skipped test using Flavored pattern+--+-- Demonstrates how the newtype integrates with the Flavored mechanism+-- to provide ergonomic test skipping with visual feedback.+tasty_skippedAssertion :: TD.Flavored Assertion+tasty_skippedAssertion = TD.flavored TD.skip $ Assertion $ do+ -- This test will be skipped and show "[SKIPPED]" in yellow+ error "This should never run because the test is skipped"++-- | Example: Platform-conditional test+--+-- Shows how the same newtype can work with platform filtering,+-- demonstrating the composability of flavor transformations.+tasty_platformAssertion :: TD.Flavored Assertion+tasty_platformAssertion = TD.flavored (TD.platform "!windows") $ Assertion $ do+ -- This test only runs on non-Windows platforms+ let unixSpecificResult = "Unix-style path" :: String+ length unixSpecificResult @?= 15++spec_symlinksNotFollowed :: Spec+spec_symlinksNotFollowed = describe "Symlinks handling" $ do+ it "this test is disabled - see tasty_symlinksNotFollowed instead" $ do+ pure () :: IO ()++-- Tasty test that expects failure for symlink handling+tasty_symlinksNotFollowed :: IO T.TestTree+tasty_symlinksNotFollowed = do+ pure $ expectFail $ HU.testCase "should handle symlinked directories gracefully without crashing" $ do+ withSystemTempDirectory "tasty-discover-symlink-test" $ \tmpDir -> do+ -- Create a real test directory with a test file+ let realTestDir = tmpDir </> "real-tests"+ createDirectoryIfMissing True realTestDir+ writeFile (realTestDir </> "RealTest.hs") $ unlines+ [ "module RealTest where"+ , "import Test.Tasty.HUnit"+ , "test_real :: TestTree"+ , "test_real = testCase \"real test\" $ 1 @?= 1"+ ]++ -- Create a symlinked directory pointing to the real test directory+ let symlinkTestDir = tmpDir </> "symlinked-tests"+ createFileLink realTestDir symlinkTestDir++ -- Verify symlink was created+ symlinkExists <- doesDirectoryExist symlinkTestDir+ symlinkExists `shouldBe` True++ -- Helper function to print directory structure for debugging+ let printDirStructure dir prefix = do+ contents <- listDirectory dir+ mapM_ (\item -> do+ let fullPath = dir </> item+ isDir <- doesDirectoryExist fullPath+ if isDir+ then do+ putStrLn $ prefix ++ item ++ "/ (directory)"+ printDirStructure fullPath (prefix ++ " ")+ else putStrLn $ prefix ++ item+ ) contents++ -- Run tasty-discover on the temp directory+ let outputFile = tmpDir </> "TestOutput.hs"+ (exitCode, _stdout, stderr) <- readProcessWithExitCode "tasty-discover" [tmpDir, "--output", outputFile] ""++ -- tasty-discover should NOT crash on symlinked directories+ -- This test will FAIL until issue #38 is fixed, which is the correct behavior+ case exitCode of+ ExitFailure code -> do+ putStrLn $ "tasty-discover crashed with exit code " ++ show code+ putStrLn $ "Test directory structure in " ++ tmpDir ++ ":"+ printDirStructure tmpDir ""+ putStrLn $ "stderr: " ++ stderr+ if "withFile: inappropriate type (is a directory)" `isInfixOf` stderr+ then error "BUG: tasty-discover crashes on symlinked directories (GitHub issue #38). This test will pass when the issue is fixed."+ else error $ "tasty-discover failed for unexpected reason: " ++ stderr+ ExitSuccess -> do+ -- Success! tasty-discover handled symlinks gracefully+ putStrLn "tasty-discover handled symlinks gracefully!"+ testOutput <- readFile outputFile+ -- Verify that at least the real test was found+ testOutput `shouldSatisfy` ("RealTest" `isInfixOf`)+ -- The behavior when symlinks are handled correctly could be:+ -- 1. Symlinks are followed (tests appear twice)+ -- 2. Symlinks are ignored (tests appear once)+ -- Either is acceptable as long as no crash occurs
test/DiscoverTest.hs view
@@ -1,16 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} +{- HLINT ignore "Avoid reverse" -}+{- HLINT ignore "Redundant reverse" -}+ module DiscoverTest where import Data.ByteString.Lazy (ByteString) import Data.List+import Data.Maybe (listToMaybe) import Data.String (IsString(..))+import GHC.Generics (Generic)+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode) import Test.Hspec (shouldBe) import Test.Hspec.Core.Spec (Spec, describe, it) import Test.Tasty+import Test.Tasty.Discover (Flavored, flavored, skip, platform, applySkips, evaluatePlatformExpression) import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding (Property, property)@@ -18,8 +24,10 @@ import qualified Hedgehog as H import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R+import qualified Test.Tasty as TT import qualified Test.Tasty.Discover as TD import qualified Test.Tasty.Hedgehog as TH+import qualified Test.Tasty.HUnit as HU ------------------------------------------------------------------------------------------------ @@ -41,7 +49,7 @@ spec_prelude :: Spec spec_prelude = describe "Prelude.head" $ do it "returns the first element of a list" $ do- head [23 ..] `shouldBe` (23 :: Int)+ listToMaybe [23 ..] `shouldBe` Just (23 :: Int) ------------------------------------------------------------------------------------------------ @@ -69,33 +77,321 @@ test_generateTrees = pure (map (\s -> testCase s $ pure ()) ["First input", "Second input"]) --------------------------------------------------------------------------------------------------- How to add custom support for hedgehog to avoid deprecation warning from tasty-hedgehog+-- How to simultaneously support tasty-hedgehog <1.2 and ^>1.2 using a custom test newtype Property = Property { unProperty :: H.Property } instance TD.Tasty Property where- tasty info (Property p) = pure $+ tasty info (Property p) = do+ let name = TD.nameOf info+ let mkTestTree = #if MIN_VERSION_tasty_hedgehog(1, 2, 0)- TH.testPropertyNamed (TD.nameOf info) (fromString (TD.descriptionOf info)) p+ TH.testPropertyNamed name (fromString (TD.descriptionOf info)) #else- TH.testProperty (TD.nameOf info) p+ TH.testProperty name #endif+ yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]+ -- Apply skip functionality if SkipTest option is True+ pure $ askOption $ \(TD.SkipTest shouldSkip) ->+ if shouldSkip+ then testCase (TD.nameOf info ++ " " ++ yellowText "[SKIPPED]") (pure ())+ else mkTestTree p property :: HasCallStack => H.PropertyT IO () -> Property property = Property . H.property -{- HLINT ignore "Avoid reverse" -} tasty_reverse :: Property tasty_reverse = property $ do xs <- H.forAll $ G.list (R.linear 0 100) G.alpha reverse (reverse xs) H.=== xs +tasty_skip_me :: Flavored Property+tasty_skip_me =+ flavored skip $ property $ do+ H.failure++-- Skipping guideline (read this first):+-- To skip a tasty_ test at the TestTree level (so it shows [SKIPPED] and+-- doesn’t run), use: flavored skip $ ...+-- Applying skip directly to a TestTree won’t skip it at that outer level; the+-- test itself must check SkipTest via askOption.+--+-- Implementation details (for the curious):+-- Applying skip to an already-constructed TestTree sets a Tasty option on the+-- subtree. The test body can observe it (as asserted below), but the Tasty+-- instance used by tasty_ functions may have already decided how to wrap the+-- node, so you won’t see a top-level [SKIPPED] placeholder. Wrapping with+-- flavored skip applies the transformation earlier, letting the instance see+-- SkipTest and short-circuit with a skipped placeholder.+tasty_tree_of_testCase_not_skipped :: TT.TestTree+tasty_tree_of_testCase_not_skipped =+ skip $ askOption $ \(TD.SkipTest shouldSkip) ->+ HU.testCase "This test is not skipped at the TestTree level" $+ HU.assertBool "Expected SkipTest to be True inside TestTree" shouldSkip+ --------------------------------------------------------------------------------------------------- How to use tasty-hedgehog up to version 1.1+-- Platform expression tests -{- HLINT ignore "Avoid reverse" -}+-- Test basic platform matching+unit_platformExpression_linux :: Assertion +unit_platformExpression_linux =+ evaluatePlatformExpression "linux" "linux" @?= True++unit_platformExpression_darwin :: Assertion+unit_platformExpression_darwin =+ evaluatePlatformExpression "darwin" "darwin" @?= True++unit_platformExpression_windows :: Assertion+unit_platformExpression_windows =+ evaluatePlatformExpression "windows" "mingw32" @?= True++unit_platformExpression_mingw32 :: Assertion+unit_platformExpression_mingw32 =+ evaluatePlatformExpression "mingw32" "mingw32" @?= True++-- Test negation+unit_platformExpression_not_linux :: Assertion+unit_platformExpression_not_linux =+ evaluatePlatformExpression "!linux" "darwin" @?= True++unit_platformExpression_not_linux_false :: Assertion+unit_platformExpression_not_linux_false =+ evaluatePlatformExpression "!linux" "linux" @?= False++unit_platformExpression_not_darwin :: Assertion+unit_platformExpression_not_darwin =+ evaluatePlatformExpression "!darwin" "linux" @?= True++unit_platformExpression_not_darwin_false :: Assertion+unit_platformExpression_not_darwin_false =+ evaluatePlatformExpression "!darwin" "darwin" @?= False++unit_platformExpression_not_windows :: Assertion+unit_platformExpression_not_windows =+ evaluatePlatformExpression "!windows" "linux" @?= True++unit_platformExpression_not_windows_false :: Assertion+unit_platformExpression_not_windows_false =+ evaluatePlatformExpression "!windows" "mingw32" @?= False++unit_platformExpression_not_mingw32 :: Assertion+unit_platformExpression_not_mingw32 =+ evaluatePlatformExpression "!mingw32" "linux" @?= True++unit_platformExpression_not_mingw32_false :: Assertion+unit_platformExpression_not_mingw32_false =+ evaluatePlatformExpression "!mingw32" "mingw32" @?= False++unit_platformExpression_not_unix :: Assertion+unit_platformExpression_not_unix =+ evaluatePlatformExpression "!unix" "mingw32" @?= True++unit_platformExpression_not_unix_false_linux :: Assertion+unit_platformExpression_not_unix_false_linux =+ evaluatePlatformExpression "!unix" "linux" @?= False++unit_platformExpression_not_unix_false_darwin :: Assertion+unit_platformExpression_not_unix_false_darwin =+ evaluatePlatformExpression "!unix" "darwin" @?= False++-- Test conjunction (AND)+unit_platformExpression_and_true :: Assertion+unit_platformExpression_and_true =+ evaluatePlatformExpression "!windows & !darwin" "linux" @?= True++unit_platformExpression_and_false :: Assertion+unit_platformExpression_and_false =+ evaluatePlatformExpression "!windows & !darwin" "darwin" @?= False++unit_platformExpression_and_false_windows :: Assertion+unit_platformExpression_and_false_windows =+ evaluatePlatformExpression "!windows & !darwin" "mingw32" @?= False++unit_platformExpression_and_both_positive :: Assertion+unit_platformExpression_and_both_positive =+ evaluatePlatformExpression "unix & !windows" "linux" @?= True++unit_platformExpression_and_both_positive_false :: Assertion+unit_platformExpression_and_both_positive_false =+ evaluatePlatformExpression "unix & !windows" "mingw32" @?= False++unit_platformExpression_and_three_terms :: Assertion+unit_platformExpression_and_three_terms =+ evaluatePlatformExpression "!windows & !darwin & !mingw32" "linux" @?= True++-- Test disjunction (OR)+unit_platformExpression_or_true :: Assertion+unit_platformExpression_or_true =+ evaluatePlatformExpression "linux | darwin" "linux" @?= True++unit_platformExpression_or_true_darwin :: Assertion+unit_platformExpression_or_true_darwin =+ evaluatePlatformExpression "linux | darwin" "darwin" @?= True++unit_platformExpression_or_false :: Assertion+unit_platformExpression_or_false =+ evaluatePlatformExpression "linux | darwin" "mingw32" @?= False++unit_platformExpression_or_windows_mingw32 :: Assertion+unit_platformExpression_or_windows_mingw32 =+ evaluatePlatformExpression "windows | linux" "mingw32" @?= True++unit_platformExpression_or_three_platforms :: Assertion+unit_platformExpression_or_three_platforms =+ evaluatePlatformExpression "linux | darwin | windows" "darwin" @?= True++-- Test unix special case+unit_platformExpression_unix_linux :: Assertion+unit_platformExpression_unix_linux =+ evaluatePlatformExpression "unix" "linux" @?= True++unit_platformExpression_unix_darwin :: Assertion+unit_platformExpression_unix_darwin =+ evaluatePlatformExpression "unix" "darwin" @?= True++unit_platformExpression_unix_windows :: Assertion+unit_platformExpression_unix_windows =+ evaluatePlatformExpression "unix" "mingw32" @?= False++-- Test complex expressions+unit_platformExpression_complex1 :: Assertion+unit_platformExpression_complex1 =+ evaluatePlatformExpression "!windows & !darwin" "linux" @?= True++unit_platformExpression_complex2 :: Assertion +unit_platformExpression_complex2 =+ evaluatePlatformExpression "linux | darwin" "freebsd" @?= False++-- Test edge cases+unit_platformExpression_unknown :: Assertion+unit_platformExpression_unknown =+ evaluatePlatformExpression "unknown_platform" "linux" @?= False++unit_platformExpression_empty :: Assertion+unit_platformExpression_empty =+ evaluatePlatformExpression "" "linux" @?= True -- Should default to True on parse failure++unit_platformExpression_unknown_current :: Assertion+unit_platformExpression_unknown_current =+ evaluatePlatformExpression "linux" "freebsd" @?= False++unit_platformExpression_unix_freebsd :: Assertion+unit_platformExpression_unix_freebsd =+ evaluatePlatformExpression "unix" "freebsd" @?= False -- unix only matches linux and darwin++unit_platformExpression_not_unix_freebsd :: Assertion+unit_platformExpression_not_unix_freebsd =+ evaluatePlatformExpression "!unix" "freebsd" @?= True -- freebsd is not unix (in our definition)++------------------------------------------------------------------------------------------------+-- Platform-Specific Test Examples+-- +-- The `platform` function allows you to conditionally run tests based on the current platform.+-- It takes a platform expression string and a TestTree, and returns a TestTree that will only+-- run if the expression evaluates to true for the current platform.+--+-- The `platform` function works best with `tasty_` prefixed tests when using tasty-discover.+-- For custom tests that don't use the `tasty_` prefix, you can apply `platform` directly to TestTrees.+--+-- Platform expression syntax:+-- - Platform names: "linux", "darwin", "windows", "mingw32", "unix"+-- - Logical operators: "&" (AND), "|" (OR), "!" (NOT)+-- - Parentheses for grouping (future enhancement)+-- - Special platform "unix" matches both "linux" and "darwin"+-- - Platform name "windows" is mapped to "mingw32" (the actual System.Info.os value)+--+-- Examples:+-- platform "linux" test -- Run only on Linux+-- platform "!windows" test -- Run on all platforms except Windows +-- platform "!windows & !darwin" test -- Run on platforms that are neither Windows nor Darwin+-- platform "linux | darwin" test -- Run on Linux or Darwin (Unix-like systems)+-- platform "unix" test -- Run on Unix-like systems (Linux or Darwin)++-- Simple platform-specific tests using tasty_ prefix+tasty_linuxOnly :: TestTree+tasty_linuxOnly = platform "linux" $ testCase "Linux-specific functionality" $ do+ -- This test only runs on Linux+ pure ()++tasty_notWindows :: TestTree +tasty_notWindows = platform "!windows" $ testCase "Non-Windows functionality" $ do+ -- This test runs on all platforms except Windows+ pure ()++tasty_unixLike :: TestTree+tasty_unixLike = platform "unix" $ testCase "Unix-like systems" $ do+ -- This test runs on Linux and Darwin (Unix-like systems)+ pure ()++-- Complex platform expressions+tasty_complexPlatform1 :: TestTree+tasty_complexPlatform1 = platform "!windows & !darwin" $ testCase "Neither Windows nor Darwin" $ do+ -- This test runs on platforms that are neither Windows nor Darwin (e.g., Linux)+ pure ()++tasty_complexPlatform2 :: TestTree+tasty_complexPlatform2 = platform "linux | darwin" $ testCase "Linux or Darwin only" $ do+ -- This test runs on either Linux or Darwin, but not Windows+ pure ()++-- Property tests with platform filtering+tasty_platformSpecific :: TestTree+tasty_platformSpecific = platform "!windows" $ testProperty "Property that doesn't work on Windows" $ + \(x :: Int) -> x + 0 == x++-- You can also combine platform filtering with other test transformations+-- using the Flavored type and function composition:++tasty_platformAndSkip :: TestTree +tasty_platformAndSkip = platform "linux" $ skip $ testCase "Linux test that's also skipped" $ do+ -- This would only run on Linux, but it's also skipped, so it never actually runs+ pure ()++-- Test groups with platform filtering+tasty_platformGroup :: TestTree+tasty_platformGroup = platform "unix" $ testGroup "Unix-only tests" + [ testCase "Unix test 1" $ pure ()+ , testCase "Unix test 2" $ pure ()+ , testProperty "Unix property" $ \(x :: Int) -> x >= 0 || x < 0+ ]++-- For more advanced use cases, you can use Flavored with platform filtering+-- This allows you to work with custom test types that have Tasty instances++tasty_platformFlavored :: Flavored TestTree+tasty_platformFlavored = flavored (platform "!windows") $ testCase "Advanced platform test" $ do+ -- This uses the Flavored pattern to apply platform filtering+ pure ()++-- You can also create platform-specific custom Property tests+tasty_platformProperty :: Flavored Property+tasty_platformProperty = flavored (platform "unix") $ property $ do+ -- This hedgehog property only runs on Unix-like systems+ x <- H.forAll $ G.int (R.linear 1 100)+ x H.=== x++-- Helper function to make testProperty respect SkipTest option+testPropertySkippable :: Testable a => String -> a -> TestTree+testPropertySkippable name prop = askOption $ \(TD.SkipTest shouldSkip) ->+ if shouldSkip+ then testCase (name ++ " " ++ yellowText "[SKIPPED]") (pure ())+ else testProperty name prop+ where+ yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]++tasty_testTree_no_darwin :: Flavored (IO TestTree)+tasty_testTree_no_darwin =+ flavored (platform "!darwin") $ pure $ applySkips $ testGroup "Non-Darwin group"+ [ testProperty "Always succeeds" $ \(x :: Int) -> x == x+ , testCase "Another test" $ pure ()+ , testProperty "Yet another" $ \(x :: Int) -> x >= 0 || x < 0+ ]++------------------------------------------------------------------------------------------------+-- How to use the latest version of tasty-hedgehog+ hprop_reverse :: H.Property hprop_reverse = H.property $ do xs <- H.forAll $ G.list (R.linear 0 100) G.alpha@@ -105,9 +401,10 @@ -- How to add custom support for golden tests. data GoldenTest = GoldenTest FilePath (IO ByteString)+ deriving stock (Generic) instance TD.Tasty GoldenTest where tasty info (GoldenTest fp act) = pure $ goldenVsString (TD.descriptionOf info) fp act -case_goldenTest :: GoldenTest-case_goldenTest = GoldenTest "test/SubMod/example.golden" $ return "test"+tasty_goldenTest :: GoldenTest+tasty_goldenTest = GoldenTest "test/SubMod/example.golden" $ return "test"
test/Driver.hs view
@@ -4,9 +4,13 @@ module Main (main, ingredients, tests) where +import Data.String (fromString) import Prelude+import qualified BackupFiles.ValidTest import qualified ConfigTest import qualified DiscoverTest+import qualified ModulesGlob.Sub.OneTest+import qualified ModulesGlob.TwoTest import qualified SubMod.FooBaz import qualified SubMod.PropTest import qualified SubMod.SubSubMod.PropTest@@ -20,6 +24,7 @@ import qualified Test.Tasty.QuickCheck as QC import qualified Test.Tasty.SmallCheck as SC +{- HLINT ignore "Evaluate" -} {- HLINT ignore "Use let" -} @@ -40,49 +45,171 @@ tests :: IO T.TestTree tests = do- t0 <- HS.testSpec "modules" ConfigTest.spec_modules+ t0 <- pure $ QC.testProperty "validTest" BackupFiles.ValidTest.prop_validTest - t1 <- HS.testSpec "ignores" ConfigTest.spec_ignores+ t1 <- HS.testSpec "modules" ConfigTest.spec_modules - t2 <- HS.testSpec "badModuleGlob" ConfigTest.spec_badModuleGlob+ t2 <- HS.testSpec "ignores" ConfigTest.spec_ignores - t3 <- HS.testSpec "customModuleName" ConfigTest.spec_customModuleName+ t3 <- HS.testSpec "badModuleGlob" ConfigTest.spec_badModuleGlob - t4 <- testCase "noTreeDisplayDefault" ConfigTest.unit_noTreeDisplayDefault+ t4 <- HS.testSpec "backupFilesIgnored" ConfigTest.spec_backupFilesIgnored - t5 <- testCase "treeDisplay" ConfigTest.unit_treeDisplay+ t5 <- HS.testSpec "modulesGlobIgnoresDirectories" ConfigTest.spec_modulesGlobIgnoresDirectories - t6 <- pure $ QC.testProperty "mkModuleTree" ConfigTest.prop_mkModuleTree+ t6 <- HS.testSpec "customModuleName" ConfigTest.spec_customModuleName - t7 <- testCase "listCompare" DiscoverTest.unit_listCompare+ t7 <- testCase "noTreeDisplayDefault" ConfigTest.unit_noTreeDisplayDefault - t8 <- pure $ QC.testProperty "additionCommutative" DiscoverTest.prop_additionCommutative+ t8 <- testCase "treeDisplay" ConfigTest.unit_treeDisplay - t9 <- pure $ SC.testProperty "sortReverse" DiscoverTest.scprop_sortReverse+ t9 <- pure $ QC.testProperty "mkModuleTree" ConfigTest.prop_mkModuleTree - t10 <- HS.testSpec "prelude" DiscoverTest.spec_prelude+ t10 <- HS.testSpec "commentHandling" ConfigTest.spec_commentHandling - t11 <- testGroup "addition" DiscoverTest.test_addition+ t11 <- TD.tasty (TD.description "assertionExample" <> TD.name "ConfigTest.tasty_assertionExample") ConfigTest.tasty_assertionExample - t12 <- testGroup "multiplication" DiscoverTest.test_multiplication+ t12 <- TD.tasty (TD.description "skippedAssertion" <> TD.name "ConfigTest.tasty_skippedAssertion") ConfigTest.tasty_skippedAssertion - t13 <- testGroup "generateTree" DiscoverTest.test_generateTree+ t13 <- TD.tasty (TD.description "platformAssertion" <> TD.name "ConfigTest.tasty_platformAssertion") ConfigTest.tasty_platformAssertion - t14 <- testGroup "generateTrees" DiscoverTest.test_generateTrees+ t14 <- HS.testSpec "symlinksNotFollowed" ConfigTest.spec_symlinksNotFollowed - t15 <- TD.tasty (TD.description "reverse" <> TD.name "DiscoverTest.tasty_reverse") DiscoverTest.tasty_reverse+ t15 <- TD.tasty (TD.description "symlinksNotFollowed" <> TD.name "ConfigTest.tasty_symlinksNotFollowed") ConfigTest.tasty_symlinksNotFollowed - t16 <- pure $ H.testProperty "reverse" DiscoverTest.hprop_reverse+ t16 <- testCase "listCompare" DiscoverTest.unit_listCompare - t17 <- pure $ QC.testProperty "additionCommutative" SubMod.FooBaz.prop_additionCommutative+ t17 <- pure $ QC.testProperty "additionCommutative" DiscoverTest.prop_additionCommutative - t18 <- pure $ QC.testProperty "multiplationDistributiveOverAddition" SubMod.FooBaz.prop_multiplationDistributiveOverAddition+ t18 <- pure $ SC.testProperty "sortReverse" DiscoverTest.scprop_sortReverse - t19 <- pure $ QC.testProperty "additionAssociative" SubMod.PropTest.prop_additionAssociative+ t19 <- HS.testSpec "prelude" DiscoverTest.spec_prelude - t20 <- pure $ QC.testProperty "additionCommutative" SubMod.SubSubMod.PropTest.prop_additionCommutative+ t20 <- testGroup "addition" DiscoverTest.test_addition - pure $ T.testGroup "test/Driver.hs" [t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19,t20]+ t21 <- testGroup "multiplication" DiscoverTest.test_multiplication++ t22 <- testGroup "generateTree" DiscoverTest.test_generateTree++ t23 <- testGroup "generateTrees" DiscoverTest.test_generateTrees++ t24 <- TD.tasty (TD.description "reverse" <> TD.name "DiscoverTest.tasty_reverse") DiscoverTest.tasty_reverse++ t25 <- TD.tasty (TD.description "skip me" <> TD.name "DiscoverTest.tasty_skip_me") DiscoverTest.tasty_skip_me++ t26 <- TD.tasty (TD.description "tree of testCase not skipped" <> TD.name "DiscoverTest.tasty_tree_of_testCase_not_skipped") DiscoverTest.tasty_tree_of_testCase_not_skipped++ t27 <- testCase "platformExpression linux" DiscoverTest.unit_platformExpression_linux++ t28 <- testCase "platformExpression darwin" DiscoverTest.unit_platformExpression_darwin++ t29 <- testCase "platformExpression windows" DiscoverTest.unit_platformExpression_windows++ t30 <- testCase "platformExpression mingw32" DiscoverTest.unit_platformExpression_mingw32++ t31 <- testCase "platformExpression not linux" DiscoverTest.unit_platformExpression_not_linux++ t32 <- testCase "platformExpression not linux false" DiscoverTest.unit_platformExpression_not_linux_false++ t33 <- testCase "platformExpression not darwin" DiscoverTest.unit_platformExpression_not_darwin++ t34 <- testCase "platformExpression not darwin false" DiscoverTest.unit_platformExpression_not_darwin_false++ t35 <- testCase "platformExpression not windows" DiscoverTest.unit_platformExpression_not_windows++ t36 <- testCase "platformExpression not windows false" DiscoverTest.unit_platformExpression_not_windows_false++ t37 <- testCase "platformExpression not mingw32" DiscoverTest.unit_platformExpression_not_mingw32++ t38 <- testCase "platformExpression not mingw32 false" DiscoverTest.unit_platformExpression_not_mingw32_false++ t39 <- testCase "platformExpression not unix" DiscoverTest.unit_platformExpression_not_unix++ t40 <- testCase "platformExpression not unix false linux" DiscoverTest.unit_platformExpression_not_unix_false_linux++ t41 <- testCase "platformExpression not unix false darwin" DiscoverTest.unit_platformExpression_not_unix_false_darwin++ t42 <- testCase "platformExpression and true" DiscoverTest.unit_platformExpression_and_true++ t43 <- testCase "platformExpression and false" DiscoverTest.unit_platformExpression_and_false++ t44 <- testCase "platformExpression and false windows" DiscoverTest.unit_platformExpression_and_false_windows++ t45 <- testCase "platformExpression and both positive" DiscoverTest.unit_platformExpression_and_both_positive++ t46 <- testCase "platformExpression and both positive false" DiscoverTest.unit_platformExpression_and_both_positive_false++ t47 <- testCase "platformExpression and three terms" DiscoverTest.unit_platformExpression_and_three_terms++ t48 <- testCase "platformExpression or true" DiscoverTest.unit_platformExpression_or_true++ t49 <- testCase "platformExpression or true darwin" DiscoverTest.unit_platformExpression_or_true_darwin++ t50 <- testCase "platformExpression or false" DiscoverTest.unit_platformExpression_or_false++ t51 <- testCase "platformExpression or windows mingw32" DiscoverTest.unit_platformExpression_or_windows_mingw32++ t52 <- testCase "platformExpression or three platforms" DiscoverTest.unit_platformExpression_or_three_platforms++ t53 <- testCase "platformExpression unix linux" DiscoverTest.unit_platformExpression_unix_linux++ t54 <- testCase "platformExpression unix darwin" DiscoverTest.unit_platformExpression_unix_darwin++ t55 <- testCase "platformExpression unix windows" DiscoverTest.unit_platformExpression_unix_windows++ t56 <- testCase "platformExpression complex1" DiscoverTest.unit_platformExpression_complex1++ t57 <- testCase "platformExpression complex2" DiscoverTest.unit_platformExpression_complex2++ t58 <- testCase "platformExpression unknown" DiscoverTest.unit_platformExpression_unknown++ t59 <- testCase "platformExpression empty" DiscoverTest.unit_platformExpression_empty++ t60 <- testCase "platformExpression unknown current" DiscoverTest.unit_platformExpression_unknown_current++ t61 <- testCase "platformExpression unix freebsd" DiscoverTest.unit_platformExpression_unix_freebsd++ t62 <- testCase "platformExpression not unix freebsd" DiscoverTest.unit_platformExpression_not_unix_freebsd++ t63 <- TD.tasty (TD.description "linuxOnly" <> TD.name "DiscoverTest.tasty_linuxOnly") DiscoverTest.tasty_linuxOnly++ t64 <- TD.tasty (TD.description "notWindows" <> TD.name "DiscoverTest.tasty_notWindows") DiscoverTest.tasty_notWindows++ t65 <- TD.tasty (TD.description "unixLike" <> TD.name "DiscoverTest.tasty_unixLike") DiscoverTest.tasty_unixLike++ t66 <- TD.tasty (TD.description "complexPlatform1" <> TD.name "DiscoverTest.tasty_complexPlatform1") DiscoverTest.tasty_complexPlatform1++ t67 <- TD.tasty (TD.description "complexPlatform2" <> TD.name "DiscoverTest.tasty_complexPlatform2") DiscoverTest.tasty_complexPlatform2++ t68 <- TD.tasty (TD.description "platformSpecific" <> TD.name "DiscoverTest.tasty_platformSpecific") DiscoverTest.tasty_platformSpecific++ t69 <- TD.tasty (TD.description "platformAndSkip" <> TD.name "DiscoverTest.tasty_platformAndSkip") DiscoverTest.tasty_platformAndSkip++ t70 <- TD.tasty (TD.description "platformGroup" <> TD.name "DiscoverTest.tasty_platformGroup") DiscoverTest.tasty_platformGroup++ t71 <- TD.tasty (TD.description "platformFlavored" <> TD.name "DiscoverTest.tasty_platformFlavored") DiscoverTest.tasty_platformFlavored++ t72 <- TD.tasty (TD.description "platformProperty" <> TD.name "DiscoverTest.tasty_platformProperty") DiscoverTest.tasty_platformProperty++ t73 <- TD.tasty (TD.description "testTree no darwin" <> TD.name "DiscoverTest.tasty_testTree_no_darwin") DiscoverTest.tasty_testTree_no_darwin++ t74 <- pure $ H.testPropertyNamed "reverse" (fromString "DiscoverTest.hprop_reverse") DiscoverTest.hprop_reverse++ t75 <- TD.tasty (TD.description "goldenTest" <> TD.name "DiscoverTest.tasty_goldenTest") DiscoverTest.tasty_goldenTest++ t76 <- pure $ QC.testProperty "subTest" ModulesGlob.Sub.OneTest.prop_subTest++ t77 <- pure $ QC.testProperty "topLevelTest" ModulesGlob.TwoTest.prop_topLevelTest++ t78 <- pure $ QC.testProperty "additionCommutative" SubMod.FooBaz.prop_additionCommutative++ t79 <- pure $ QC.testProperty "multiplationDistributiveOverAddition" SubMod.FooBaz.prop_multiplationDistributiveOverAddition++ t80 <- pure $ QC.testProperty "additionAssociative" SubMod.PropTest.prop_additionAssociative++ t81 <- pure $ QC.testProperty "additionCommutative" SubMod.SubSubMod.PropTest.prop_additionCommutative++ pure $ T.testGroup "test/Driver.hs" [t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19,t20,t21,t22,t23,t24,t25,t26,t27,t28,t29,t30,t31,t32,t33,t34,t35,t36,t37,t38,t39,t40,t41,t42,t43,t44,t45,t46,t47,t48,t49,t50,t51,t52,t53,t54,t55,t56,t57,t58,t59,t60,t61,t62,t63,t64,t65,t66,t67,t68,t69,t70,t71,t72,t73,t74,t75,t76,t77,t78,t79,t80,t81] ingredients :: [T.Ingredient] ingredients = T.defaultIngredients main :: IO ()
+ test/ModulesGlob/Sub/OneTest.hs view
@@ -0,0 +1,4 @@+module ModulesGlob.Sub.OneTest where++prop_subTest :: Bool -> Bool+prop_subTest _ = True
+ test/ModulesGlob/TwoTest.hs view
@@ -0,0 +1,4 @@+module ModulesGlob.TwoTest where++prop_topLevelTest :: Bool -> Bool+prop_topLevelTest _ = True