{-# LANGUAGE CPP #-}
module Test.Tasty.Discover.Internal.Driver
(
generateTestDriver
, 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 :: [String]
defaultImports =
[ String
"import Prelude"
, String
"import qualified System.Environment as E"
, String
"import qualified Test.Tasty as T"
, String
"import qualified Test.Tasty.Ingredients as T"
]
generateTestDriver :: Config -> String -> [String] -> FilePath -> [Test] -> String
generateTestDriver :: Config -> String -> [String] -> String -> [Test] -> String
generateTestDriver Config
config String
modname [String]
is String
src [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 ((String
"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) [(Int
0 :: Int)..]
testKindImports :: [[String]]
testKindImports = (Generator -> [String]) -> [Generator] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Generator -> [String]
generatorImports [Generator]
generators' :: [[String]]
testImports :: [String]
testImports = [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]
in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"{-# LANGUAGE FlexibleInstances #-}\n"
, String
"\n"
, String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (main, ingredients, tests) where\n"
, String
"\n"
, [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]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat ([String]
defaultImports[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:[[String]]
testKindImports) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
testImports
, String
"\n"
, String
"{- HLINT ignore \"Use let\" -}\n"
, String
"\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
generatorClass [Generator]
generators'
, String
"tests :: IO T.TestTree\n"
, String
"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
, String
" 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] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Config -> [Test] -> [String] -> [String]
showTests Config
config [Test]
tests [String]
testNumVars
, String
"]\n"
, String
"ingredients :: [T.Ingredient]\n"
, String
"ingredients = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
ingredients [String]
is String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
, String
"main :: IO ()\n"
, String
"main = do\n"
, String
" args <- E.getArgs\n"
, String
" 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]
++ String
" ++ args) $"
, String
" tests >>= T.defaultMainWithIngredients ingredients\n"
]
filesByModuleGlob :: FilePath -> Maybe GlobPattern -> IO [String]
filesByModuleGlob :: String -> Maybe String -> IO [String]
filesByModuleGlob String
directory Maybe String
globPattern = Pattern -> String -> IO [String]
globDir1 Pattern
pattern String
directory
where pattern :: Pattern
pattern = String -> Pattern
compile (String
"**/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"*.hs*" Maybe String
globPattern)
ignoreByModuleGlob :: [FilePath] -> Maybe GlobPattern -> [FilePath]
ignoreByModuleGlob :: [String] -> Maybe String -> [String]
ignoreByModuleGlob [String]
filePaths Maybe String
Nothing = [String]
filePaths
ignoreByModuleGlob [String]
filePaths (Just 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 -> String
forall a. [a] -> [a] -> [a]
++ String
ignoreGlob)
findTests :: Config -> IO [Test]
findTests :: Config -> IO [Test]
findTests Config
config = do
let directory :: String
directory = Config -> String
searchDir Config
config
[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)
sortedFiltered :: [String]
sortedFiltered = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
filtered
[[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]
sortedFiltered
where extract :: String -> String -> IO [Test]
extract String
directory String
filePath =
String -> IOMode -> (Handle -> IO [Test]) -> IO [Test]
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
filePath IOMode
ReadMode ((Handle -> IO [Test]) -> IO [Test])
-> (Handle -> IO [Test]) -> IO [Test]
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
#if defined(mingw32_HOST_OS)
hSetEncoding h $ mkLocaleEncoding TransliterateCodingFailure
#endif
[Test]
tests <- 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
Int -> IO [Test] -> IO [Test]
seq ([Test] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
tests) ([Test] -> IO [Test]
forall (m :: * -> *) a. Monad m => a -> m a
return [Test]
tests)
dropDirectory :: String -> String -> String
dropDirectory String
directory 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]
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 (\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 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 [String]
mods = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"import qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [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
/= Char
'.')
ingredients :: [String] -> String
ingredients :: [String] -> String
ingredients [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
":") [String]
is [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"T.defaultIngredients"]
showTests :: Config -> [Test] -> [String] -> [String]
showTests :: Config -> [Test] -> [String] -> [String]
showTests Config
config [Test]
tests [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 (String -> Test -> String) -> [String] -> [Test] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> Test -> String
forall a b. a -> b -> a
const [String]
testNumVars [Test]
tests
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 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 :: ([Char], (ModuleTree, [String])) -> [Char]
showModule :: (String, (ModuleTree, [String])) -> String
showModule (String
mdl, (ModuleTree 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
== Int
1 =
case Map String (ModuleTree, [String])
-> [(String, (ModuleTree, [String]))]
forall k a. Map k a -> [(k, a)]
M.assocs Map String (ModuleTree, [String])
subMdls of
[(String
subMdl, (ModuleTree
subSubTree, [String]
testVars))] -> (String, (ModuleTree, [String])) -> String
showModule (String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
subMdl, (ModuleTree
subSubTree, [String]
testVars))
[(String, (ModuleTree, [String]))]
as -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Excepted number of submodules != 1. Found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(String, (ModuleTree, [String]))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, (ModuleTree, [String]))]
as)
showModule (String
mdl, (ModuleTree
subTree, [String]
testVars)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"T.testGroup \"", String
mdl
, String
"\" [", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (ModuleTree -> [String]
showModuleTree ModuleTree
subTree [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
testVars), String
"]" ]
mkModuleTree :: [Test] -> [String] -> ModuleTree
mkModuleTree :: [Test] -> [String] -> ModuleTree
mkModuleTree [Test]
tests [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 (\Test
t 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 (String
mdl, String
tVar) 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 (String
key, (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
== Char
'.') String
mdl of
(String
_, []) -> (String
mdl, (Map String (ModuleTree, [String]) -> ModuleTree
ModuleTree Map String (ModuleTree, [String])
forall k a. Map k a
M.empty, [String
tVar]))
(String
topMdl, Char
'.':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)
_ -> String -> (String, (ModuleTree, [String]))
forall a. HasCallStack => String -> a
error String
"impossible case in mkModuleTree.go.key"
merge :: (ModuleTree, [String])
-> (ModuleTree, [String]) -> (ModuleTree, [String])
merge (ModuleTree Map String (ModuleTree, [String])
mdls1, [String]
tVars1) (ModuleTree Map String (ModuleTree, [String])
mdls2, [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)