{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Test.Tasty.AutoCollect.GenerateMain (
  generateMainModule,
) where

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.IO 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 <- (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
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> ([Text] -> Text) -> [Text] -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> IO Text) -> [Text] -> IO Text
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 ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 [Text] -> [Text] -> [Text]
forall 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
<> 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 =
      ((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]
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
$ 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
          -- remove trailing "."
          Text
s -> 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
cfgSuiteName

data TestModule = TestModule
  { TestModule -> Text
moduleName :: Text
  -- ^ e.g. "My.Module.Test1"
  , TestModule -> Text
displayName :: Text
  -- ^ The module name to display
  }

{- |
Find all test modules using the given path to the Main module.

>>> findTestModules "test/Main.hs"
["My.Module.Test1", "My.Module.Test2", ...]
-}
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 (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
      Text
fileContents <- FilePath -> IO Text
Text.readFile FilePath
fp
      Maybe TestModule -> IO (Maybe TestModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestModule -> IO (Maybe TestModule))
-> Maybe TestModule -> IO (Maybe TestModule)
forall a b. (a -> b) -> a -> b
$
        case (FilePath -> (FilePath, FilePath)
splitExtensions FilePath
fp, Text -> Maybe ModuleType
parseModuleType Text
fileContents) of
          ((FilePath
fpNoExt, FilePath
".hs"), Just ModuleType
ModuleTest) ->
            let moduleName :: Text
moduleName = Text -> Text -> Text -> Text
Text.replace Text
"/" Text
"." (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
makeRelative FilePath
testDir (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
fpNoExt
             in TestModule -> Maybe TestModule
forall a. a -> Maybe a
Just
                  TestModule :: Text -> Text -> TestModule
TestModule
                    { Text
moduleName :: Text
moduleName :: Text
moduleName
                    , displayName :: Text
displayName = Text -> Text -> Text
withoutSuffix (AutoCollectConfig -> Text
cfgStripSuffix AutoCollectConfig
cfg) Text
moduleName
                    }
          ((FilePath, FilePath), Maybe ModuleType)
_ -> Maybe TestModule
forall a. Maybe a
Nothing

    mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
    mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f = ([Maybe b] -> [b]) -> m [Maybe b] -> 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)
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 ->
      -- concat
      --   [ My.Module.Test1.tests
      --   , My.Module.Test2.tests
      --   , ...
      --   ]
      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
AutoCollectGroupModules ->
      -- [ testGroup "My.Module.Test1" My.Module.Test1.tests
      -- , testGroup "My.Module.Test2" My.Module.Test2.tests
      -- ]
      [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 :: 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 ->
      -- [ testGroup "My"
      --     [ testGroup "Module"
      --         [ testGroup "Test1" My.Module.Test1.tests
      --         , testGroup "Test2" My.Module.Test2.tests
      --         ]
      --     ]
      -- ]
      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 (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']

{----- Helpers -----}

listDirectoryRecursive :: FilePath -> IO [FilePath]
listDirectoryRecursive :: FilePath -> IO [FilePath]
listDirectoryRecursive FilePath
fp = ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
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)
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 (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
child]