Skip to content

Commit

Permalink
Add support for generating test-suite.
Browse files Browse the repository at this point in the history
Two new flags:
--tests
--test-dir

- Only valid to generate tests for a "Library" or "LibraryAndExecutable".
  • Loading branch information
m-renaud authored and 23Skidoo committed Jan 15, 2019
1 parent 5fbd32e commit 6e7c4f8
Show file tree
Hide file tree
Showing 4 changed files with 146 additions and 34 deletions.
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.nonInteractive = combine IT.nonInteractive,
IT.quiet = combine IT.quiet,
IT.packageDir = combine IT.packageDir,
IT.noComments = combine IT.noComments,
IT.minimal = combine IT.minimal,
IT.simpleProject = combine IT.simpleProject,
IT.packageName = combine IT.packageName,
IT.version = combine IT.version,
IT.cabalVersion = combine IT.cabalVersion,
IT.license = combine IT.license,
IT.author = combine IT.author,
IT.email = combine IT.email,
IT.homepage = combine IT.homepage,
IT.synopsis = combine IT.synopsis,
IT.category = combine IT.category,
IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc,
IT.packageType = combine IT.packageType,
IT.mainIs = combine IT.mainIs,
IT.language = combine IT.language,
IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules,
IT.otherModules = combineMonoid savedInitFlags IT.otherModules,
IT.otherExts = combineMonoid savedInitFlags IT.otherExts,
IT.dependencies = combineMonoid savedInitFlags IT.dependencies,
IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs,
IT.buildTools = combineMonoid savedInitFlags IT.buildTools,
IT.initHcPath = combine IT.initHcPath,
IT.initVerbosity = combine IT.initVerbosity,
IT.overwrite = combine IT.overwrite
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 @@ -849,6 +886,38 @@ mainHs = unlines
, "main = putStrLn \"Hello, Haskell!\""
]

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 @@ -963,6 +1032,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 @@ -1070,6 +1141,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

0 comments on commit 6e7c4f8

Please sign in to comment.