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

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

import Control.Monad (guard)
import qualified Data.ByteString as ByteString
import Data.Char (isDigit, isLower, isUpper)
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 -> Text -> IO Text
generateMainModule :: AutoCollectConfig -> FilePath -> Text -> IO Text
generateMainModule AutoCollectConfig
cfg FilePath
path Text
originalMain = 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
  let importLines :: [Text]
importLines = 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
      tests :: Text
tests = AutoCollectConfig -> [TestModule] -> Text
generateTests AutoCollectConfig
cfg [TestModule]
testModules
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    if 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 =
  Text -> Text -> Text -> Text
Text.replace Text
"{- AUTOCOLLECT.MAIN.imports -}" ([Text] -> Text
Text.unlines [Text]
importLines)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
cfgIngredientsOverride :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgIngredients :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [Text]
cfgStripSuffix :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgGroupType :: forall (f :: * -> *).
AutoCollectConfig' f -> Apply f AutoCollectGroupType
cfgSuiteName :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f (Maybe Text)
cfgImports :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [FilePath]
cfgCustomMain :: Apply Identity Bool
cfgIngredientsOverride :: Apply Identity Bool
cfgIngredients :: Apply Identity [Text]
cfgStripSuffix :: Apply Identity Text
cfgGroupType :: Apply Identity AutoCollectGroupType
cfgSuiteName :: Apply Identity (Maybe Text)
cfgImports :: Apply Identity [FilePath]
cfgCustomMain :: 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 forall a b. (a -> b) -> a -> b
$ [Text]
importLines forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Text
"import qualified " forall a. Semigroup 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
<> Text
tests
    ]
  where
    ingredients :: Text
ingredients =
      [Text] -> Text
Text.unwords
        [ [Text] -> Text
listify Apply Identity [Text]
cfgIngredients
        , Text
"++"
        , if Apply Identity 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 Apply Identity [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
          -- remove trailing "."
          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) Apply Identity (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 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 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 forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack (FilePath -> FilePath -> FilePath
makeRelative FilePath
testDir FilePath
fpNoExt) ->
                forall a. a -> Maybe a
Just
                  TestModule
                    { Text
moduleName :: Text
moduleName :: Text
moduleName
                    , displayName :: Text
displayName = Text -> Text -> Text
withoutSuffix (forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgStripSuffix AutoCollectConfig
cfg) Text
moduleName
                    }
          (FilePath, FilePath)
_ -> forall a. Maybe a
Nothing

    toModuleName :: Text -> Maybe Text
toModuleName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
".") 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 Text -> Maybe Text
validateModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Text.splitOn Text
"/"
    -- https://www.haskell.org/onlinereport/syntax-iso.html
    -- large { small | large | digit | ' }
    validateModuleName :: Text -> Maybe Text
validateModuleName Text
name = do
      (Char
first, Text
rest) <- Text -> Maybe (Char, Text)
Text.uncons Text
name
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper Char
first
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard 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 forall a. Eq a => a -> a -> Bool
== Char
'\'') Text
rest
      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 = 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{Apply Identity Bool
Apply Identity [FilePath]
Apply Identity [Text]
Apply Identity (Maybe Text)
Apply Identity Text
Apply Identity AutoCollectGroupType
cfgCustomMain :: Apply Identity Bool
cfgIngredientsOverride :: Apply Identity Bool
cfgIngredients :: Apply Identity [Text]
cfgStripSuffix :: Apply Identity Text
cfgGroupType :: Apply Identity AutoCollectGroupType
cfgSuiteName :: Apply Identity (Maybe Text)
cfgImports :: Apply Identity [FilePath]
cfgIngredientsOverride :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
cfgIngredients :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [Text]
cfgStripSuffix :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Text
cfgGroupType :: forall (f :: * -> *).
AutoCollectConfig' f -> Apply f AutoCollectGroupType
cfgSuiteName :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f (Maybe Text)
cfgImports :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f [FilePath]
cfgCustomMain :: forall (f :: * -> *). AutoCollectConfig' f -> Apply f Bool
..} [TestModule]
testModules =
  case Apply Identity AutoCollectGroupType
cfgGroupType of
    AutoCollectGroupType
Apply Identity AutoCollectGroupType
AutoCollectGroupFlat ->
      -- concat
      --   [ My.Module.Test1.tests
      --   , My.Module.Test2.tests
      --   , ...
      --   ]
      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
Apply Identity AutoCollectGroupType
AutoCollectGroupModules ->
      -- [ testGroup "My.Module.Test1" My.Module.Test1.tests
      -- , testGroup "My.Module.Test2" My.Module.Test2.tests
      -- ]
      [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
Apply Identity 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 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']

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

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]