{-# 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, 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)

-- | Main function generator, along with all the boilerplate which
-- which will run the discovered tests.
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"
      ]

-- | Match files by specified glob pattern.
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)

-- | Filter and remove files by specified glob pattern.
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)

-- | Discover the tests modules.
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)
      -- Avoid internal error: hGetContents: invalid argument (invalid byte sequence)' non UTF-8 Windows
      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

-- | Extract the test names from discovered modules.
extractTests :: FilePath -> String -> [Test]
extractTests :: String -> String -> [Test]
extractTests 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

-- | Show the imports.
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

-- | Retrieve the ingredient name.
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 to be included.
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"]

-- | Show the tests.
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
    -- special case, collapse to mdl.submdl
    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)