Merge pull request #5761 from m-renaud/init-tests

Add support for generating test-suite.

cabal-install/Distribution/Client/Config.hs

@@ -258,34 +258,36 @@ instance Semigroup SavedConfig where
           lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags
 
       combinedSavedInitFlags = IT.InitFlags {
-        IT.author         = combine IT.author,
-        IT.buildTools     = combineMonoid savedInitFlags IT.buildTools,
-        IT.cabalVersion   = combine IT.cabalVersion,
-        IT.category       = combine IT.category,
-        IT.dependencies   = combineMonoid savedInitFlags IT.dependencies,
-        IT.email          = combine IT.email,
-        IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules,
-        IT.extraSrc       = combineMonoid savedInitFlags IT.extraSrc,
-        IT.homepage       = combine IT.homepage,
-        IT.initHcPath     = combine IT.initHcPath,
-        IT.initVerbosity  = combine IT.initVerbosity,
-        IT.language       = combine IT.language,
-        IT.license        = combine IT.license,
-        IT.mainIs         = combine IT.mainIs,
-        IT.minimal        = combine IT.minimal,
-        IT.noComments     = combine IT.noComments,
-        IT.nonInteractive = combine IT.nonInteractive,
-        IT.otherExts      = combineMonoid savedInitFlags IT.otherExts,
-        IT.otherModules   = combineMonoid savedInitFlags IT.otherModules,
-        IT.overwrite      = combine IT.overwrite,
-        IT.packageDir     = combine IT.packageDir,
-        IT.packageName    = combine IT.packageName,
-        IT.packageType    = combine IT.packageType,
-        IT.quiet          = combine IT.quiet,
-        IT.simpleProject  = combine IT.simpleProject,
-        IT.sourceDirs     = combineMonoid savedInitFlags IT.sourceDirs,
-        IT.synopsis       = combine IT.synopsis,
-        IT.version        = combine IT.version
+        IT.author              = combine IT.author,
+        IT.buildTools          = combineMonoid savedInitFlags IT.buildTools,
+        IT.cabalVersion        = combine IT.cabalVersion,
+        IT.category            = combine IT.category,
+        IT.dependencies        = combineMonoid savedInitFlags IT.dependencies,
+        IT.email               = combine IT.email,
+        IT.exposedModules      = combineMonoid savedInitFlags IT.exposedModules,
+        IT.extraSrc            = combineMonoid savedInitFlags IT.extraSrc,
+        IT.homepage            = combine IT.homepage,
+        IT.initHcPath          = combine IT.initHcPath,
+        IT.initVerbosity       = combine IT.initVerbosity,
+        IT.initializeTestSuite = combine IT.initializeTestSuite,
+        IT.language            = combine IT.language,
+        IT.license             = combine IT.license,
+        IT.mainIs              = combine IT.mainIs,
+        IT.minimal             = combine IT.minimal,
+        IT.noComments          = combine IT.noComments,
+        IT.nonInteractive      = combine IT.nonInteractive,
+        IT.otherExts           = combineMonoid savedInitFlags IT.otherExts,
+        IT.otherModules        = combineMonoid savedInitFlags IT.otherModules,
+        IT.overwrite           = combine IT.overwrite,
+        IT.packageDir          = combine IT.packageDir,
+        IT.packageName         = combine IT.packageName,
+        IT.packageType         = combine IT.packageType,
+        IT.quiet               = combine IT.quiet,
+        IT.simpleProject       = combine IT.simpleProject,
+        IT.sourceDirs          = combineMonoid savedInitFlags IT.sourceDirs,
+        IT.synopsis            = combine IT.synopsis,
+        IT.testDirs            = combineMonoid savedInitFlags IT.testDirs,
+        IT.version             = combine IT.version
         }
         where
           combine = combine' savedInitFlags

cabal-install/Distribution/Client/Init.hs

@@ -129,8 +129,13 @@ initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do
     _                 -> writeLicense initFlags'
   writeSetupFile initFlags'
   writeChangeLog initFlags'
-  createSourceDirectories initFlags'
+  createDirectories (sourceDirs initFlags')
   createMainHs initFlags'
+  -- If a test suite was requested and this is not an executable-only
+  -- package, then create the "test" directory.
+  when (eligibleForTestSuite initFlags') $ do
+    createDirectories (testDirs initFlags')
+    createTestHs initFlags'
   success <- writeCabalFile initFlags'
 
   when success $ generateWarnings initFlags'
@@ -155,6 +160,8 @@ extendFlags pkgIx sourcePkgDb =
   >=> getCategory
   >=> getExtraSourceFiles
   >=> getSrcDir
+  >=> getGenTests
+  >=> getTestDir
   >=> getLanguage
   >=> getGenComments
   >=> getModulesBuildToolsAndDeps pkgIx
@@ -411,6 +418,30 @@ getMainFile flags =
                        defaultFile showCandidate True)
       ?>> return (fmap (either id id) defaultFile)
 
+-- | Ask if a test suite should be generated for the library.
+getGenTests :: InitFlags -> IO InitFlags
+getGenTests flags = do
+  genTests <-     return (flagToMaybe $ initializeTestSuite flags)
+                  -- Only generate a test suite if the package contains a library.
+              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing
+              ?>> maybePrompt flags
+                  (promptYesNo
+                    "Should I generate a test suite for the library"
+                    (Just True))
+  return $ flags { initializeTestSuite = maybeToFlag genTests }
+
+-- | Ask for the test root directory.
+getTestDir :: InitFlags -> IO InitFlags
+getTestDir flags = do
+  dirs <- return (testDirs flags)
+              -- Only need testDirs when test suite generation is enabled.
+          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing
+          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt
+                   flags
+                   (promptList "Test directory" ["test"] (Just "test") id True))
+
+  return $ flags { testDirs = dirs }
+
 -- | Ask for the base language of the package.
 getLanguage :: InitFlags -> IO InitFlags
 getLanguage flags = do
@@ -588,6 +619,12 @@ incVersion n = alterVersion (incVersion' n)
     incVersion' m []     = replicate m 0 ++ [1]
     incVersion' m (v:vs) = v : incVersion' (m-1) vs
 
+-- | Returns true if this package is eligible for test suite initialization.
+eligibleForTestSuite :: InitFlags -> Bool
+eligibleForTestSuite flags =
+  Flag True == initializeTestSuite flags
+  && Flag Executable /= packageType flags
+
 ---------------------------------------------------------------------------
 --  Prompting/user interaction  -------------------------------------------
 ---------------------------------------------------------------------------
@@ -805,11 +842,11 @@ writeFileSafe flags fileName content = do
   moveExistingFile flags fileName
   writeFile fileName content
 
--- | Create source directories, if they were given.
-createSourceDirectories :: InitFlags -> IO ()
-createSourceDirectories flags = case sourceDirs flags of
-                                  Just dirs -> forM_ dirs (createDirectoryIfMissing True)
-                                  Nothing   -> return ()
+-- | Create directories, if they were given, and don't already exist.
+createDirectories :: Maybe [String] -> IO ()
+createDirectories mdirs = case mdirs of
+  Just dirs -> forM_ dirs (createDirectoryIfMissing True)
+  Nothing   -> return ()
 
 -- | Create Main.hs, but only if we are init'ing an executable and
 --   the mainIs flag has been provided.
@@ -858,6 +895,38 @@ mainHs flags = (unlines . map prependPrefix)
       _             -> False
 
 
+testFile :: String
+testFile = "MyLibTest.hs"
+
+-- | Create MyLibTest.hs, but only if we are init'ing a library and
+--   the initializeTestSuite flag has been set.
+createTestHs :: InitFlags -> IO ()
+createTestHs flags =
+  when (eligibleForTestSuite flags) $
+    case testDirs flags of
+      Just (testPath:_) -> writeTestHs flags (testPath </> testFile)
+      _ -> writeMainHs flags testFile
+
+--- | Write a test file.
+writeTestHs :: InitFlags -> FilePath -> IO ()
+writeTestHs flags testPath = do
+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
+  let testFullPath = dir </> testPath
+  exists <- doesFileExist testFullPath
+  unless exists $ do
+      message flags $ "Generating " ++ testPath ++ "..."
+      writeFileSafe flags testFullPath testHs
+
+-- | Default MyLibTest.hs file.
+testHs :: String
+testHs = unlines
+  [ "module Main (main) where"
+  , ""
+  , "main :: IO ()"
+  , "main = putStrLn \"Test suite not yet implemented.\""
+  ]
+
+
 -- | Move an existing file, if there is one, and the overwrite flag is
 --   not set.
 moveExistingFile :: InitFlags -> FilePath -> IO ()
@@ -972,6 +1041,8 @@ generateCabalFile fileName c = trimTrailingWS $
            Flag Library    -> libraryStanza
            Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza
            _               -> empty
+
+       , if eligibleForTestSuite c then testSuiteStanza else empty
        ]
  where
    specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)
@@ -1079,6 +1150,30 @@ generateCabalFile fileName c = trimTrailingWS $
              , generateBuildInfo LibBuild c
              ])
 
+   testSuiteStanza :: Doc
+   testSuiteStanza = text "\ntest-suite" <+>
+     text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$
+     nest 2 (vcat
+             [ field  "default-language" (language c)
+               (Just "Base language which the package is written in.")
+               True
+
+             , fieldS "type" (Flag "exitcode-stdio-1.0")
+               (Just "The interface type and version of the test suite.")
+               True
+
+             , fieldS "hs-source-dirs" (listFieldS (testDirs c))
+               (Just "The directory where the test specifications are found.")
+               True
+
+             , fieldS "main-is" (Flag testFile)
+               (Just "The entrypoint to the test suite.")
+               True
+
+             , fieldS "build-depends" (listField (dependencies c))
+               (Just "Test dependencies.")
+               True
+             ])
 
 -- | Generate warnings for missing fields etc.
 generateWarnings :: InitFlags -> IO ()

cabal-install/Distribution/Client/Init/Types.hs

@@ -70,6 +70,9 @@ data InitFlags =
               , sourceDirs   :: Maybe [String]
               , buildTools   :: Maybe [String]
 
+              , initializeTestSuite :: Flag Bool
+              , testDirs            :: Maybe [String]
+
               , initHcPath    :: Flag FilePath
 
               , initVerbosity :: Flag Verbosity

cabal-install/Distribution/Client/Setup.hs

@@ -2313,6 +2313,18 @@ initOptions _ =
     (\v flags -> flags { IT.packageType = v })
     (noArg (Flag IT.LibraryAndExecutable))
 
+      , option [] ["tests"]
+        "Generate a test suite for the library."
+        IT.initializeTestSuite
+        (\v flags -> flags { IT.initializeTestSuite = v })
+        trueArg
+
+      , option [] ["test-dir"]
+        "Directory containing tests."
+        IT.testDirs (\v flags -> flags { IT.testDirs = v })
+        (reqArg' "DIR" (Just . (:[]))
+                       (fromMaybe []))
+
   , option [] ["simple"]
     "Create a simple project with sensible defaults."
     IT.simpleProject

cabal-install/changelog

@@ -15,6 +15,7 @@
 	* v2-test now succeeds when there are no test suites. (#5435)
 	* Add '--lib', '--exe', and '--libandexe' shorthands to init. (#5759)
 	* init now generates valid `Main.lhs` files. (#5577)
+	* Add support for generating test-suite via cabal init. (#5761)
 
 2.4.1.0 Mikhail Glushenkov <[email protected]> November 2018
 	* Add message to alert user to potential package casing errors. (#5635)