{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Tasty.AutoCollect.GenerateMain (
generateMainModule,
) where
import Control.Monad (guard)
import Data.ByteString qualified as ByteString
import Data.Char (isDigit, isLower, isUpper)
import Data.List (sortOn)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified 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 Test.Tasty.AutoCollect.Utils.TreeMap qualified as TreeMap
generateMainModule :: AutoCollectConfig -> FilePath -> Text -> IO Text
generateMainModule :: AutoCollectConfig -> FilePath -> Text -> IO Text
generateMainModule AutoCollectConfig
cfg FilePath
path Text
originalMain = do
[TestModule]
testModules <- (TestModule -> Text) -> [TestModule] -> [TestModule]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn TestModule -> Text
displayName ([TestModule] -> [TestModule])
-> IO [TestModule] -> IO [TestModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AutoCollectConfig -> FilePath -> IO [TestModule]
findTestModules AutoCollectConfig
cfg FilePath
path
let importLines :: [Text]
importLines = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"import qualified " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (TestModule -> Text) -> [TestModule] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TestModule -> Text
moduleName [TestModule]
testModules
tests :: Text
tests = AutoCollectConfig -> [TestModule] -> Text
generateTests AutoCollectConfig
cfg [TestModule]
testModules
Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$
if AutoCollectConfig -> Apply Identity Bool
forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgCustomMain AutoCollectConfig
cfg
then [Text] -> Text -> Text -> Text
rewriteMain [Text]
importLines Text
tests Text
originalMain
else AutoCollectConfig -> FilePath -> [Text] -> Text -> Text
mkMainModule AutoCollectConfig
cfg FilePath
path [Text]
importLines Text
tests
rewriteMain :: [Text] -> Text -> Text -> Text
rewriteMain :: [Text] -> Text -> Text -> Text
rewriteMain [Text]
importLines Text
tests =
HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{- AUTOCOLLECT.MAIN.imports -}" ([Text] -> Text
Text.unlines [Text]
importLines)
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{- AUTOCOLLECT.MAIN.tests -}" Text
tests
mkMainModule :: AutoCollectConfig -> FilePath -> [Text] -> Text -> Text
mkMainModule :: AutoCollectConfig -> FilePath -> [Text] -> Text -> Text
mkMainModule AutoCollectConfig{Apply Identity Bool
Apply Identity [FilePath]
Apply Identity [Text]
Apply Identity (Maybe Text)
Apply Identity Text
Apply Identity AutoCollectGroupType
cfgCustomMain :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgImports :: Apply Identity [FilePath]
cfgSuiteName :: Apply Identity (Maybe Text)
cfgGroupType :: Apply Identity AutoCollectGroupType
cfgStripSuffix :: Apply Identity Text
cfgIngredients :: Apply Identity [Text]
cfgIngredientsOverride :: Apply Identity Bool
cfgCustomMain :: Apply Identity Bool
cfgImports :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [FilePath]
cfgSuiteName :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f (Maybe Text)
cfgGroupType :: forall (f :: * -> *).
AutoCollectConfig' f -> Apply f AutoCollectGroupType
cfgStripSuffix :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgIngredients :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [Text]
cfgIngredientsOverride :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
..} FilePath
path [Text]
importLines Text
tests =
[Text] -> Text
Text.unlines
[ Text
"{-# OPTIONS_GHC -w #-}"
, Text
""
, Text
"module Main (main) where"
, Text
""
, Text
"import Test.Tasty"
, [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
importLines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"import qualified " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
ingredientsModules
, Text
""
, Text
"main :: IO ()"
, Text
"main = defaultMainWithIngredients ingredients (testGroup suiteName tests)"
, Text
" where"
, Text
" ingredients = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ingredients
, Text
" suiteName = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suiteName
, Text
" tests = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tests
]
where
ingredients :: Text
ingredients =
[Text] -> Text
Text.unwords
[ [Text] -> Text
listify [Text]
Apply Identity [Text]
cfgIngredients
, Text
"++"
, if Bool
Apply Identity Bool
cfgIngredientsOverride then Text
"[]" else Text
"defaultIngredients"
]
ingredientsModules :: [Text]
ingredientsModules =
((Text -> Text) -> [Text] -> [Text])
-> [Text] -> (Text -> Text) -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Text]
Apply Identity [Text]
cfgIngredients ((Text -> Text) -> [Text]) -> (Text -> Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ \Text
ingredient ->
case (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." Text
ingredient of
Text
"" -> FilePath -> Text
forall a. FilePath -> a
autocollectError (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Ingredient needs to be fully qualified: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
ingredient
Text
s -> HasCallStack => Text -> Text
Text -> Text
Text.init Text
s
suiteName :: Text
suiteName = Text -> Text
quoted (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Text
Text.pack FilePath
path) Maybe Text
Apply Identity (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 IO [FilePath] -> ([FilePath] -> IO [TestModule]) -> IO [TestModule]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO (Maybe TestModule))
-> [FilePath] -> IO [TestModule]
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
Maybe TestModule -> IO (Maybe TestModule)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TestModule -> IO (Maybe TestModule))
-> Maybe TestModule -> IO (Maybe TestModule)
forall a b. (a -> b) -> a -> b
$
case FilePath -> (FilePath, FilePath)
splitExtensions FilePath
fp of
(FilePath
fpNoExt, FilePath
".hs")
| Right (Just ModuleType
ModuleTest) <- Text -> Maybe ModuleType
parseModuleType (Text -> Maybe ModuleType)
-> Either UnicodeException Text
-> Either UnicodeException (Maybe ModuleType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
fileContentsBS
, Just Text
moduleName <- Text -> Maybe Text
toModuleName (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack (FilePath -> FilePath -> FilePath
makeRelative FilePath
testDir FilePath
fpNoExt) ->
TestModule -> Maybe TestModule
forall a. a -> Maybe a
Just
TestModule
{ Text
moduleName :: Text
moduleName :: Text
moduleName
, displayName :: Text
displayName = Text -> Text -> Text
withoutSuffix (AutoCollectConfig -> Apply Identity Text
forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgStripSuffix AutoCollectConfig
cfg) Text
moduleName
}
(FilePath, FilePath)
_ -> Maybe TestModule
forall a. Maybe a
Nothing
toModuleName :: Text -> Maybe Text
toModuleName = ([Text] -> Text) -> Maybe [Text] -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
".") (Maybe [Text] -> Maybe Text)
-> (Text -> Maybe [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text) -> [Text] -> Maybe [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Maybe Text
validateModuleName ([Text] -> Maybe [Text])
-> (Text -> [Text]) -> Text -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"/"
validateModuleName :: Text -> Maybe Text
validateModuleName Text
name = do
(Char
first, Text
rest) <- Text -> Maybe (Char, Text)
Text.uncons Text
name
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper Char
first
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
Text.all (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'') Text
rest
Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
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 = ([Maybe b] -> [b]) -> m [Maybe b] -> m [b]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe b] -> m [b]) -> ([a] -> m [Maybe b]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Maybe b)) -> [a] -> m [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m (Maybe b)
f
generateTests :: AutoCollectConfig -> [TestModule] -> Text
generateTests :: AutoCollectConfig -> [TestModule] -> Text
generateTests AutoCollectConfig{Apply Identity Bool
Apply Identity [FilePath]
Apply Identity [Text]
Apply Identity (Maybe Text)
Apply Identity Text
Apply Identity AutoCollectGroupType
cfgCustomMain :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgImports :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [FilePath]
cfgSuiteName :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f (Maybe Text)
cfgGroupType :: forall (f :: * -> *).
AutoCollectConfig' f -> Apply f AutoCollectGroupType
cfgStripSuffix :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgIngredients :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [Text]
cfgIngredientsOverride :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgImports :: Apply Identity [FilePath]
cfgSuiteName :: Apply Identity (Maybe Text)
cfgGroupType :: Apply Identity AutoCollectGroupType
cfgStripSuffix :: Apply Identity Text
cfgIngredients :: Apply Identity [Text]
cfgIngredientsOverride :: Apply Identity Bool
cfgCustomMain :: Apply Identity Bool
..} [TestModule]
testModules =
case Apply Identity AutoCollectGroupType
cfgGroupType of
AutoCollectGroupType
Apply Identity AutoCollectGroupType
AutoCollectGroupFlat ->
Text
"concat " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
listify ((TestModule -> Text) -> [TestModule] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
addTestList (Text -> Text) -> (TestModule -> Text) -> TestModule -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestModule -> Text
moduleName) [TestModule]
testModules)
AutoCollectGroupType
Apply Identity AutoCollectGroupType
AutoCollectGroupModules ->
[Text] -> Text
listify ([Text] -> Text)
-> ((TestModule -> Text) -> [Text]) -> (TestModule -> Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestModule -> Text) -> [TestModule] -> [Text])
-> [TestModule] -> (TestModule -> Text) -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TestModule -> Text) -> [TestModule] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [TestModule]
testModules ((TestModule -> Text) -> Text) -> (TestModule -> Text) -> Text
forall a b. (a -> b) -> a -> b
$ \TestModule{Text
displayName :: TestModule -> Text
moduleName :: TestModule -> Text
moduleName :: Text
displayName :: Text
..} ->
[Text] -> Text
Text.unwords [Text
"testGroup", Text -> Text
quoted Text
displayName, Text -> Text
addTestList Text
moduleName]
AutoCollectGroupType
Apply Identity AutoCollectGroupType
AutoCollectGroupTree ->
let getInfo :: TestModule -> ([Text], Text)
getInfo TestModule{Text
displayName :: TestModule -> Text
moduleName :: TestModule -> Text
moduleName :: Text
displayName :: Text
..} = (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"." Text
displayName, Text -> Text
addTestList Text
moduleName)
in (Maybe Text -> Map Text Text -> Text) -> TreeMap Text Text -> Text
forall v k r. (Maybe v -> Map k r -> r) -> TreeMap k v -> r
TreeMap.foldTreeMap Maybe Text -> Map Text Text -> Text
testGroupFromTree (TreeMap Text Text -> Text)
-> ([TestModule] -> TreeMap Text Text) -> [TestModule] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Text], Text)] -> TreeMap Text Text
forall k v. Ord k => [([k], v)] -> TreeMap k v
TreeMap.fromList ([([Text], Text)] -> TreeMap Text Text)
-> ([TestModule] -> [([Text], Text)])
-> [TestModule]
-> TreeMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestModule -> ([Text], Text)) -> [TestModule] -> [([Text], Text)]
forall a b. (a -> b) -> [a] -> [b]
map TestModule -> ([Text], Text)
getInfo ([TestModule] -> Text) -> [TestModule] -> Text
forall a b. (a -> b) -> a -> b
$ [TestModule]
testModules
where
addTestList :: Text -> Text
addTestList Text
moduleName = Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> 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 =
(((Text, Text) -> Text) -> [(Text, Text)] -> [Text])
-> [(Text, Text)] -> ((Text, Text) -> Text) -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text Text
subTrees) (((Text, Text) -> Text) -> [Text])
-> ((Text, Text) -> Text) -> [Text]
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 " Text -> Text -> Text
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 = ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[FilePath]] -> IO [FilePath])
-> ([FilePath] -> IO [[FilePath]]) -> [FilePath] -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> IO [FilePath]
go (FilePath -> IO [FilePath])
-> (FilePath -> FilePath) -> FilePath -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
fp FilePath -> FilePath -> FilePath
</>)) ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [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 [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
child]