{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Tasty.AutoCollect.GenerateMain (
generateMainModule,
) where
import qualified Data.ByteString as ByteString
import Data.List (sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import System.Directory (doesDirectoryExist, listDirectory)
import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>))
import Test.Tasty.AutoCollect.Config
import Test.Tasty.AutoCollect.Constants
import Test.Tasty.AutoCollect.Error
import Test.Tasty.AutoCollect.ModuleType
import Test.Tasty.AutoCollect.Utils.Text
import qualified Test.Tasty.AutoCollect.Utils.TreeMap as TreeMap
generateMainModule :: AutoCollectConfig -> FilePath -> IO Text
generateMainModule :: AutoCollectConfig -> FilePath -> IO Text
generateMainModule cfg :: AutoCollectConfig
cfg@AutoCollectConfig{Bool
[Text]
Maybe Text
Text
AutoCollectGroupType
cfgIngredientsOverride :: AutoCollectConfig -> Bool
cfgIngredients :: AutoCollectConfig -> [Text]
cfgStripSuffix :: AutoCollectConfig -> Text
cfgGroupType :: AutoCollectConfig -> AutoCollectGroupType
cfgSuiteName :: AutoCollectConfig -> Maybe Text
cfgIngredientsOverride :: Bool
cfgIngredients :: [Text]
cfgStripSuffix :: Text
cfgGroupType :: AutoCollectGroupType
cfgSuiteName :: Maybe Text
..} FilePath
path = do
[TestModule]
testModules <- forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn TestModule -> Text
displayName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AutoCollectConfig -> FilePath -> IO [TestModule]
findTestModules AutoCollectConfig
cfg FilePath
path
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
[ Text
"{-# OPTIONS_GHC -w #-}"
, Text
""
, Text
"module Main (main) where"
, Text
""
, Text
"import Test.Tasty"
, [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text
"import qualified " forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TestModule -> Text
moduleName [TestModule]
testModules forall a. [a] -> [a] -> [a]
++ [Text]
ingredientsModules
, Text
""
, Text
"main :: IO ()"
, Text
"main = defaultMainWithIngredients ingredients (testGroup suiteName tests)"
, Text
" where"
, Text
" ingredients = " forall a. Semigroup a => a -> a -> a
<> Text
ingredients
, Text
" suiteName = " forall a. Semigroup a => a -> a -> a
<> Text
suiteName
, Text
" tests = " forall a. Semigroup a => a -> a -> a
<> AutoCollectConfig -> [TestModule] -> Text
generateTests AutoCollectConfig
cfg [TestModule]
testModules
]
where
ingredients :: Text
ingredients =
[Text] -> Text
Text.unwords
[ [Text] -> Text
listify [Text]
cfgIngredients
, Text
"++"
, if Bool
cfgIngredientsOverride then Text
"[]" else Text
"defaultIngredients"
]
ingredientsModules :: [Text]
ingredientsModules =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Text]
cfgIngredients forall a b. (a -> b) -> a -> b
$ \Text
ingredient ->
case forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." Text
ingredient of
Text
"" -> forall a. FilePath -> a
autocollectError forall a b. (a -> b) -> a -> b
$ FilePath
"Ingredient needs to be fully qualified: " forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
ingredient
Text
s -> Text -> Text
Text.init Text
s
suiteName :: Text
suiteName = Text -> Text
quoted forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Text
Text.pack FilePath
path) Maybe Text
cfgSuiteName
data TestModule = TestModule
{ TestModule -> Text
moduleName :: Text
, TestModule -> Text
displayName :: Text
}
findTestModules :: AutoCollectConfig -> FilePath -> IO [TestModule]
findTestModules :: AutoCollectConfig -> FilePath -> IO [TestModule]
findTestModules AutoCollectConfig
cfg FilePath
path = FilePath -> IO [FilePath]
listDirectoryRecursive FilePath
testDir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM FilePath -> IO (Maybe TestModule)
toTestModule
where
testDir :: FilePath
testDir = FilePath -> FilePath
takeDirectory FilePath
path
toTestModule :: FilePath -> IO (Maybe TestModule)
toTestModule FilePath
fp = do
ByteString
fileContentsBS <- FilePath -> IO ByteString
ByteString.readFile FilePath
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case (FilePath -> (FilePath, FilePath)
splitExtensions FilePath
fp, Text -> Maybe ModuleType
parseModuleType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
fileContentsBS) of
((FilePath
fpNoExt, FilePath
".hs"), Right (Just ModuleType
ModuleTest)) ->
let moduleName :: Text
moduleName = Text -> Text -> Text -> Text
Text.replace Text
"/" Text
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
makeRelative FilePath
testDir forall a b. (a -> b) -> a -> b
$ FilePath
fpNoExt
in forall a. a -> Maybe a
Just
TestModule
{ Text
moduleName :: Text
moduleName :: Text
moduleName
, displayName :: Text
displayName = Text -> Text -> Text
withoutSuffix (AutoCollectConfig -> Text
cfgStripSuffix AutoCollectConfig
cfg) Text
moduleName
}
((FilePath, FilePath), Either UnicodeException (Maybe ModuleType))
_ -> forall a. Maybe a
Nothing
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m (Maybe b)
f
generateTests :: AutoCollectConfig -> [TestModule] -> Text
generateTests :: AutoCollectConfig -> [TestModule] -> Text
generateTests AutoCollectConfig{Bool
[Text]
Maybe Text
Text
AutoCollectGroupType
cfgIngredientsOverride :: Bool
cfgIngredients :: [Text]
cfgStripSuffix :: Text
cfgGroupType :: AutoCollectGroupType
cfgSuiteName :: Maybe Text
cfgIngredientsOverride :: AutoCollectConfig -> Bool
cfgIngredients :: AutoCollectConfig -> [Text]
cfgStripSuffix :: AutoCollectConfig -> Text
cfgGroupType :: AutoCollectConfig -> AutoCollectGroupType
cfgSuiteName :: AutoCollectConfig -> Maybe Text
..} [TestModule]
testModules =
case AutoCollectGroupType
cfgGroupType of
AutoCollectGroupType
AutoCollectGroupFlat ->
Text
"concat " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
listify (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
addTestList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestModule -> Text
moduleName) [TestModule]
testModules)
AutoCollectGroupType
AutoCollectGroupModules ->
[Text] -> Text
listify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [TestModule]
testModules forall a b. (a -> b) -> a -> b
$ \TestModule{Text
displayName :: Text
moduleName :: Text
moduleName :: TestModule -> Text
displayName :: TestModule -> Text
..} ->
[Text] -> Text
Text.unwords [Text
"testGroup", Text -> Text
quoted Text
displayName, Text -> Text
addTestList Text
moduleName]
AutoCollectGroupType
AutoCollectGroupTree ->
let getInfo :: TestModule -> ([Text], Text)
getInfo TestModule{Text
displayName :: Text
moduleName :: Text
moduleName :: TestModule -> Text
displayName :: TestModule -> Text
..} = (Text -> Text -> [Text]
Text.splitOn Text
"." Text
displayName, Text -> Text
addTestList Text
moduleName)
in forall v k r. (Maybe v -> Map k r -> r) -> TreeMap k v -> r
TreeMap.foldTreeMap Maybe Text -> Map Text Text -> Text
testGroupFromTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [([k], v)] -> TreeMap k v
TreeMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TestModule -> ([Text], Text)
getInfo forall a b. (a -> b) -> a -> b
$ [TestModule]
testModules
where
addTestList :: Text -> Text
addTestList Text
moduleName = Text
moduleName forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
testListIdentifier
testGroupFromTree :: Maybe Text -> Map Text Text -> Text
testGroupFromTree Maybe Text
mTestsIdentifier Map Text Text
subTrees =
let subGroups :: [Text]
subGroups =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text Text
subTrees) forall a b. (a -> b) -> a -> b
$ \(Text
testModuleDisplay, Text
subTests) ->
[Text] -> Text
Text.unwords [Text
"testGroup", Text -> Text
quoted Text
testModuleDisplay, Text
"$", Text
subTests]
in case ([Text]
subGroups, Maybe Text
mTestsIdentifier) of
([Text]
subGroups', Maybe Text
Nothing) -> [Text] -> Text
listify [Text]
subGroups'
([], Just Text
testsIdentifier) -> Text
testsIdentifier
([Text]
subGroups', Just Text
testsIdentifier) -> Text
"concat " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
listify [Text
testsIdentifier, [Text] -> Text
listify [Text]
subGroups']
listDirectoryRecursive :: FilePath -> IO [FilePath]
listDirectoryRecursive :: FilePath -> IO [FilePath]
listDirectoryRecursive FilePath
fp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IO [FilePath]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
fp FilePath -> FilePath -> FilePath
</>)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
listDirectory FilePath
fp
where
go :: FilePath -> IO [FilePath]
go FilePath
child = do
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
child
if Bool
isDir
then FilePath -> IO [FilePath]
listDirectoryRecursive FilePath
child
else forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
child]