From 0723d6f11caf6e719d46bb014e3d610080b642ae Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sun, 2 Dec 2018 22:26:36 -0800 Subject: [PATCH 1/3] Add support for generating test-suite. Two new flags: --tests --test-dir - Only valid to generate tests for a "Library" or "LibraryAndExecutable". --- cabal-install/Distribution/Client/Config.hs | 58 +++++----- cabal-install/Distribution/Client/Init.hs | 107 +++++++++++++++++- .../Distribution/Client/Init/Types.hs | 3 + cabal-install/Distribution/Client/Setup.hs | 12 ++ 4 files changed, 146 insertions(+), 34 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 5e50ca735d2..b1d9911e774 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Init.hs b/cabal-install/Distribution/Client/Init.hs index 16c82adc1e9..e49d262c5e2 100644 --- a/cabal-install/Distribution/Client/Init.hs +++ b/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 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' @@ -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 () diff --git a/cabal-install/Distribution/Client/Init/Types.hs b/cabal-install/Distribution/Client/Init/Types.hs index cc09991d735..0e54fd73daf 100644 --- a/cabal-install/Distribution/Client/Init/Types.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 915a2f37345..f7b6beb243b 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/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 From b7fe024db26d62bd7f03e6fd473a27932888d272 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sat, 8 Dec 2018 13:16:19 -0800 Subject: [PATCH 2/3] Update changelog. [ci skip] --- cabal-install/changelog | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal-install/changelog b/cabal-install/changelog index df1d7db43e0..9d7b6f36e14 100644 --- a/cabal-install/changelog +++ b/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 November 2018 * Add message to alert user to potential package casing errors. (#5635) From e3475bb967bfc8b2346af9193452c4b7bc149425 Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Fri, 25 Jan 2019 02:00:51 +0000 Subject: [PATCH 3/3] Comment. --- cabal-install/Distribution/Client/Init.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/Distribution/Client/Init.hs b/cabal-install/Distribution/Client/Init.hs index e49d262c5e2..51a6a853f24 100644 --- a/cabal-install/Distribution/Client/Init.hs +++ b/cabal-install/Distribution/Client/Init.hs @@ -131,8 +131,8 @@ initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do writeChangeLog initFlags' createDirectories (sourceDirs initFlags') createMainHs initFlags' - -- If a test suite was requested and this in not an executable only - -- then create the "test" directory. + -- 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'