tasty-discover 4.2.3 → 4.2.4

raw patch · 16 files changed

+680/−465 lines, 16 filesdep +bytestringdep +tasty-goldenPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, tasty-golden

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +50/−0
• executable/Main.hs +8/−8
• library/Test/Tasty/Config.hs +0/−118
• library/Test/Tasty/Discover.hs +0/−149
• library/Test/Tasty/Generator.hs +0/−150
• src/Test/Tasty/Discover.hs +48/−0
• src/Test/Tasty/Discover/Internal/Config.hs +118/−0
• src/Test/Tasty/Discover/Internal/Driver.hs +156/−0
• src/Test/Tasty/Discover/Internal/Generator.hs +160/−0
• src/Test/Tasty/Discover/TastyInfo.hs +22/−0
• src/Test/Tasty/Discover/Version.hs +10/−0
• tasty-discover.cabal +13/−5
• test/ConfigTest.hs +4/−4
• test/DiscoverTest.hs +65/−6
• test/Driver.hs +18/−25

@@ -8,6 +8,14 @@ [Keep a Changelog]: http://keepachangelog.com/ [Semantic Versioning]: http://semver.org/ +- Support for custom test libraries+- Version module+- Deduplicate imports in generated code+- Rename library directory to src+- Move existing library modules to Test.Discover.Internal++# 4.2.3 [2022-05-21]+ - Added `--search-dir DIR` option - Adds an `--in-place` flag to write the generated driver to the source file. 

@@ -103,6 +103,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  Here is an example test module with a bunch of different tests: @@ -113,6 +114,7 @@  import Data.List import Test.Tasty+import Test.Tasty.Discover import Test.Tasty.HUnit import Test.Tasty.Hspec import Test.Tasty.QuickCheck@@ -135,6 +137,27 @@   it "returns the first element of a list" $ do     head [23 ..] `shouldBe` (23 :: Int) +-- Custom test+--+-- 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)++data CustomTest = CustomTest String Assertion++instance Tasty CustomTest where+  tasty info (CustomTest prefix act) =+    pure $ testCase (prefix ++ descriptionOf info) act++tasty_myTest :: CustomTest+tasty_myTest = CustomTest "Custom: " $ pure ()+ -- Tasty TestTree test_multiplication :: [TestTree] test_multiplication = [testProperty "One is identity" $ \(a :: Int) -> a * 1 == a]@@ -221,6 +244,33 @@ 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.  # Maintenance 

@@ -2,14 +2,14 @@  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.Config   (Config (..), parseConfig)-import Test.Tasty.Discover (findTests, generateTestDriver)+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 ()

@@ -1,118 +0,0 @@--- | The test driver configuration options module.------ Anything that can be passed as an argument to the test driver--- definition exists as a field in the 'Config' type.--module Test.Tasty.Config-  ( -- * Configuration Options-    Config (..)-  , GlobPattern--    -- * Configuration Parser-  , parseConfig--    -- * Configuration Defaults-  , defaultConfig-  ) where--import Data.Maybe            (isJust)-import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), ArgOrder (Permute), OptDescr (Option), getOpt')-import System.FilePath ((</>))---- | A tasty ingredient.-type Ingredient = String---- | A glob pattern.-type GlobPattern = String---- | The discovery and runner configuration.-data Config = Config-  { modules             :: Maybe GlobPattern -- ^ Glob pattern for matching modules during test discovery.-  , moduleSuffix        :: Maybe String      -- ^ <<<DEPRECATED>>>: Module suffix.-  , searchDir           :: FilePath          -- ^ Directory where to look for tests.-  , generatedModuleName :: Maybe String      -- ^ Name of the generated main module.-  , ignores             :: Maybe GlobPattern -- ^ Glob pattern for ignoring modules during test discovery.-  , ignoredModules      :: [FilePath]        -- ^ <<<DEPRECATED>>>: Ignored modules by full name.-  , tastyIngredients    :: [Ingredient]      -- ^ Tasty ingredients to use.-  , tastyOptions        :: [String]          -- ^ Options passed to tasty-  , inPlace             :: Bool              -- ^ Whether the source file should be modified in-place.-  , noModuleSuffix      :: Bool              -- ^ <<<DEPRECATED>>>: suffix and look in all modules.-  , debug               :: Bool              -- ^ Debug the generated module.-  , treeDisplay         :: Bool              -- ^ Tree display for the test results table.-  } deriving (Show)---- | The default configuration-defaultConfig :: FilePath -> Config-defaultConfig theSearchDir = Config Nothing Nothing theSearchDir Nothing Nothing [] [] [] False False False False---- | Deprecation message for old `--[no-]module-suffix` option.-moduleSuffixDeprecationMessage :: String-moduleSuffixDeprecationMessage = error $ concat-  [ "\n\n"-  , "----------------------------------------------------------\n"-  , "DEPRECATION NOTICE: `--[no-]module-suffix` is deprecated.\n"-  , "The default behaviour now discovers all test module suffixes.\n"-  , "Please use the `--modules='<glob-pattern>'` option to specify.\n"-  , "----------------------------------------------------------\n"-  ]---- | Deprecation message for old `--ignore-module` option.-ignoreModuleDeprecationMessage :: String-ignoreModuleDeprecationMessage = error $ concat-  [ "\n\n"-  , "----------------------------------------------------------\n"-  , "DEPRECATION NOTICE: `--ignore-module` is deprecated.\n"-  , "Please use the `--ignores='<glob-pattern>'` option instead.\n"-  , "----------------------------------------------------------\n"-  ]---- | Configuration options parser.-parseConfig :: FilePath -> String -> [String] -> Either String Config-parseConfig srcDir prog args = case getOpt' Permute (options srcDir) args of-  (opts, rest, rest', []) ->-    let config = foldl (flip id) (defaultConfig srcDir) { tastyOptions = rest ++ rest' } opts in-      if noModuleSuffix config || isJust (moduleSuffix config)-        then error moduleSuffixDeprecationMessage-        else if not $ null (ignoredModules config)-          then error ignoreModuleDeprecationMessage-          else Right config-  (_, _, _, err:_)  -> formatError err-  where formatError err = Left (prog ++ ": " ++ err)---- | All configuration options.-options :: FilePath -> [OptDescr (Config -> Config)]-options srcDir =-  [ Option [] ["modules"]-      (ReqArg (\s c -> c {modules = Just s}) "GLOB-PATTERN")-      "Specify desired modules with a glob pattern (white-list)"-  , Option [] ["module-suffix"]-      (ReqArg (\s c -> c {moduleSuffix = Just s}) "SUFFIX")-      "<<<DEPRECATED>>>: Specify desired test module suffix"-  , Option [] ["search-dir"]-      (ReqArg (\s c -> c {searchDir = srcDir </> s}) "DIR")-      "Directory where to look for tests relative to the directory of src. By default, this is the directory of src."-  , Option [] ["generated-module"]-      (ReqArg (\s c -> c {generatedModuleName = Just s}) "MODULE")-      "Qualified generated module name"-  , Option [] ["ignores"]-      (ReqArg (\s c -> c {ignores = Just s}) "GLOB-PATTERN")-      "Specify desired modules to ignore with a glob pattern (black-list)"-  , Option [] ["ignore-module"]-      (ReqArg (\s c -> c {ignoredModules = s : ignoredModules c}) "FILE")-      "<<<DEPRECATED>>>: Ignore a test module"-  , Option [] ["ingredient"]-      (ReqArg (\s c -> c {tastyIngredients = s : tastyIngredients c}) "INGREDIENT")-      "Qualified tasty ingredient name"-  , Option [] ["in-place"]-      (NoArg $ \c -> c {inPlace = True})-      "Whether the source file should be modified in-place"-  , Option [] ["no-module-suffix"]-      (NoArg $ \c -> c {noModuleSuffix = True})-      "<<<DEPRECATED>>>: Ignore test module suffix and import them all"-  , Option [] ["debug"]-      (NoArg $ \c -> c {debug = True})-      "Debug output of generated test module"-  , Option [] ["tree-display"]-      (NoArg $ \c -> c {treeDisplay = True})-      "Display test output hierarchically"-  ]

@@ -1,149 +0,0 @@-{-# LANGUAGE CPP #-}---- | Automatic test discovery and runner for the tasty framework.-module Test.Tasty.Discover-  ( -- * Main Test Generator-    generateTestDriver--    -- * For Testing Purposes Only-  , ModuleTree (..)-  , findTests-  , mkModuleTree-  , showTests-  ) where--import Data.List            (dropWhileEnd, intercalate, isPrefixOf, nub, sort, stripPrefix)-import Data.Maybe           (fromMaybe)-import System.FilePath      (pathSeparator)-import System.FilePath.Glob (compile, globDir1, match)-import System.IO            (IOMode (ReadMode), withFile)-import Test.Tasty.Config    (Config (..), GlobPattern)-import Test.Tasty.Generator (Generator (..), Test (..), generators, getGenerators, mkTest, showSetup)--import qualified Data.Map.Strict as M--#if defined(mingw32_HOST_OS)-import GHC.IO.Encoding.CodePage (mkLocaleEncoding)-import GHC.IO.Encoding.Failure  (CodingFailureMode (TransliterateCodingFailure))-import GHC.IO.Handle            (hGetContents, hSetEncoding)-#else-import GHC.IO.Handle (hGetContents)-#endif---- | Main function generator, along with all the boilerplate which--- which will run the discovered tests.-generateTestDriver :: Config -> String -> [String] -> FilePath -> [Test] -> String-generateTestDriver config modname is src tests =-  let generators' = getGenerators tests-      testNumVars = map (("t"++) . show) [(0 :: Int)..]-  in concat-    [ "{-# LANGUAGE FlexibleInstances #-}\n"-    , "\n"-    , "module " ++ modname ++ " (main, ingredients, tests) where\n"-    , "\n"-    , "import Prelude\n"-    , "\n"-    , "import qualified System.Environment as E\n"-    , "import qualified Test.Tasty as T\n"-    , "import qualified Test.Tasty.Ingredients as T\n"-    , unlines $ map generatorImport generators'-    , showImports (map ingredientImport is ++ map testModule tests)-    , "{- HLINT ignore \"Use let\" -}\n"-    , "\n"-    , unlines $ map generatorClass generators'-    , "tests :: IO T.TestTree\n"-    , "tests = do\n"-    , unlines $ zipWith showSetup tests testNumVars-    , "  pure $ T.testGroup " ++ show src ++ " ["-    , intercalate "," $ showTests config tests testNumVars-    , "]\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"-    ]---- | Match files by specified glob pattern.-filesByModuleGlob :: FilePath -> Maybe GlobPattern -> IO [String]-filesByModuleGlob directory globPattern = globDir1 pattern directory-  where pattern = compile ("**/" ++ fromMaybe "*.hs*" globPattern)---- | Filter and remove files by specified glob pattern.-ignoreByModuleGlob :: [FilePath] -> Maybe GlobPattern -> [FilePath]-ignoreByModuleGlob filePaths Nothing = filePaths-ignoreByModuleGlob filePaths (Just ignoreGlob) = filter (not . match pattern) filePaths-  where pattern = compile ("**/" ++ ignoreGlob)---- | Discover the tests modules.-findTests :: Config -> IO [Test]-findTests config = do-  let directory = searchDir config-  allModules <- filesByModuleGlob directory (modules config)-  let filtered = ignoreByModuleGlob allModules (ignores config)-      -- The files to scan need to be sorted or otherwise the output of-      -- findTests might not be deterministic-      sortedFiltered = sort filtered-  concat <$> traverse (extract directory) sortedFiltered-  where extract directory filePath =-          withFile filePath ReadMode $ \h -> do-#if defined(mingw32_HOST_OS)-          -- Avoid internal error: hGetContents: invalid argument (invalid byte sequence)' non UTF-8 Windows-            hSetEncoding h $ mkLocaleEncoding TransliterateCodingFailure-#endif-            tests <- extractTests (dropDirectory directory filePath) <$> hGetContents h-            seq (length tests) (return tests)-        dropDirectory directory filePath = fromMaybe filePath $-          stripPrefix (directory ++ [pathSeparator]) filePath---- | Extract the test names from discovered modules.-extractTests :: FilePath -> String -> [Test]-extractTests file = mkTestDeDuped . isKnownPrefix . parseTest-  where mkTestDeDuped = map (mkTest file) . nub-        isKnownPrefix = filter (\g -> any (checkPrefix g) generators)-        checkPrefix g = (`isPrefixOf` g) . generatorPrefix-        parseTest     = map fst . concatMap lex . lines---- | Show the imports.-showImports :: [String] -> String-showImports mods = unlines $ nub $ map (\m -> "import qualified " ++ m ++ "\n") mods---- | Retrieve the ingredient name.-ingredientImport :: String -> String-ingredientImport = init . dropWhileEnd (/= '.')---- | Ingredients to be included.-ingredients :: [String] -> String-ingredients is = concat $ map (++":") is ++ ["T.defaultIngredients"]---- | Show the tests.-showTests :: Config -> [Test] -> [String] -> [String]-showTests config tests testNumVars = if treeDisplay config-  then showModuleTree $ mkModuleTree tests testNumVars-  else zipWith (curry snd) tests testNumVars--newtype ModuleTree = ModuleTree (M.Map String (ModuleTree, [String]))-  deriving (Eq, Show)--showModuleTree :: ModuleTree -> [String]-showModuleTree (ModuleTree mdls) = map showModule $ M.assocs mdls-  where -- special case, collapse to mdl.submdl-        showModule (mdl, (ModuleTree subMdls, [])) | M.size subMdls == 1 =-          let [(subMdl, (subSubTree, testVars))] = M.assocs subMdls-          in showModule (mdl ++ '.' : subMdl, (subSubTree, testVars))-        showModule (mdl, (subTree, testVars)) = concat-          [ "T.testGroup \"", mdl-          , "\" [", intercalate "," (showModuleTree subTree ++ testVars), "]" ]--mkModuleTree :: [Test] -> [String] -> ModuleTree-mkModuleTree tests testVars = ModuleTree $-    foldr go M.empty $ zipWith (\t tVar -> (testModule t, tVar)) tests testVars-  where go (mdl, tVar) mdls = M.insertWith merge key val mdls-          where (key, val) = case break (== '.') mdl of-                  (_, [])              -> (mdl, (ModuleTree M.empty, [tVar]))-                  (topMdl, '.':subMdl) -> (topMdl, (ModuleTree $ go (subMdl, tVar) M.empty, []))-                  _                    -> error "impossible case in mkModuleTree.go.key"-        merge (ModuleTree mdls1, tVars1) (ModuleTree mdls2, tVars2) =-          (ModuleTree $ M.unionWith merge mdls1 mdls2, tVars1 ++ tVars2)

@@ -1,150 +0,0 @@--- | The test generator boilerplate module.------ Any test that is supported (HUnit, HSpec, etc.) provides here, a--- generator type with all the context necessary for outputting the--- necessary boilerplate for the generated main function that will--- run all the tests.--module Test.Tasty.Generator-  ( -- * Types-    Generator (..)-  , Test (..)--    -- * Generators-  , generators-  , getGenerator-  , getGenerators--    -- * Boilerplate Formatter-  , showSetup--    -- * Type Constructor-  , mkTest-  ) where--import Data.Function   (on)-import Data.List       (find, groupBy, isPrefixOf, sortOn)-import Data.Maybe      (fromJust)-import System.FilePath (dropExtension, isPathSeparator)---- | The test type.-data Test = Test-  { testModule   :: String -- ^ Module name.-  , testFunction :: String -- ^ Function name.-  } deriving (Eq, Show, Ord)---- | 'Test' constructor.-mkTest :: FilePath -> String -> Test-mkTest = Test . replacePathSepTo '.' . dropExtension-  where replacePathSepTo c1 = map $ \c2 -> if isPathSeparator c2 then c1 else c2---- | The generator type.-data Generator = Generator-  { generatorPrefix :: String          -- ^ Generator prefix.-  , generatorImport :: String          -- ^ Module import path.-  , generatorClass  :: String          -- ^ Generator class.-  , generatorSetup  :: Test -> String  -- ^ Generator setup.-  }---- | Module import qualifier.-qualifyFunction :: Test -> String-qualifyFunction t = testModule t ++ "." ++ testFunction t---- | Function namer.-name :: Test -> String-name = chooser '_' ' ' . tail . dropWhile (/= '_') . testFunction-  where chooser c1 c2 = map $ \c3 -> if c3 == c1 then c2 else c3---- | Generator retriever (single).-getGenerator :: Test -> Generator-getGenerator t = fromJust $ getPrefix generators-  where getPrefix = find ((`isPrefixOf` testFunction t) . generatorPrefix)---- | Generator retriever (many).-getGenerators :: [Test] -> [Generator]-getGenerators =-  map head .-  groupBy  ((==) `on` generatorPrefix) .-  sortOn generatorPrefix .-  map getGenerator---- | Boilerplate formatter.-showSetup :: Test -> String -> String-showSetup t var = "  " ++ var ++ " <- " ++ setup ++ "\n"-  where setup = generatorSetup (getGenerator t) t---- | All types of tests supported for boilerplate generation.-generators :: [Generator]-generators =-  [ quickCheckPropertyGenerator-  , smallCheckPropertyGenerator-  , hedgehogPropertyGenerator-  , hunitTestCaseGenerator-  , hspecTestCaseGenerator-  , tastyTestGroupGenerator-  ]---- | Quickcheck group generator prefix.-hedgehogPropertyGenerator :: Generator-hedgehogPropertyGenerator = Generator-  { generatorPrefix = "hprop_"-  , generatorImport = "import qualified Test.Tasty.Hedgehog as H\n"-  , generatorClass  = ""-  , generatorSetup  = \t -> "pure $ H.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t-  }---- | Quickcheck group generator prefix.-quickCheckPropertyGenerator :: Generator-quickCheckPropertyGenerator = Generator-  { generatorPrefix = "prop_"-  , generatorImport = "import qualified Test.Tasty.QuickCheck as QC\n"-  , generatorClass  = ""-  , generatorSetup  = \t -> "pure $ QC.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t-  }---- | Smallcheck group generator prefix.-smallCheckPropertyGenerator :: Generator-smallCheckPropertyGenerator = Generator-  { generatorPrefix = "scprop_"-  , generatorImport = "import qualified Test.Tasty.SmallCheck as SC\n"-  , generatorClass  = ""-  , generatorSetup  = \t -> "pure $ SC.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t-  }---- | HUnit generator prefix.-hunitTestCaseGenerator :: Generator-hunitTestCaseGenerator = Generator-  { generatorPrefix = "unit_"-  , generatorImport = "import qualified Test.Tasty.HUnit as HU\n"-  , generatorClass  = concat-    [ "class TestCase a where testCase :: String -> a -> IO T.TestTree\n"-    , "instance TestCase (IO ())                      where testCase n = pure . HU.testCase      n\n"-    , "instance TestCase (IO String)                  where testCase n = pure . HU.testCaseInfo  n\n"-    , "instance TestCase ((String -> IO ()) -> IO ()) where testCase n = pure . HU.testCaseSteps n\n"-    ]-  , generatorSetup  = \t -> "testCase \"" ++ name t ++ "\" " ++ qualifyFunction t-  }---- | Hspec generator prefix.-hspecTestCaseGenerator :: Generator-hspecTestCaseGenerator = Generator-  { generatorPrefix = "spec_"-  , generatorImport = "import qualified Test.Tasty.Hspec as HS\n"-  , generatorClass  = ""-  , generatorSetup  = \t -> "HS.testSpec \"" ++ name t ++ "\" " ++ qualifyFunction t-  }---- | Tasty group generator prefix.-tastyTestGroupGenerator :: Generator-tastyTestGroupGenerator = Generator-  { generatorPrefix = "test_"-  , generatorImport = ""-  , generatorClass  = concat-    [ "class TestGroup a where testGroup :: String -> a -> IO T.TestTree\n"-    , "instance TestGroup T.TestTree        where testGroup _ a = pure a\n"-    , "instance TestGroup [T.TestTree]      where testGroup n a = pure $ T.testGroup n a\n"-    , "instance TestGroup (IO T.TestTree)   where testGroup _ a = a\n"-    , "instance TestGroup (IO [T.TestTree]) where testGroup n a = T.testGroup n <$> a\n"-    ]-  , generatorSetup  = \t -> "testGroup \"" ++ name t ++ "\" " ++ qualifyFunction t-  }

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}++module Test.Tasty.Discover+  ( Tasty(..)+  , TastyInfo+  , name+  , description+  , nameOf+  , descriptionOf+  ) where++import Data.Maybe+import Data.Monoid+import Test.Tasty.Discover.TastyInfo (TastyInfo)++import qualified Test.Tasty as TT+import qualified Test.Tasty.Discover.TastyInfo as TI++class Tasty a where+  tasty :: TastyInfo -> a -> IO TT.TestTree++instance Tasty TT.TestTree where+  tasty _ a = pure a++instance Tasty [TT.TestTree] where+  tasty info a = pure $ TT.testGroup (descriptionOf info) a++instance Tasty (IO TT.TestTree) where+  tasty _ a = a++instance Tasty (IO [TT.TestTree]) where+  tasty info a = TT.testGroup (descriptionOf info) <$> a++nameOf :: TastyInfo -> String+nameOf info = (fromMaybe "<unnamed>" (getLast (TI.name info)))++descriptionOf :: TastyInfo -> String+descriptionOf info = (fromMaybe "<undescribed>" (getLast (TI.description info)))++name :: String -> TastyInfo+name n = mempty+  { TI.name = Last $ Just n+  }++description :: String -> TastyInfo+description n = mempty+  { TI.description = Last $ Just n+  }

@@ -0,0 +1,118 @@+-- | The test driver configuration options module.+--+-- Anything that can be passed as an argument to the test driver+-- definition exists as a field in the 'Config' type.++module Test.Tasty.Discover.Internal.Config+  ( -- * Configuration Options+    Config (..)+  , GlobPattern++    -- * Configuration Parser+  , parseConfig++    -- * Configuration Defaults+  , defaultConfig+  ) where++import Data.Maybe            (isJust)+import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), ArgOrder (Permute), OptDescr (Option), getOpt')+import System.FilePath ((</>))++-- | A tasty ingredient.+type Ingredient = String++-- | A glob pattern.+type GlobPattern = String++-- | The discovery and runner configuration.+data Config = Config+  { modules             :: Maybe GlobPattern -- ^ Glob pattern for matching modules during test discovery.+  , moduleSuffix        :: Maybe String      -- ^ <<<DEPRECATED>>>: Module suffix.+  , searchDir           :: FilePath          -- ^ Directory where to look for tests.+  , generatedModuleName :: Maybe String      -- ^ Name of the generated main module.+  , ignores             :: Maybe GlobPattern -- ^ Glob pattern for ignoring modules during test discovery.+  , ignoredModules      :: [FilePath]        -- ^ <<<DEPRECATED>>>: Ignored modules by full name.+  , tastyIngredients    :: [Ingredient]      -- ^ Tasty ingredients to use.+  , tastyOptions        :: [String]          -- ^ Options passed to tasty+  , inPlace             :: Bool              -- ^ Whether the source file should be modified in-place.+  , noModuleSuffix      :: Bool              -- ^ <<<DEPRECATED>>>: suffix and look in all modules.+  , debug               :: Bool              -- ^ Debug the generated module.+  , treeDisplay         :: Bool              -- ^ Tree display for the test results table.+  } deriving (Show)++-- | The default configuration+defaultConfig :: FilePath -> Config+defaultConfig theSearchDir = Config Nothing Nothing theSearchDir Nothing Nothing [] [] [] False False False False++-- | Deprecation message for old `--[no-]module-suffix` option.+moduleSuffixDeprecationMessage :: String+moduleSuffixDeprecationMessage = error $ concat+  [ "\n\n"+  , "----------------------------------------------------------\n"+  , "DEPRECATION NOTICE: `--[no-]module-suffix` is deprecated.\n"+  , "The default behaviour now discovers all test module suffixes.\n"+  , "Please use the `--modules='<glob-pattern>'` option to specify.\n"+  , "----------------------------------------------------------\n"+  ]++-- | Deprecation message for old `--ignore-module` option.+ignoreModuleDeprecationMessage :: String+ignoreModuleDeprecationMessage = error $ concat+  [ "\n\n"+  , "----------------------------------------------------------\n"+  , "DEPRECATION NOTICE: `--ignore-module` is deprecated.\n"+  , "Please use the `--ignores='<glob-pattern>'` option instead.\n"+  , "----------------------------------------------------------\n"+  ]++-- | Configuration options parser.+parseConfig :: FilePath -> String -> [String] -> Either String Config+parseConfig srcDir prog args = case getOpt' Permute (options srcDir) args of+  (opts, rest, rest', []) ->+    let config = foldl (flip id) (defaultConfig srcDir) { tastyOptions = rest ++ rest' } opts in+      if noModuleSuffix config || isJust (moduleSuffix config)+        then error moduleSuffixDeprecationMessage+        else if not $ null (ignoredModules config)+          then error ignoreModuleDeprecationMessage+          else Right config+  (_, _, _, err:_)  -> formatError err+  where formatError err = Left (prog ++ ": " ++ err)++-- | All configuration options.+options :: FilePath -> [OptDescr (Config -> Config)]+options srcDir =+  [ Option [] ["modules"]+      (ReqArg (\s c -> c {modules = Just s}) "GLOB-PATTERN")+      "Specify desired modules with a glob pattern (white-list)"+  , Option [] ["module-suffix"]+      (ReqArg (\s c -> c {moduleSuffix = Just s}) "SUFFIX")+      "<<<DEPRECATED>>>: Specify desired test module suffix"+  , Option [] ["search-dir"]+      (ReqArg (\s c -> c {searchDir = srcDir </> s}) "DIR")+      "Directory where to look for tests relative to the directory of src. By default, this is the directory of src."+  , Option [] ["generated-module"]+      (ReqArg (\s c -> c {generatedModuleName = Just s}) "MODULE")+      "Qualified generated module name"+  , Option [] ["ignores"]+      (ReqArg (\s c -> c {ignores = Just s}) "GLOB-PATTERN")+      "Specify desired modules to ignore with a glob pattern (black-list)"+  , Option [] ["ignore-module"]+      (ReqArg (\s c -> c {ignoredModules = s : ignoredModules c}) "FILE")+      "<<<DEPRECATED>>>: Ignore a test module"+  , Option [] ["ingredient"]+      (ReqArg (\s c -> c {tastyIngredients = s : tastyIngredients c}) "INGREDIENT")+      "Qualified tasty ingredient name"+  , Option [] ["in-place"]+      (NoArg $ \c -> c {inPlace = True})+      "Whether the source file should be modified in-place"+  , Option [] ["no-module-suffix"]+      (NoArg $ \c -> c {noModuleSuffix = True})+      "<<<DEPRECATED>>>: Ignore test module suffix and import them all"+  , Option [] ["debug"]+      (NoArg $ \c -> c {debug = True})+      "Debug output of generated test module"+  , Option [] ["tree-display"]+      (NoArg $ \c -> c {treeDisplay = True})+      "Display test output hierarchically"+  ]

@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}++-- | Automatic test discovery and runner for the tasty framework.+module Test.Tasty.Discover.Internal.Driver+  ( -- * Main Test Generator+    generateTestDriver++    -- * For Testing Purposes Only+  , ModuleTree (..)+  , findTests+  , mkModuleTree+  , showTests+  ) where++import Data.List                              (dropWhileEnd, intercalate, isPrefixOf, nub, sort, stripPrefix)+import Data.Maybe                             (fromMaybe)+import System.FilePath                        (pathSeparator)+import System.FilePath.Glob                   (compile, globDir1, match)+import System.IO                              (IOMode (ReadMode), withFile)+import Test.Tasty.Discover.Internal.Config    (Config (..), GlobPattern)+import Test.Tasty.Discover.Internal.Generator (Generator (..), Test (..), generators, getGenerators, mkTest, showSetup)++import qualified Data.Map.Strict as M++#if defined(mingw32_HOST_OS)+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)+import GHC.IO.Encoding.Failure  (CodingFailureMode (TransliterateCodingFailure))+import GHC.IO.Handle            (hGetContents, hSetEncoding)+#else+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+generateTestDriver config modname is src tests =+  let generators' = getGenerators tests+      testNumVars = map (("t"++) . show) [(0 :: Int)..]+      testKindImports = map generatorImports generators' :: [[String]]+      testImports = showImports (map ingredientImport is ++ map testModule tests) :: [String]+  in concat+    [ "{-# LANGUAGE FlexibleInstances #-}\n"+    , "\n"+    , "module " ++ modname ++ " (main, ingredients, tests) where\n"+    , "\n"+    , unlines $ nub $ sort $ mconcat (defaultImports:testKindImports) ++ testImports+    , "\n"+    , "{- HLINT ignore \"Use let\" -}\n"+    , "\n"+    , unlines $ map generatorClass generators'+    , "tests :: IO T.TestTree\n"+    , "tests = do\n"+    , unlines $ zipWith showSetup tests testNumVars+    , "  pure $ T.testGroup " ++ show src ++ " ["+    , intercalate "," $ showTests config tests testNumVars+    , "]\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"+    ]++-- | Match files by specified glob pattern.+filesByModuleGlob :: FilePath -> Maybe GlobPattern -> IO [String]+filesByModuleGlob directory globPattern = globDir1 pattern directory+  where pattern = compile ("**/" ++ fromMaybe "*.hs*" globPattern)++-- | Filter and remove files by specified glob pattern.+ignoreByModuleGlob :: [FilePath] -> Maybe GlobPattern -> [FilePath]+ignoreByModuleGlob filePaths Nothing = filePaths+ignoreByModuleGlob filePaths (Just ignoreGlob) = filter (not . match pattern) filePaths+  where pattern = compile ("**/" ++ ignoreGlob)++-- | Discover the tests modules.+findTests :: Config -> IO [Test]+findTests config = do+  let directory = searchDir config+  allModules <- filesByModuleGlob directory (modules config)+  let filtered = ignoreByModuleGlob allModules (ignores config)+      -- The files to scan need to be sorted or otherwise the output of+      -- findTests might not be deterministic+      sortedFiltered = sort filtered+  concat <$> traverse (extract directory) sortedFiltered+  where extract directory filePath =+          withFile filePath ReadMode $ \h -> do+#if defined(mingw32_HOST_OS)+          -- Avoid internal error: hGetContents: invalid argument (invalid byte sequence)' non UTF-8 Windows+            hSetEncoding h $ mkLocaleEncoding TransliterateCodingFailure+#endif+            tests <- extractTests (dropDirectory directory filePath) <$> hGetContents h+            seq (length tests) (return tests)+        dropDirectory directory filePath = fromMaybe filePath $+          stripPrefix (directory ++ [pathSeparator]) filePath++-- | Extract the test names from discovered modules.+extractTests :: FilePath -> String -> [Test]+extractTests file = mkTestDeDuped . isKnownPrefix . parseTest+  where mkTestDeDuped = map (mkTest file) . nub+        isKnownPrefix = filter (\g -> any (checkPrefix g) generators)+        checkPrefix g = (`isPrefixOf` g) . generatorPrefix+        parseTest     = map fst . concatMap lex . lines++-- | Show the imports.+showImports :: [String] -> [String]+showImports mods = sort $ map ("import qualified " ++) mods++-- | Retrieve the ingredient name.+ingredientImport :: String -> String+ingredientImport = init . dropWhileEnd (/= '.')++-- | Ingredients to be included.+ingredients :: [String] -> String+ingredients is = concat $ map (++":") is ++ ["T.defaultIngredients"]++-- | Show the tests.+showTests :: Config -> [Test] -> [String] -> [String]+showTests config tests testNumVars = if treeDisplay config+  then showModuleTree $ mkModuleTree tests testNumVars+  else zipWith const testNumVars tests++newtype ModuleTree = ModuleTree (M.Map String (ModuleTree, [String]))+  deriving (Eq, Show)++showModuleTree :: ModuleTree -> [String]+showModuleTree (ModuleTree mdls) = map showModule $ M.assocs mdls+  where -- special case, collapse to mdl.submdl+        showModule :: ([Char], (ModuleTree, [String])) -> [Char]+        showModule (mdl, (ModuleTree subMdls, [])) | M.size subMdls == 1 =+          case M.assocs subMdls of+            [(subMdl, (subSubTree, testVars))] -> showModule (mdl ++ '.' : subMdl, (subSubTree, testVars))+            as -> error $ "Excepted number of submodules != 1.  Found " <> show (length as)+        showModule (mdl, (subTree, testVars)) = concat+          [ "T.testGroup \"", mdl+          , "\" [", intercalate "," (showModuleTree subTree ++ testVars), "]" ]++mkModuleTree :: [Test] -> [String] -> ModuleTree+mkModuleTree tests testVars = ModuleTree $+    foldr go M.empty $ zipWith (\t tVar -> (testModule t, tVar)) tests testVars+  where go (mdl, tVar) mdls = M.insertWith merge key val mdls+          where (key, val) = case break (== '.') mdl of+                  (_, [])              -> (mdl, (ModuleTree M.empty, [tVar]))+                  (topMdl, '.':subMdl) -> (topMdl, (ModuleTree $ go (subMdl, tVar) M.empty, []))+                  _                    -> error "impossible case in mkModuleTree.go.key"+        merge (ModuleTree mdls1, tVars1) (ModuleTree mdls2, tVars2) =+          (ModuleTree $ M.unionWith merge mdls1 mdls2, tVars1 ++ tVars2)

@@ -0,0 +1,160 @@+-- | The test generator boilerplate module.+--+-- Any test that is supported (HUnit, HSpec, etc.) provides here, a+-- generator type with all the context necessary for outputting the+-- necessary boilerplate for the generated main function that will+-- run all the tests.++module Test.Tasty.Discover.Internal.Generator+  ( -- * Types+    Generator (..)+  , Test (..)++    -- * Generators+  , generators+  , getGenerator+  , getGenerators++    -- * Boilerplate Formatter+  , showSetup++    -- * Type Constructor+  , mkTest+  ) where++import Data.Function   (on)+import Data.List       (find, groupBy, isPrefixOf, sortOn)+import Data.Maybe      (fromJust)+import System.FilePath (dropExtension, isPathSeparator)++-- | The test type.+data Test = Test+  { testModule   :: String -- ^ Module name.+  , testFunction :: String -- ^ Function name.+  } deriving (Eq, Show, Ord)++-- | 'Test' constructor.+mkTest :: FilePath -> String -> Test+mkTest = Test . replacePathSepTo '.' . dropExtension+  where replacePathSepTo c1 = map $ \c2 -> if isPathSeparator c2 then c1 else c2++-- | The generator type.+data Generator = Generator+  { generatorPrefix   :: String          -- ^ Generator prefix.+  , generatorImports  :: [String]        -- ^ Module import path.+  , generatorClass    :: String          -- ^ Generator class.+  , generatorSetup    :: Test -> String  -- ^ Generator setup.+  }++-- | Module import qualifier.+qualifyFunction :: Test -> String+qualifyFunction t = testModule t ++ "." ++ testFunction t++-- | Function namer.+name :: Test -> String+name = chooser '_' ' ' . tail . dropWhile (/= '_') . testFunction+  where chooser c1 c2 = map $ \c3 -> if c3 == c1 then c2 else c3++-- | Generator retriever (single).+getGenerator :: Test -> Generator+getGenerator t = fromJust $ getPrefix generators+  where getPrefix = find ((`isPrefixOf` testFunction t) . generatorPrefix)++-- | Generator retriever (many).+getGenerators :: [Test] -> [Generator]+getGenerators =+  map head .+  groupBy  ((==) `on` generatorPrefix) .+  sortOn generatorPrefix .+  map getGenerator++-- | Boilerplate formatter.+showSetup :: Test -> String -> String+showSetup t var = "  " ++ var ++ " <- " ++ setup ++ "\n"+  where setup = generatorSetup (getGenerator t) t++-- | All types of tests supported for boilerplate generation.+generators :: [Generator]+generators =+  [ quickCheckPropertyGenerator+  , smallCheckPropertyGenerator+  , hedgehogPropertyGenerator+  , hunitTestCaseGenerator+  , hspecTestCaseGenerator+  , tastyTestGroupGenerator+  , tastyGenerator+  ]++-- | Quickcheck group generator prefix.+hedgehogPropertyGenerator :: Generator+hedgehogPropertyGenerator = Generator+  { generatorPrefix   = "hprop_"+  , generatorImports  = ["import qualified Test.Tasty.Hedgehog as H"]+  , generatorClass    = ""+  , generatorSetup    = \t -> "pure $ H.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | Quickcheck group generator prefix.+quickCheckPropertyGenerator :: Generator+quickCheckPropertyGenerator = Generator+  { generatorPrefix   = "prop_"+  , generatorImports  = ["import qualified Test.Tasty.QuickCheck as QC"]+  , generatorClass    = ""+  , generatorSetup    = \t -> "pure $ QC.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | Smallcheck group generator prefix.+smallCheckPropertyGenerator :: Generator+smallCheckPropertyGenerator = Generator+  { generatorPrefix   = "scprop_"+  , generatorImports  = ["import qualified Test.Tasty.SmallCheck as SC"]+  , generatorClass    = ""+  , generatorSetup    = \t -> "pure $ SC.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | HUnit generator prefix.+hunitTestCaseGenerator :: Generator+hunitTestCaseGenerator = Generator+  { generatorPrefix   = "unit_"+  , generatorImports  = ["import qualified Test.Tasty.HUnit as HU"]+  , generatorClass    = concat+    [ "class TestCase a where testCase :: String -> a -> IO T.TestTree\n"+    , "instance TestCase (IO ())                      where testCase n = pure . HU.testCase      n\n"+    , "instance TestCase (IO String)                  where testCase n = pure . HU.testCaseInfo  n\n"+    , "instance TestCase ((String -> IO ()) -> IO ()) where testCase n = pure . HU.testCaseSteps n\n"+    ]+  , generatorSetup  = \t -> "testCase \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | Hspec generator prefix.+hspecTestCaseGenerator :: Generator+hspecTestCaseGenerator = Generator+  { generatorPrefix   = "spec_"+  , generatorImports  = ["import qualified Test.Tasty.Hspec as HS"]+  , generatorClass    = ""+  , generatorSetup    = \t -> "HS.testSpec \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | Tasty group generator prefix.+tastyTestGroupGenerator :: Generator+tastyTestGroupGenerator = Generator+  { generatorPrefix   = "test_"+  , generatorImports  = []+  , generatorClass    = concat+    [ "class TestGroup a where testGroup :: String -> a -> IO T.TestTree\n"+    , "instance TestGroup T.TestTree        where testGroup _ a = pure a\n"+    , "instance TestGroup [T.TestTree]      where testGroup n a = pure $ T.testGroup n a\n"+    , "instance TestGroup (IO T.TestTree)   where testGroup _ a = a\n"+    , "instance TestGroup (IO [T.TestTree]) where testGroup n a = T.testGroup n <$> a\n"+    ]+  , generatorSetup  = \t -> "testGroup \"" ++ name t ++ "\" " ++ qualifyFunction t+  }++-- | Tasty group generator prefix.+tastyGenerator :: Generator+tastyGenerator = Generator+  { generatorPrefix   = "tasty_"+  , generatorImports  = ["import qualified Test.Tasty.Discover as TD"]+  , generatorClass    = []+  , generatorSetup    = \t -> "TD.tasty (TD.description \"" ++ name t ++ "\" <> TD.name \"" ++ qualifyFunction t ++ "\") " ++ qualifyFunction t+  }

@@ -0,0 +1,22 @@+module Test.Tasty.Discover.TastyInfo+  ( TastyInfo(..)+  ) where++import Data.Monoid++data TastyInfo = TastyInfo+  { name        :: Last String+  , description :: Last String+  } deriving (Eq, Show)++instance Semigroup TastyInfo where+  a <> b = TastyInfo+    { name        = name a        <> name b+    , description = description a <> description b+    }++instance Monoid TastyInfo where+  mempty = TastyInfo+    { name        = Last Nothing+    , description = Last Nothing+    }

@@ -0,0 +1,10 @@+module Test.Tasty.Discover.Version+  ( version+  ) where++import Data.Version (Version(..))++import qualified Paths_tasty_discover as P++version :: Version+version = P.version

@@ -1,7 +1,7 @@ cabal-version: 2.2  name:                   tasty-discover-version:                4.2.3+version:                4.2.4 synopsis:               Test discovery for the tasty framework. description:            Automatic test discovery and runner for the tasty framework.                       @@ -35,6 +35,7 @@  common base                       { build-depends: base                       >= 4.11       && < 5      } +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      }@@ -44,6 +45,7 @@ common hspec-core                 { build-depends: hspec-core                 >= 2.7.10   && < 2.11     } 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-hspec                { build-depends: tasty-hspec                >= 1.1      && < 1.3      } common tasty-hunit                { build-depends: tasty-hunit                >= 0.10     && < 0.11     }@@ -51,18 +53,22 @@ common tasty-smallcheck           { build-depends: tasty-smallcheck           >= 0.8      && < 1.0      }  library-  exposed-modules:      Test.Tasty.Config-                        Test.Tasty.Discover-                        Test.Tasty.Generator+  exposed-modules:      Test.Tasty.Discover+                        Test.Tasty.Discover.Internal.Config+                        Test.Tasty.Discover.Internal.Driver+                        Test.Tasty.Discover.Internal.Generator+                        Test.Tasty.Discover.TastyInfo+                        Test.Tasty.Discover.Version   other-modules:        Paths_tasty_discover   autogen-modules:      Paths_tasty_discover-  hs-source-dirs:       library+  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@@ -81,6 +87,7 @@ test-suite tasty-discover-test   import:               base                       , Glob+                      , bytestring                       , containers                       , directory                       , filepath@@ -88,6 +95,7 @@                       , hspec                       , hspec-core                       , tasty+                      , tasty-golden                       , tasty-hedgehog                       , tasty-hspec                       , tasty-hunit

@@ -5,10 +5,10 @@  module ConfigTest where -import Data.List             (isInfixOf, sort)-import Test.Tasty.Config-import Test.Tasty.Discover   (ModuleTree (..), findTests, generateTestDriver, mkModuleTree, showTests)-import Test.Tasty.Generator  (Test (..), mkTest)+import Data.List                              (isInfixOf, sort)+import Test.Tasty.Discover.Internal.Config+import Test.Tasty.Discover.Internal.Driver    (ModuleTree (..), findTests, generateTestDriver, mkModuleTree, showTests)+import Test.Tasty.Discover.Internal.Generator (Test (..), mkTest)  import Test.Tasty.HUnit import Test.Tasty.QuickCheck

@@ -5,50 +5,109 @@  module DiscoverTest where +import Data.ByteString.Lazy (ByteString) import Data.List+import Data.String (IsString(..))+import Test.Hspec (shouldBe)+import Test.Hspec.Core.Spec (Spec, describe, it) import Test.Tasty+import Test.Tasty.Golden import Test.Tasty.HUnit-import Test.Tasty.QuickCheck-import Test.Hspec.Core.Spec (Spec, describe, it)-import Test.Hspec (shouldBe)+import Test.Tasty.QuickCheck hiding (Property, property) -import qualified Hedgehog       as H-import qualified Hedgehog.Gen   as G-import qualified Hedgehog.Range as R+import qualified Hedgehog            as H+import qualified Hedgehog.Gen        as G+import qualified Hedgehog.Range      as R+import qualified Test.Tasty.Discover as TD+import qualified Test.Tasty.Hedgehog as TH +------------------------------------------------------------------------------------------------+ unit_listCompare :: IO () unit_listCompare = [1 :: Int, 2, 3] `compare` [1,2] @?= GT +------------------------------------------------------------------------------------------------+ prop_additionCommutative :: Int -> Int -> Bool prop_additionCommutative a b = a + b == b + a +------------------------------------------------------------------------------------------------+ scprop_sortReverse :: [Int] -> Bool scprop_sortReverse list = sort list == sort (reverse list) +------------------------------------------------------------------------------------------------+ spec_prelude :: Spec spec_prelude = describe "Prelude.head" $ do   it "returns the first element of a list" $ do     head [23 ..] `shouldBe` (23 :: Int) +------------------------------------------------------------------------------------------------+ test_addition :: TestTree test_addition = testProperty "Addition commutes" $ \(a :: Int) (b :: Int) -> a + b == b + a +------------------------------------------------------------------------------------------------+ test_multiplication :: [TestTree] test_multiplication =   [ testProperty "Multiplication commutes" $ \(a :: Int) (b :: Int) -> a * b == b * a   , testProperty "One is identity" $ \(a :: Int) -> a == a   ] +------------------------------------------------------------------------------------------------+ test_generateTree :: IO TestTree test_generateTree = do   let input = "Some input"   pure $ testCase input $ pure () +------------------------------------------------------------------------------------------------+ test_generateTrees :: IO [TestTree] 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++newtype Property = Property+  { unProperty :: H.Property+  }++instance TD.Tasty Property where+  tasty info (Property p) = pure $+#if MIN_VERSION_tasty_hedgehog(1, 2, 0)+    TH.testPropertyNamed (TD.nameOf info) (fromString (TD.descriptionOf info)) p+#else+    TH.testProperty (TD.nameOf info) p+#endif++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++------------------------------------------------------------------------------------------------+-- How to use tasty-hedgehog up to version 1.1++{- HLINT ignore "Avoid reverse" -} hprop_reverse :: H.Property hprop_reverse = H.property $ do   xs <- H.forAll $ G.list (R.linear 0 100) G.alpha   reverse (reverse xs) H.=== xs++------------------------------------------------------------------------------------------------+-- How to add custom support for golden tests.++data GoldenTest = GoldenTest FilePath (IO ByteString)++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"

@@ -5,30 +5,20 @@ module Main (main, ingredients, tests) where  import Prelude--import qualified System.Environment as E-import qualified Test.Tasty as T-import qualified Test.Tasty.Ingredients as T-import qualified Test.Tasty.Hedgehog as H--import qualified Test.Tasty.QuickCheck as QC--import qualified Test.Tasty.SmallCheck as SC--import qualified Test.Tasty.Hspec as HS---import qualified Test.Tasty.HUnit as HU- import qualified ConfigTest- import qualified DiscoverTest- import qualified SubMod.FooBaz- import qualified SubMod.PropTest- import qualified SubMod.SubSubMod.PropTest+import qualified System.Environment as E+import qualified Test.Tasty as T+import qualified Test.Tasty.Discover as TD+import qualified Test.Tasty.HUnit as HU+import qualified Test.Tasty.Hedgehog as H+import qualified Test.Tasty.Hspec as HS+import qualified Test.Tasty.Ingredients as T+import qualified Test.Tasty.QuickCheck as QC+import qualified Test.Tasty.SmallCheck as SC  {- HLINT ignore "Use let" -} @@ -36,6 +26,7 @@   + class TestGroup a where testGroup :: String -> a -> IO T.TestTree instance TestGroup T.TestTree        where testGroup _ a = pure a instance TestGroup [T.TestTree]      where testGroup n a = pure $ T.testGroup n a@@ -79,17 +70,19 @@    t14 <- testGroup "generateTrees" DiscoverTest.test_generateTrees -  t15 <- pure $ H.testProperty "reverse" DiscoverTest.hprop_reverse+  t15 <- TD.tasty (TD.description "reverse" <> TD.name "DiscoverTest.tasty_reverse") DiscoverTest.tasty_reverse -  t16 <- pure $ QC.testProperty "additionCommutative" SubMod.FooBaz.prop_additionCommutative+  t16 <- pure $ H.testProperty "reverse" DiscoverTest.hprop_reverse -  t17 <- pure $ QC.testProperty "multiplationDistributiveOverAddition" SubMod.FooBaz.prop_multiplationDistributiveOverAddition+  t17 <- pure $ QC.testProperty "additionCommutative" SubMod.FooBaz.prop_additionCommutative -  t18 <- pure $ QC.testProperty "additionAssociative" SubMod.PropTest.prop_additionAssociative+  t18 <- pure $ QC.testProperty "multiplationDistributiveOverAddition" SubMod.FooBaz.prop_multiplationDistributiveOverAddition -  t19 <- pure $ QC.testProperty "additionCommutative" SubMod.SubSubMod.PropTest.prop_additionCommutative+  t19 <- pure $ QC.testProperty "additionAssociative" SubMod.PropTest.prop_additionAssociative -  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 <- 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] ingredients :: [T.Ingredient] ingredients = T.defaultIngredients main :: IO ()