{-# LANGUAGE CPP #-}
module Test.Tasty.Discover (
generateTestDriver
, ModuleTree (..)
, findTests
, mkModuleTree
, showTests
) where
import Data.List (dropWhileEnd, intercalate,
isPrefixOf, nub, stripPrefix)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
#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
import System.FilePath (pathSeparator, takeDirectory)
import System.FilePath.Glob (compile, globDir1, match)
import System.IO (IOMode (ReadMode), openFile)
import Test.Tasty.Config (Config (..), GlobPattern)
import Test.Tasty.Generator (Generator (..), Test (..),
generators, getGenerators, mkTest,
showSetup)
generateTestDriver :: Config -> String -> [String] -> FilePath -> [Test] -> String
generateTestDriver :: Config -> String -> [String] -> String -> [Test] -> String
generateTestDriver config :: Config
config modname :: String
modname is :: [String]
is src :: String
src tests :: [Test]
tests =
let generators' :: [Generator]
generators' = [Test] -> [Generator]
getGenerators [Test]
tests
testNumVars :: [String]
testNumVars = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (("t"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(0 :: Int)..]
in
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "{-# LINE 1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " #-}\n"
, "{-# LANGUAGE FlexibleInstances #-}\n"
, "module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modname String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (main, ingredients, tests) where\n"
, "import Prelude\n"
, "import qualified System.Environment as E\n"
, "import qualified Test.Tasty as T\n"
, "import qualified Test.Tasty.Ingredients as T\n"
, [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Generator -> String) -> [Generator] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Generator -> String
generatorImport [Generator]
generators'
, [String] -> String
showImports ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
ingredientImport [String]
is [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Test -> String) -> [Test] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Test -> String
testModule [Test]
tests)
, [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Generator -> String) -> [Generator] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Generator -> String
generatorClass [Generator]
generators'
, "tests :: IO T.TestTree\n"
, "tests = do\n"
, [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Test -> String -> String) -> [Test] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Test -> String -> String
showSetup [Test]
tests [String]
testNumVars
, " pure $ T.testGroup " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ["
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Config -> [Test] -> [String] -> [String]
showTests Config
config [Test]
tests [String]
testNumVars
, "]\n"
, "ingredients :: [T.Ingredient]\n"
, "ingredients = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
ingredients [String]
is String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
, "main :: IO ()\n"
, "main = do\n"
, " args <- E.getArgs\n"
, " E.withArgs (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (Config -> [String]
tastyOptions Config
config) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ++ args) $"
, " tests >>= T.defaultMainWithIngredients ingredients\n"
]
filesByModuleGlob :: FilePath -> Maybe GlobPattern -> IO [String]
filesByModuleGlob :: String -> Maybe String -> IO [String]
filesByModuleGlob directory :: String
directory globPattern :: Maybe String
globPattern = do
Pattern -> String -> IO [String]
globDir1 Pattern
pattern String
directory
where pattern :: Pattern
pattern = String -> Pattern
compile ("**/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "*.hs*" Maybe String
globPattern)
ignoreByModuleGlob :: [FilePath] -> Maybe GlobPattern -> [FilePath]
ignoreByModuleGlob :: [String] -> Maybe String -> [String]
ignoreByModuleGlob filePaths :: [String]
filePaths Nothing = [String]
filePaths
ignoreByModuleGlob filePaths :: [String]
filePaths (Just ignoreGlob :: String
ignoreGlob) = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> String -> Bool
match Pattern
pattern) [String]
filePaths
where pattern :: Pattern
pattern = String -> Pattern
compile ("**/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ignoreGlob)
findTests :: FilePath -> Config -> IO [Test]
findTests :: String -> Config -> IO [Test]
findTests src :: String
src config :: Config
config = do
let directory :: String
directory = String -> String
takeDirectory String
src
[String]
allModules <- String -> Maybe String -> IO [String]
filesByModuleGlob String
directory (Config -> Maybe String
modules Config
config)
let filtered :: [String]
filtered = [String] -> Maybe String -> [String]
ignoreByModuleGlob [String]
allModules (Config -> Maybe String
ignores Config
config)
[[Test]] -> [Test]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Test]] -> [Test]) -> IO [[Test]] -> IO [Test]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [Test]) -> [String] -> IO [[Test]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> String -> IO [Test]
extract String
directory) [String]
filtered
where
extract :: String -> String -> IO [Test]
extract directory :: String
directory filePath :: String
filePath = do
Handle
h <- String -> IOMode -> IO Handle
openFile String
filePath IOMode
ReadMode
#if defined(mingw32_HOST_OS)
hSetEncoding h $ mkLocaleEncoding TransliterateCodingFailure
#endif
String -> String -> [Test]
extractTests (String -> String -> String
dropDirectory String
directory String
filePath) (String -> [Test]) -> IO String -> IO [Test]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO String
hGetContents Handle
h
dropDirectory :: String -> String -> String
dropDirectory directory :: String
directory filePath :: String
filePath = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
filePath (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$
String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String
directory String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator]) String
filePath
extractTests :: FilePath -> String -> [Test]
file :: String
file = [String] -> [Test]
mkTestDeDuped ([String] -> [Test]) -> (String -> [String]) -> String -> [Test]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
isKnownPrefix ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parseTest
where
mkTestDeDuped :: [String] -> [Test]
mkTestDeDuped = (String -> Test) -> [String] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Test
mkTest String
file) ([String] -> [Test])
-> ([String] -> [String]) -> [String] -> [Test]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub
isKnownPrefix :: [String] -> [String]
isKnownPrefix = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: String
g -> (Generator -> Bool) -> [Generator] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Generator -> Bool
checkPrefix String
g) [Generator]
generators)
checkPrefix :: String -> Generator -> Bool
checkPrefix g :: String
g = (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
g) (String -> Bool) -> (Generator -> String) -> Generator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator -> String
generatorPrefix
parseTest :: String -> [String]
parseTest = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst ([(String, String)] -> [String])
-> (String -> [(String, String)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [(String, String)]) -> [String] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [(String, String)]
lex ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
showImports :: [String] -> String
showImports :: [String] -> String
showImports mods :: [String]
mods = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\m :: String
m -> "import qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n") [String]
mods
ingredientImport :: String -> String
ingredientImport :: String -> String
ingredientImport = String -> String
forall a. [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.')
ingredients :: [String] -> String
ingredients :: [String] -> String
ingredients is :: [String]
is = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++":") [String]
is [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["T.defaultIngredients"]
showTests :: Config -> [Test] -> [String] -> [String]
showTests :: Config -> [Test] -> [String] -> [String]
showTests config :: Config
config tests :: [Test]
tests testNumVars :: [String]
testNumVars = if Config -> Bool
treeDisplay Config
config
then ModuleTree -> [String]
showModuleTree (ModuleTree -> [String]) -> ModuleTree -> [String]
forall a b. (a -> b) -> a -> b
$ [Test] -> [String] -> ModuleTree
mkModuleTree [Test]
tests [String]
testNumVars
else (Test -> String -> String) -> [Test] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Test, String) -> String) -> Test -> String -> String
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Test, String) -> String
forall a b. (a, b) -> b
snd) [Test]
tests [String]
testNumVars
newtype ModuleTree = ModuleTree (M.Map String (ModuleTree, [String]))
deriving (ModuleTree -> ModuleTree -> Bool
(ModuleTree -> ModuleTree -> Bool)
-> (ModuleTree -> ModuleTree -> Bool) -> Eq ModuleTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleTree -> ModuleTree -> Bool
$c/= :: ModuleTree -> ModuleTree -> Bool
== :: ModuleTree -> ModuleTree -> Bool
$c== :: ModuleTree -> ModuleTree -> Bool
Eq, Int -> ModuleTree -> String -> String
[ModuleTree] -> String -> String
ModuleTree -> String
(Int -> ModuleTree -> String -> String)
-> (ModuleTree -> String)
-> ([ModuleTree] -> String -> String)
-> Show ModuleTree
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ModuleTree] -> String -> String
$cshowList :: [ModuleTree] -> String -> String
show :: ModuleTree -> String
$cshow :: ModuleTree -> String
showsPrec :: Int -> ModuleTree -> String -> String
$cshowsPrec :: Int -> ModuleTree -> String -> String
Show)
showModuleTree :: ModuleTree -> [String]
showModuleTree :: ModuleTree -> [String]
showModuleTree (ModuleTree mdls :: Map String (ModuleTree, [String])
mdls) = ((String, (ModuleTree, [String])) -> String)
-> [(String, (ModuleTree, [String]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (ModuleTree, [String])) -> String
showModule ([(String, (ModuleTree, [String]))] -> [String])
-> [(String, (ModuleTree, [String]))] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String (ModuleTree, [String])
-> [(String, (ModuleTree, [String]))]
forall k a. Map k a -> [(k, a)]
M.assocs Map String (ModuleTree, [String])
mdls
where
showModule :: (String, (ModuleTree, [String])) -> String
showModule (mdl :: String
mdl, (ModuleTree subMdls :: Map String (ModuleTree, [String])
subMdls, [])) | Map String (ModuleTree, [String]) -> Int
forall k a. Map k a -> Int
M.size Map String (ModuleTree, [String])
subMdls Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 =
let [(subMdl :: String
subMdl, (subSubTree :: ModuleTree
subSubTree, testVars :: [String]
testVars))] = Map String (ModuleTree, [String])
-> [(String, (ModuleTree, [String]))]
forall k a. Map k a -> [(k, a)]
M.assocs Map String (ModuleTree, [String])
subMdls
in (String, (ModuleTree, [String])) -> String
showModule (String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ '.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
subMdl, (ModuleTree
subSubTree, [String]
testVars))
showModule (mdl :: String
mdl, (subTree :: ModuleTree
subTree, testVars :: [String]
testVars)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "T.testGroup \"", String
mdl
, "\" [", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," (ModuleTree -> [String]
showModuleTree ModuleTree
subTree [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
testVars), "]" ]
mkModuleTree :: [Test] -> [String] -> ModuleTree
mkModuleTree :: [Test] -> [String] -> ModuleTree
mkModuleTree tests :: [Test]
tests testVars :: [String]
testVars = Map String (ModuleTree, [String]) -> ModuleTree
ModuleTree (Map String (ModuleTree, [String]) -> ModuleTree)
-> Map String (ModuleTree, [String]) -> ModuleTree
forall a b. (a -> b) -> a -> b
$
((String, String)
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String]))
-> Map String (ModuleTree, [String])
-> [(String, String)]
-> Map String (ModuleTree, [String])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String)
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
go Map String (ModuleTree, [String])
forall k a. Map k a
M.empty ([(String, String)] -> Map String (ModuleTree, [String]))
-> [(String, String)] -> Map String (ModuleTree, [String])
forall a b. (a -> b) -> a -> b
$ (Test -> String -> (String, String))
-> [Test] -> [String] -> [(String, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\t :: Test
t tVar :: String
tVar -> (Test -> String
testModule Test
t, String
tVar)) [Test]
tests [String]
testVars
where
go :: (String, String)
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
go (mdl :: String
mdl, tVar :: String
tVar) mdls :: Map String (ModuleTree, [String])
mdls = ((ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String]))
-> String
-> (ModuleTree, [String])
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String])
merge String
key (ModuleTree, [String])
val Map String (ModuleTree, [String])
mdls
where
(key :: String
key, val :: (ModuleTree, [String])
val) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') String
mdl of
(_, []) -> (String
mdl, (Map String (ModuleTree, [String]) -> ModuleTree
ModuleTree Map String (ModuleTree, [String])
forall k a. Map k a
M.empty, [String
tVar]))
(topMdl :: String
topMdl, '.':subMdl :: String
subMdl) -> (String
topMdl, (Map String (ModuleTree, [String]) -> ModuleTree
ModuleTree (Map String (ModuleTree, [String]) -> ModuleTree)
-> Map String (ModuleTree, [String]) -> ModuleTree
forall a b. (a -> b) -> a -> b
$ (String, String)
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
go (String
subMdl, String
tVar) Map String (ModuleTree, [String])
forall k a. Map k a
M.empty, []))
_ -> String -> (String, (ModuleTree, [String]))
forall a. HasCallStack => String -> a
error "impossible case in mkModuleTree.go.key"
merge :: (ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String])
merge (ModuleTree mdls1 :: Map String (ModuleTree, [String])
mdls1, tVars1 :: [String]
tVars1) (ModuleTree mdls2 :: Map String (ModuleTree, [String])
mdls2, tVars2 :: [String]
tVars2) =
(Map String (ModuleTree, [String]) -> ModuleTree
ModuleTree (Map String (ModuleTree, [String]) -> ModuleTree)
-> Map String (ModuleTree, [String]) -> ModuleTree
forall a b. (a -> b) -> a -> b
$ ((ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String]))
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
-> Map String (ModuleTree, [String])
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String])
merge Map String (ModuleTree, [String])
mdls1 Map String (ModuleTree, [String])
mdls2, [String]
tVars1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
tVars2)