diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [![tasty-discover-nightly](http://stackage.org/package/tasty-discover/badge/nightly)](http://stackage.org/nightly/package/tasty-discover) [![tasty-discover-lts](http://stackage.org/package/tasty-discover/badge/lts)](http://stackage.org/lts/package/tasty-discover) [![Hackage Status](https://img.shields.io/hackage/v/tasty-discover.svg)](http://hackage.haskell.org/package/tasty-discover) -[![GitHub license](https://img.shields.io/badge/license-MIT-brightgreen.svg)](https://raw.githubusercontent.com/lwm/tasty-discover/master/LICENSE) +[![GitHub license](https://img.shields.io/badge/license-MIT-brightgreen.svg)](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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/executable/Main.hs b/executable/Main.hs deleted file mode 100644 --- a/executable/Main.hs +++ /dev/null @@ -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) diff --git a/src/Test/Tasty/Discover.hs b/src/Test/Tasty/Discover.hs --- a/src/Test/Tasty/Discover.hs +++ b/src/Test/Tasty/Discover.hs @@ -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 "" (getLast (TI.name info))) +nameOf info = + fromMaybe "" (getLast (TI.name info)) descriptionOf :: TastyInfo -> String -descriptionOf info = (fromMaybe "" (getLast (TI.description info))) +descriptionOf info = + fromMaybe "" (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 diff --git a/src/Test/Tasty/Discover/Internal/Config.hs b/src/Test/Tasty/Discover/Internal/Config.hs --- a/src/Test/Tasty/Discover/Internal/Config.hs +++ b/src/Test/Tasty/Discover/Internal/Config.hs @@ -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 -- ^ <<>>: 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" ] diff --git a/src/Test/Tasty/Discover/Internal/Driver.hs b/src/Test/Tasty/Discover/Internal/Driver.hs --- a/src/Test/Tasty/Discover/Internal/Driver.hs +++ b/src/Test/Tasty/Discover/Internal/Driver.hs @@ -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 diff --git a/src/Test/Tasty/Discover/Internal/Generator.hs b/src/Test/Tasty/Discover/Internal/Generator.hs --- a/src/Test/Tasty/Discover/Internal/Generator.hs +++ b/src/Test/Tasty/Discover/Internal/Generator.hs @@ -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. diff --git a/src/Test/Tasty/Discover/Internal/Unsafe.hs b/src/Test/Tasty/Discover/Internal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/Internal/Unsafe.hs @@ -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 diff --git a/src/Test/Tasty/Discover/TastyInfo.hs b/src/Test/Tasty/Discover/TastyInfo.hs --- a/src/Test/Tasty/Discover/TastyInfo.hs +++ b/src/Test/Tasty/Discover/TastyInfo.hs @@ -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 diff --git a/tasty-discover.cabal b/tasty-discover.cabal --- a/tasty-discover.cabal +++ b/tasty-discover.cabal @@ -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 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 diff --git a/test-no-main/Main.hs b/test-no-main/Main.hs new file mode 100644 --- /dev/null +++ b/test-no-main/Main.hs @@ -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 diff --git a/test-no-main/Tests.hs b/test-no-main/Tests.hs new file mode 100644 --- /dev/null +++ b/test-no-main/Tests.hs @@ -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 + diff --git a/test-no-main/Tests/Simple.hs b/test-no-main/Tests/Simple.hs new file mode 100644 --- /dev/null +++ b/test-no-main/Tests/Simple.hs @@ -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 + ] diff --git a/test/BackupFiles/ValidTest.hs b/test/BackupFiles/ValidTest.hs new file mode 100644 --- /dev/null +++ b/test/BackupFiles/ValidTest.hs @@ -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 diff --git a/test/ConfigTest.hs b/test/ConfigTest.hs --- a/test/ConfigTest.hs +++ b/test/ConfigTest.hs @@ -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 diff --git a/test/DiscoverTest.hs b/test/DiscoverTest.hs --- a/test/DiscoverTest.hs +++ b/test/DiscoverTest.hs @@ -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" diff --git a/test/Driver.hs b/test/Driver.hs --- a/test/Driver.hs +++ b/test/Driver.hs @@ -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 () diff --git a/test/ModulesGlob/Sub/OneTest.hs b/test/ModulesGlob/Sub/OneTest.hs new file mode 100644 --- /dev/null +++ b/test/ModulesGlob/Sub/OneTest.hs @@ -0,0 +1,4 @@ +module ModulesGlob.Sub.OneTest where + +prop_subTest :: Bool -> Bool +prop_subTest _ = True diff --git a/test/ModulesGlob/TwoTest.hs b/test/ModulesGlob/TwoTest.hs new file mode 100644 --- /dev/null +++ b/test/ModulesGlob/TwoTest.hs @@ -0,0 +1,4 @@ +module ModulesGlob.TwoTest where + +prop_topLevelTest :: Bool -> Bool +prop_topLevelTest _ = True