Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add support for generating test-suite. #5761

Merged
merged 3 commits into from
Jan 25, 2019
Merged
Show file tree
Hide file tree
Changes from 2 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
58 changes: 30 additions & 28 deletions cabal-install/Distribution/Client/Config.hs
Original file line number Diff line number Diff line change
Expand Up @@ -252,34 +252,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
Expand Down
107 changes: 101 additions & 6 deletions cabal-install/Distribution/Client/Init.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 in not an executable only
-- then create the "test" directory.
when (eligibleForTestSuite initFlags') $ do
createDirectories (testDirs initFlags')
createTestHs initFlags'
success <- writeCabalFile initFlags'

when success $ generateWarnings initFlags'
Expand All @@ -155,6 +160,8 @@ extendFlags pkgIx sourcePkgDb =
>=> getCategory
>=> getExtraSourceFiles
>=> getSrcDir
>=> getGenTests
>=> getTestDir
>=> getLanguage
>=> getGenComments
>=> getModulesBuildToolsAndDeps pkgIx
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 -------------------------------------------
---------------------------------------------------------------------------
Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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 ()
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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 ()
Expand Down
3 changes: 3 additions & 0 deletions cabal-install/Distribution/Client/Init/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,9 @@ data InitFlags =
, sourceDirs :: Maybe [String]
, buildTools :: Maybe [String]

, initializeTestSuite :: Flag Bool
, testDirs :: Maybe [String]

, initHcPath :: Flag FilePath

, initVerbosity :: Flag Verbosity
Expand Down
12 changes: 12 additions & 0 deletions cabal-install/Distribution/Client/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions cabal-install/changelog
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down