{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ConfigTest where
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, extractTests)
import Test.Tasty.Discover.Internal.Generator (Test (..), mkTest)
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
let expectedTests = [ mkTest "PropTest.hs" "prop_additionAssociative"
, mkTest "SubSubMod/PropTest.hs" "prop_additionCommutative"
]
config = (defaultConfig "test/SubMod") { modules = Just "*Test.hs" }
discoveredTests <- findTests config
sort discoveredTests `shouldBe` sort expectedTests
spec_ignores :: Spec
spec_ignores = describe "Module ignore configuration" $ do
it "Ignores tests in modules with the specified suffix" $ do
let ignoreModuleConfig = (defaultConfig "test/SubMod") { ignores = Just "*.hs" }
discoveredTests <- findTests ignoreModuleConfig
discoveredTests `shouldBe` []
spec_badModuleGlob :: Spec
spec_badModuleGlob = describe "Module suffix configuration" $ do
it "Filters discovered tests by specified suffix" $ do
let badGlobConfig = (defaultConfig "test/SubMod") { modules = Just "DoesntExist*.hs" }
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
let generatedModule = generateTestDriver (defaultConfig "test/") "FunkyModuleName" [] "test/" []
"FunkyModuleName" `shouldSatisfy` (`isInfixOf` generatedModule)
unit_noTreeDisplayDefault :: IO ()
unit_noTreeDisplayDefault = do
let config = defaultConfig "test/SubMod"
tests <- findTests config
let testNumVars = map (('t' :) . show) [(0::Int)..]
trees = showTests config tests testNumVars
length trees @?= 4
unit_treeDisplay :: IO ()
unit_treeDisplay = do
let config = (defaultConfig "test/SubMod") { treeDisplay = True }
tests <- findTests config
let testNumVars = map (('t' :) . show) [(0::Int)..]
trees = showTests config tests testNumVars
length trees @?= 3
prop_mkModuleTree :: ModuleTree -> Property
prop_mkModuleTree mtree =
let (tests, testVars) = unzip $ flattenTree mtree
in mkModuleTree tests testVars === mtree
where flattenTree (ModuleTree mp) = M.assocs mp >>= flattenModule
flattenModule (mdl, (subTree, testVars)) = concat
[ map (\(Test subMdl _, tVar) -> (Test (mdl ++ '.':subMdl) "-", tVar)) (flattenTree subTree)
, map (Test mdl "-", ) testVars ]
instance Arbitrary ModuleTree where
arbitrary = sized $ \size ->
resize (min size 12) (ModuleTree . M.fromList <$> listOf1 mdlGen)
where mdlGen = sized $ \size -> do
mdl <- listOf1 (elements ['a'..'z'])
subTree <- if size == 0
then pure $ ModuleTree M.empty
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