diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/executable/Main.hs b/executable/Main.hs --- a/executable/Main.hs +++ b/executable/Main.hs @@ -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 () diff --git a/library/Test/Tasty/Config.hs b/library/Test/Tasty/Config.hs deleted file mode 100644 --- a/library/Test/Tasty/Config.hs +++ /dev/null @@ -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 -- ^ <<>>: 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] -- ^ <<>>: 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 -- ^ <<>>: 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=''` 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=''` 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") - "<<>>: 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") - "<<>>: 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}) - "<<>>: 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" - ] diff --git a/library/Test/Tasty/Discover.hs b/library/Test/Tasty/Discover.hs deleted file mode 100644 --- a/library/Test/Tasty/Discover.hs +++ /dev/null @@ -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) diff --git a/library/Test/Tasty/Generator.hs b/library/Test/Tasty/Generator.hs deleted file mode 100644 --- a/library/Test/Tasty/Generator.hs +++ /dev/null @@ -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 - } diff --git a/src/Test/Tasty/Discover.hs b/src/Test/Tasty/Discover.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover.hs @@ -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 "" (getLast (TI.name info))) + +descriptionOf :: TastyInfo -> String +descriptionOf info = (fromMaybe "" (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 + } diff --git a/src/Test/Tasty/Discover/Internal/Config.hs b/src/Test/Tasty/Discover/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/Internal/Config.hs @@ -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 -- ^ <<>>: 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] -- ^ <<>>: 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 -- ^ <<>>: 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=''` 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=''` 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") + "<<>>: 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") + "<<>>: 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}) + "<<>>: 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" + ] diff --git a/src/Test/Tasty/Discover/Internal/Driver.hs b/src/Test/Tasty/Discover/Internal/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/Internal/Driver.hs @@ -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) diff --git a/src/Test/Tasty/Discover/Internal/Generator.hs b/src/Test/Tasty/Discover/Internal/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/Internal/Generator.hs @@ -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 + } diff --git a/src/Test/Tasty/Discover/TastyInfo.hs b/src/Test/Tasty/Discover/TastyInfo.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/TastyInfo.hs @@ -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 + } diff --git a/src/Test/Tasty/Discover/Version.hs b/src/Test/Tasty/Discover/Version.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Discover/Version.hs @@ -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 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 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 diff --git a/test/ConfigTest.hs b/test/ConfigTest.hs --- a/test/ConfigTest.hs +++ b/test/ConfigTest.hs @@ -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 diff --git a/test/DiscoverTest.hs b/test/DiscoverTest.hs --- a/test/DiscoverTest.hs +++ b/test/DiscoverTest.hs @@ -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" diff --git a/test/Driver.hs b/test/Driver.hs --- a/test/Driver.hs +++ b/test/Driver.hs @@ -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 ()