diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,21 @@ [Keep a Changelog]: http://keepachangelog.com/ [Semantic Versioning]: http://semver.org/ +# 3.0.0 2017-05-03 + +### Added +- [#103]: Added `--tree-display` configuration option. + +### Changed +- [#97]: `case_` is deprecated in favour of `unit_` for HUnit test cases. + +### Fixed +- [#102]: `--no-module-suffix` incorrectly handling directories. + +[#97]: https://github.com/lwm/tasty-discover/pull/97 +[#102]: https://github.com/lwm/tasty-discover/pull/102 +[#103]: https://github.com/lwm/tasty-discover/pull/103 + # 2.0.3 [2017-04-13] ### Fixed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ [![Build Status](https://travis-ci.org/lwm/tasty-discover.svg?branch=master)](https://travis-ci.org/lwm/tasty-discover) -[![Hackage Status](https://img.shields.io/badge/Hackage-2.0.1-brightgreen.svg)](http://hackage.haskell.org/package/tasty-discover) -[![Stackage Status](https://img.shields.io/badge/Stackage-2.0.1-brightgreen.svg)](https://www.stackage.org/package/tasty-discover/) +[![Hackage Status](https://img.shields.io/badge/Hackage-2.0.3-brightgreen.svg)](http://hackage.haskell.org/package/tasty-discover) +[![Stackage Status](https://img.shields.io/badge/Stackage-2.0.3-brightgreen.svg)](https://www.stackage.org/package/tasty-discover/) [![GitHub license](https://img.shields.io/badge/license-MIT-brightgreen.svg)](https://raw.githubusercontent.com/lwm/tasty-discover/master/LICENSE) # tasty-discover @@ -9,6 +9,15 @@ [tasty framework]: https://github.com/feuerbach/tasty +### Table Of Contents + +- [Getting Started](#getting-started) +- [Examples](#examples) +- [Configuration](#configuration) +- [Change Log](#change-log) +- [Contributing](#contributing) +- [Acknowledgements](#acknowledgements) + # Getting Started ![Usage GIF](http://i.imgur.com/gpdHc6x.gif) @@ -20,7 +29,7 @@ - Write your tests with the following prefixes: - `prop_`: [QuickCheck](http://hackage.haskell.org/package/tasty-quickcheck) properties. - `scprop_`: [SmallCheck](http://hackage.haskell.org/package/tasty-smallcheck) properties. - - `case_`: [HUnit](http://hackage.haskell.org/package/tasty-hunit) test cases. + - `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. @@ -37,8 +46,8 @@ import Test.Tasty.QuickCheck -- HUnit test case -case_listCompare :: IO () -case_listCompare = [1, 2, 3] `compare` [1,2] @?= GT +unit_listCompare :: IO () +unit_listCompare = [1, 2, 3] `compare` [1,2] @?= GT -- QuickCheck property prop_additionCommutative :: Int -> Int -> Bool @@ -99,9 +108,9 @@ - `--ingredient`: Tasty ingredients to add to your test runner. # Change Log -See the [Change log] for the latest changes. +See the [change log] for the latest changes. -[Change log]: https://github.com/lwm/tasty-discover/blob/master/CHANGELOG.md +[change log]: https://github.com/lwm/tasty-discover/blob/master/CHANGELOG.md # Contributing All contributions welcome! diff --git a/executable/Main.hs b/executable/Main.hs --- a/executable/Main.hs +++ b/executable/Main.hs @@ -24,7 +24,7 @@ tests <- findTests src config let ingredients = tastyIngredients config moduleName = fromMaybe "Main" (generatedModuleName config) - output = generateTestDriver moduleName ingredients src tests + output = generateTestDriver config moduleName ingredients src tests when (debug config) $ hPutStrLn stderr output writeFile dst output _ -> do diff --git a/library/Test/Tasty/Config.hs b/library/Test/Tasty/Config.hs --- a/library/Test/Tasty/Config.hs +++ b/library/Test/Tasty/Config.hs @@ -19,11 +19,12 @@ , tastyIngredients :: [Ingredient] , noModuleSuffix :: Bool , debug :: Bool + , treeDisplay :: Bool } deriving (Show) -- | The default configuration defaultConfig :: Config -defaultConfig = Config Nothing Nothing [] [] False False +defaultConfig = Config Nothing Nothing [] [] False False False -- | Configuration options parser. parseConfig :: String -> [String] -> Either String Config @@ -61,4 +62,7 @@ , 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 --- a/library/Test/Tasty/Discover.hs +++ b/library/Test/Tasty/Discover.hs @@ -3,6 +3,7 @@ import Data.List (dropWhileEnd, intercalate, isPrefixOf, isSuffixOf, nub) +import qualified Data.Map.Strict as M import Data.Traversable (for) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (takeDirectory, ()) @@ -10,8 +11,8 @@ import Test.Tasty.Generator (Generator (..), Test (..), generators, getGenerators, mkTest, showSetup) -generateTestDriver :: String -> [String] -> FilePath -> [Test] -> String -generateTestDriver modname is src 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 @@ -29,7 +30,7 @@ , "tests = do\n" , unlines $ zipWith showSetup tests testNumVars , " pure $ T.testGroup \"" ++ src ++ "\" [" - , intercalate "," $ zipWith (curry snd) tests testNumVars + , intercalate "," $ showTests config tests testNumVars , "]\n" , concat [ "ingredients :: [T.Ingredient]\n" @@ -48,14 +49,15 @@ filesBySuffix :: FilePath -> [String] -> IO [FilePath] filesBySuffix dir suffixes = do entries <- filter isHidden <$> getDirectoryContents dir - found <- for entries $ \entry -> do + fmap concat $ for entries $ \entry -> do let dir' = dir entry dirExists <- doesDirectoryExist dir' if dirExists then map (entry ) <$> filesBySuffix dir' suffixes + else if any (`isSuffixOf` entry) suffixes then + pure [entry] else pure [] - pure $ filter (\x -> any (`isSuffixOf` x) suffixes) entries ++ concat found isIgnored :: [FilePath] -> String -> Bool isIgnored ignores filename = filename `notElem` addSuffixes ignores @@ -63,14 +65,10 @@ findTests :: FilePath -> Config -> IO [Test] findTests src config = do let dir = takeDirectory src - suffixes = testFileSuffixes (moduleSuffix config) + suffixes = testFileSuffixes config ignores = ignoredModules config - files <- - if noModuleSuffix config - then filter isHidden <$> getDirectoryContents dir - else filesBySuffix dir suffixes - let files' = filter (isIgnored ignores) files - concat <$> traverse (extract dir) files' + files <- filter (isIgnored ignores) <$> filesBySuffix dir suffixes + concat <$> traverse (extract dir) files where extract dir file = extractTests file <$> readFile (dir file) @@ -82,10 +80,12 @@ checkPrefix g = (`isPrefixOf` g) . generatorPrefix parseTest = map fst . concatMap lex . lines -testFileSuffixes :: Maybe String -> [String] -testFileSuffixes suffix = addSuffixes suffixes +testFileSuffixes :: Config -> [String] +testFileSuffixes config = if noModuleSuffix config + then [""] + else addSuffixes suffixes where - suffixes = case suffix of + suffixes = case moduleSuffix config of Just suffix' -> [suffix'] Nothing -> ["Spec", "Test"] @@ -97,3 +97,35 @@ ingredients :: [String] -> String ingredients is = concat $ map (++":") is ++ ["T.defaultIngredients"] + +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 --- a/library/Test/Tasty/Generator.hs +++ b/library/Test/Tasty/Generator.hs @@ -37,17 +37,24 @@ where chooser c1 c2 = map $ \c3 -> if c3 == c1 then c2 else c3 getGenerator :: Test -> Generator -getGenerator t = fromJust $ find ((`isPrefixOf` testFunction t) . generatorPrefix) generators +getGenerator t = fromJust $ getPrefix generators + where getPrefix = find ((`isPrefixOf` testFunction t) . generatorPrefix) getGenerators :: [Test] -> [Generator] -getGenerators = map head . groupBy ((==) `on` generatorPrefix) . sortOn generatorPrefix . map getGenerator +getGenerators = + map head . + groupBy ((==) `on` generatorPrefix) . + sortOn generatorPrefix . + map getGenerator showSetup :: Test -> String -> String -showSetup t var = " " ++ var ++ " <- " ++ generatorSetup (getGenerator t) t ++ "\n" +showSetup t var = " " ++ var ++ " <- " ++ setup ++ "\n" + where setup = generatorSetup (getGenerator t) t generators :: [Generator] generators = [ quickCheckPropertyGenerator + , hunitTestCaseGeneratorDeprecated , hunitTestCaseGenerator , hspecTestCaseGenerator , tastyTestGroupGenerator @@ -61,9 +68,29 @@ , generatorSetup = \t -> "pure $ QC.testProperty \"" ++ name t ++ "\" " ++ qualifyFunction t } +deprecationMessage :: String +deprecationMessage = + error $ concat + [ "\n\n" + , "----------------------------------------------------------\n" + , "DEPRECATION NOTICE: The `case_` prefix is deprecated.\n" + , "Please use the `unit_` prefix instead.\n" + , "Please see https://github.com/lwm/tasty-discover/issues/95.\n" + , "----------------------------------------------------------\n" + ] + +-- DEPRECATED: Use `unit_` instead (below) +hunitTestCaseGeneratorDeprecated :: Generator +hunitTestCaseGeneratorDeprecated = Generator + { generatorPrefix = "case_" + , generatorImport = deprecationMessage + , generatorClass = deprecationMessage + , generatorSetup = const deprecationMessage + } + hunitTestCaseGenerator :: Generator hunitTestCaseGenerator = Generator - { generatorPrefix = "case_" + { generatorPrefix = "unit_" , generatorImport = "import qualified Test.Tasty.HUnit as HU\n" , generatorClass = concat [ "class TestCase a where testCase :: String -> a -> IO T.TestTree\n" diff --git a/tasty-discover.cabal b/tasty-discover.cabal --- a/tasty-discover.cabal +++ b/tasty-discover.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: tasty-discover -version: 2.0.3 +version: 3.0.0 synopsis: Test discovery for the tasty framework. description: Automatic test discovery and runner for the tasty framework. Prefix your test case names and tasty-discover will discover, collect and run them. All popular test libraries are covered. Configure once and then just write your tests. Avoid forgetting to add test modules to your Cabal/Hpack files. Tasty ingredients are included along with various configuration options for different use cases. Please see the `README.md` below for how to get started. @@ -33,6 +33,7 @@ ghc-options: -Wall build-depends: base >= 4.8 && < 5 + , containers >= 0.4 , directory >= 1.1 && < 1.4 , filepath >= 1.3 && < 1.5 exposed-modules: @@ -46,6 +47,7 @@ ghc-options: -Wall build-depends: base >= 4.8 && < 5 + , containers >= 0.4 , directory >= 1.1 && < 1.4 , filepath >= 1.3 && < 1.5 , tasty-discover @@ -59,6 +61,7 @@ ghc-options: -Wall build-depends: base >= 4.8 && < 5 + , containers >= 0.4 , directory >= 1.1 && < 1.4 , filepath >= 1.3 && < 1.5 , base diff --git a/test/ConfigTest.hs b/test/ConfigTest.hs --- a/test/ConfigTest.hs +++ b/test/ConfigTest.hs @@ -1,31 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module ConfigTest where import Data.List (isInfixOf) +import qualified Data.Map.Strict as M import Test.Tasty.Config -import Test.Tasty.Discover (findTests, generateTestDriver) -import Test.Tasty.Generator (mkTest) +import Test.Tasty.Discover (findTests, generateTestDriver, showTests, + ModuleTree(..), mkModuleTree) +import Test.Tasty.Generator (Test(..), mkTest) import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -case_noModuleSuffixEmptyList :: IO () -case_noModuleSuffixEmptyList = do +unit_noModuleSuffixEmptyList :: IO () +unit_noModuleSuffixEmptyList = do actual <- findTests "test/SubMod/" (defaultConfig { moduleSuffix = Just "DoesntExist"}) actual @?= [] -case_differentGeneratedModule :: Assertion -case_differentGeneratedModule = assertBool "" ("FunkyModuleName" `isInfixOf` generatedModule) - where generatedModule = generateTestDriver "FunkyModuleName" [] "test/" [] +unit_differentGeneratedModule :: Assertion +unit_differentGeneratedModule = assertBool "" ("FunkyModuleName" `isInfixOf` generatedModule) + where generatedModule = generateTestDriver defaultConfig "FunkyModuleName" [] "test/" [] -case_ignoreAModule :: IO () -case_ignoreAModule = do +unit_ignoreAModule :: IO () +unit_ignoreAModule = do actual <- findTests "test/SubMod/" (defaultConfig { ignoredModules = ["PropTest"] }) actual @?= [] -case_noModuleSuffix :: IO () -case_noModuleSuffix = do +unit_noModuleSuffix :: IO () +unit_noModuleSuffix = do actual1 <- findTests "test/SubMod/" defaultConfig actual1 @?= [mkTest "PropTest" "prop_additionAssociative"] actual2 <- findTests "test/SubMod/" (defaultConfig { noModuleSuffix = True }) let expected = [ mkTest "FooBaz" "prop_additionCommutative" + , mkTest "FooBaz" "prop_multiplationDistributiveOverAddition" , mkTest "PropTest" "prop_additionAssociative" ] assertBool "" $ all (`elem` expected) actual2 + +unit_noModuleSuffixRecurseDirs :: IO () +unit_noModuleSuffixRecurseDirs = do + tests <- findTests "test/" (defaultConfig { noModuleSuffix = True }) + assertBool "" $ elem (mkTest "SubMod/FooBaz" "prop_additionCommutative") tests + +unit_noTreeDisplayDefault :: IO () +unit_noTreeDisplayDefault = do + let config = defaultConfig { noModuleSuffix = True } + tests <- findTests "test/SubMod/" config + let testNumVars = map (('t' :) . show) [(0::Int)..] + trees = showTests config tests testNumVars + length trees @?= 3 + +unit_treeDisplay :: IO () +unit_treeDisplay = do + let config = defaultConfig { noModuleSuffix = True, treeDisplay = True } + tests <- findTests "test/SubMod/" config + let testNumVars = map (('t' :) . show) [(0::Int)..] + trees = showTests config tests testNumVars + length trees @?= 2 + +prop_mkModuleTree :: ModuleTree -> Property +prop_mkModuleTree mtree = + let (tests, testVars) = unzip $ flattenTree mtree + in mkModuleTree tests testVars === mtree + where + flattenTree (ModuleTree mp) = M.assocs mp >>= flattenModule + flattenModule (mdl, (subTree, testVars)) = concat + [ map (\(Test subMdl _, tVar) -> (Test (mdl ++ '.':subMdl) "-", tVar)) (flattenTree subTree) + , map (\tVar -> (Test mdl "-", tVar)) testVars ] + +instance Arbitrary ModuleTree where + arbitrary = sized $ \size -> + resize (min size 12) (ModuleTree . M.fromList <$> listOf1 mdlGen) + where + mdlGen = sized $ \size -> do + mdl <- listOf1 (elements ['a'..'z']) + subTree <- if size == 0 + then pure $ ModuleTree M.empty + else resize (size `div` 2) arbitrary + tVars <- listOf1 (listOf1 arbitrary) + pure (mdl, (subTree, tVars)) diff --git a/test/DiscoverTest.hs b/test/DiscoverTest.hs --- a/test/DiscoverTest.hs +++ b/test/DiscoverTest.hs @@ -8,8 +8,8 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck -case_listCompare :: IO () -case_listCompare = [1 :: Int, 2, 3] `compare` [1,2] @?= GT +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 diff --git a/test/SubMod/FooBaz.hs b/test/SubMod/FooBaz.hs --- a/test/SubMod/FooBaz.hs +++ b/test/SubMod/FooBaz.hs @@ -2,3 +2,6 @@ prop_additionCommutative :: Int -> Int -> Bool prop_additionCommutative a b = a + b == b + a + +prop_multiplationDistributiveOverAddition :: Integer -> Integer -> Integer -> Bool +prop_multiplationDistributiveOverAddition a b c = a * (b + c) == a * b + a * c