{-# 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 :: [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"
  ]

-- | 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 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"
    ]

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

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

-- | Discover the tests modules.
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)
      -- The files to scan need to be sorted or otherwise the output of
      -- findTests might not be deterministic
      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)
          -- Avoid internal error: hGetContents: invalid argument (invalid byte sequence)' non UTF-8 Windows
            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

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

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

-- | 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
/= Char
'.')

-- | Ingredients to be included.
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"]

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