diff --git a/Cabal/src/Distribution/Fields/Pretty.hs b/Cabal/src/Distribution/Fields/Pretty.hs index 7af4728cee2..dfca73a19d4 100644 --- a/Cabal/src/Distribution/Fields/Pretty.hs +++ b/Cabal/src/Distribution/Fields/Pretty.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} -- | Cabal-like file AST types: 'Field', 'Section' etc, -- -- This (intermediate) data type is used for pretty-printing. @@ -35,6 +36,7 @@ import qualified Text.PrettyPrint as PP data PrettyField ann = PrettyField ann FieldName PP.Doc | PrettySection ann FieldName [PP.Doc] [PrettyField ann] + | PrettyEmpty deriving (Functor, Foldable, Traversable) -- | Prettyprint a list of fields. @@ -74,8 +76,8 @@ showFields' rann post n = unlines . renderFields (Opts rann indent post) indent2 xs = ' ' : ' ' : xs data Opts ann = Opts - { _optAnnotation ::(ann -> [String]) - , _optIndent ::(String -> String) + { _optAnnotation :: ann -> [String] + , _optIndent :: String -> String , _optPostprocess :: ann -> [String] -> [String] } @@ -87,6 +89,7 @@ renderFields opts fields = flattenBlocks $ map (renderField opts len) fields maxNameLength !acc [] = acc maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest + maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest -- | Block of lines, -- Boolean parameter tells whether block should be surrounded by empty lines @@ -134,7 +137,9 @@ renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) ++ post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ] ++ - (map indent $ renderFields opts fields) + map indent (renderFields opts fields) + +renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty ------------------------------------------------------------------------------- -- Transform from Parsec.Field @@ -161,7 +166,7 @@ prettyFieldLines _ fls = PP.vcat -- | Used in 'fromParsecFields'. prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] -prettySectionArgs _ = map $ \sa -> case sa of +prettySectionArgs _ = map $ \case P.SecArgName _ bs -> showToken $ fromUTF8BS bs P.SecArgStr _ bs -> showToken $ fromUTF8BS bs P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs index 3a80f94027a..345ee0807fb 100644 --- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -118,7 +118,7 @@ runTest pkg_descr lbi clbi flags suite = do let suiteLog = buildLog exit -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName' + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' -- Append contents of temporary log file to the final human- -- readable log file @@ -144,7 +144,7 @@ runTest pkg_descr lbi clbi flags suite = do when isCoverageEnabled $ case PD.library pkg_descr of Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" + die' verbosity "Error: test coverage is only supported for packages with a library component" Just library -> markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs index d667d7e0d48..2302e7773e8 100644 --- a/Cabal/src/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs @@ -158,12 +158,11 @@ runTest pkg_descr lbi clbi flags suite = do notice verbosity $ summarizeSuiteFinish suiteLog when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" - - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + case PD.library pkg_descr of + Nothing -> + die' verbosity "Error: test coverage is only supported for packages with a library component" + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library return suiteLog where diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 8e42a9bc7dd..25c73f285ea 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -119,12 +119,16 @@ library Distribution.Client.IndexUtils.IndexState Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init - Distribution.Client.Init.Command Distribution.Client.Init.Defaults Distribution.Client.Init.FileCreators - Distribution.Client.Init.Heuristics + Distribution.Client.Init.FlagExtractors + Distribution.Client.Init.Format + Distribution.Client.Init.Interactive.Command + Distribution.Client.Init.NonInteractive.Command + Distribution.Client.Init.NonInteractive.Heuristics Distribution.Client.Init.Licenses Distribution.Client.Init.Prompt + Distribution.Client.Init.Simple Distribution.Client.Init.Types Distribution.Client.Init.Utils Distribution.Client.Install @@ -203,6 +207,7 @@ library directory >= 1.2.2.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, + exceptions, filepath >= 1.4.0.0 && < 1.5, hashable >= 1.0 && < 1.4, HTTP >= 4000.1.5 && < 4000.4, @@ -273,6 +278,11 @@ Test-Suite unit-tests UnitTests.Distribution.Client.Glob UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.Init + UnitTests.Distribution.Client.Init.Golden + UnitTests.Distribution.Client.Init.Interactive + UnitTests.Distribution.Client.Init.NonInteractive + UnitTests.Distribution.Client.Init.Simple + UnitTests.Distribution.Client.Init.Utils UnitTests.Distribution.Client.Store UnitTests.Distribution.Client.Tar UnitTests.Distribution.Client.TreeDiffInstances diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index fcbed901807..6bb112a26a5 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -13,6 +13,7 @@ -- Entry point to the default cabal-install front-end. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} module Main (main) where import Distribution.Client.Setup @@ -109,11 +110,12 @@ import Distribution.Client.Sandbox (loadConfigOrSandboxConfig ,updateInstallDirs) import Distribution.Client.Tar (createTarGzFile) import Distribution.Client.Types.Credentials (Password (..)) -import Distribution.Client.Init (initCabal) +import Distribution.Client.Init (initCmd) import Distribution.Client.Manpage (manpageCmd) import Distribution.Client.ManpageFlags (ManpageFlags (..)) import Distribution.Client.Utils (determineNumJobs ,relaxEncodingErrors + ,cabalInstallVersion ) import Distribution.Package (packageId) @@ -219,9 +221,9 @@ mainWorker args = do ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines printErrors errs = dieNoVerbosity $ intercalate "\n" errs - printNumericVersion = putStrLn $ display cabalVersion + printNumericVersion = putStrLn $ display cabalInstallVersion printVersion = putStrLn $ "cabal-install version " - ++ display cabalVersion + ++ display cabalInstallVersion ++ "\ncompiled using version " ++ display cabalVersion ++ " of the Cabal library " @@ -918,24 +920,24 @@ unpackAction getFlags extraArgs globalFlags = do getAction getFlags extraArgs globalFlags initAction :: InitFlags -> [String] -> Action -initAction initFlags extraArgs globalFlags = do - let verbosity = fromFlag (initVerbosity initFlags) - when (extraArgs /= []) $ - die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config `mappend` - -- override with `--with-compiler` from CLI if available - mempty { configHcPath = initHcPath initFlags } - let initFlags' = savedInitFlags config `mappend` initFlags - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - initCabal verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - initFlags' +initAction initFlags extraArgs globalFlags + | not (null extraArgs) = + die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs + | otherwise = do + confFlags <- loadConfigOrSandboxConfig verbosity globalFlags + -- override with `--with-compiler` from CLI if available + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` initFlags + globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags + + (comp, _, progdb) <- configCompilerAux' confFlags' + + withRepoContext verbosity globalFlags' $ \repoContext -> + initCmd verbosity (configPackageDB' confFlags') + repoContext comp progdb initFlags' + where + verbosity = fromFlag (initVerbosity initFlags) + compFlags = mempty { configHcPath = initHcPath initFlags } userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index e7277535587..26ae5a87e3e 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -841,8 +841,8 @@ commentSavedConfig = do IT.cabalVersion = toFlag IT.defaultCabalVersion, IT.language = toFlag Haskell2010, IT.license = NoFlag, - IT.sourceDirs = Just [IT.defaultSourceDir], - IT.applicationDirs = Just [IT.defaultApplicationDir] + IT.sourceDirs = Flag [IT.defaultSourceDir], + IT.applicationDirs = Flag [IT.defaultApplicationDir] }, savedInstallFlags = defaultInstallFlags, savedClientInstallFlags= defaultClientInstallFlags, diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs index 5fe5ffd8ba6..3636f4ad663 100644 --- a/cabal-install/src/Distribution/Client/GenBounds.hs +++ b/cabal-install/src/Distribution/Client/GenBounds.hs @@ -18,7 +18,7 @@ module Distribution.Client.GenBounds ( import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Client.Init +import Distribution.Client.Utils ( incVersion ) import Distribution.Client.Freeze ( getFreezePkgs ) @@ -93,7 +93,7 @@ genBounds -> GlobalFlags -> FreezeFlags -> IO () -genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do +genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do let cinfo = compilerInfo comp cwd <- getCurrentDirectory diff --git a/cabal-install/src/Distribution/Client/Init.hs b/cabal-install/src/Distribution/Client/Init.hs index b7b37d23980..c463907581c 100644 --- a/cabal-install/src/Distribution/Client/Init.hs +++ b/cabal-install/src/Distribution/Client/Init.hs @@ -13,13 +13,53 @@ -- ----------------------------------------------------------------------------- -module Distribution.Client.Init ( +module Distribution.Client.Init +( -- * Commands + initCmd +) where - -- * Commands - initCabal - , incVersion +import qualified Distribution.Client.Init.Interactive.Command as Interactive +import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive +import qualified Distribution.Client.Init.Simple as Simple +import Distribution.Verbosity +import Distribution.Client.Setup (RepoContext) +import Distribution.Simple.Compiler +import Distribution.Simple.Program (ProgramDb) +import Distribution.Client.Init.Types +import Distribution.Simple.Setup +import Distribution.Client.IndexUtils +import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering)) +import Distribution.Client.Init.FileCreators - ) where - -import Distribution.Client.Init.Command - ( initCabal, incVersion ) +-- | This is the main driver for the init script. +-- +initCmd + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> InitFlags + -> IO () +initCmd v packageDBs repoCtxt comp progdb initFlags = do + installedPkgIndex <- getInstalledPackages v comp packageDBs progdb + sourcePkgDb <- getSourcePackages v repoCtxt + hSetBuffering stdout NoBuffering + settings <- createProject v installedPkgIndex sourcePkgDb initFlags + writeProject settings + where + -- When no flag is set, default to interactive. + -- + -- When `--interactive` is set, if we also set `--simple`, + -- then we interactive generate a simple project with sensible defaults. + -- + -- If `--simple` is not set, default to interactive. When the flag + -- is explicitly set to `--non-interactive`, then we choose non-interactive. + -- + createProject = case interactive initFlags of + NoFlag -> Interactive.createProject + Flag True + | fromFlagOrDefault False (simpleProject initFlags) -> + Simple.createProject + | otherwise -> Interactive.createProject + Flag False -> NonInteractive.createProject diff --git a/cabal-install/src/Distribution/Client/Init/Command.hs b/cabal-install/src/Distribution/Client/Init/Command.hs deleted file mode 100644 index 0842250cd1b..00000000000 --- a/cabal-install/src/Distribution/Client/Init/Command.hs +++ /dev/null @@ -1,749 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Command --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Command - ( -- * Commands - initCabal - , incVersion - - -- * Helpers - , getSimpleProject - , getLibOrExec - , getCabalVersion - , getPackageName - , getVersion - , getLicense - , getAuthorInfo - , getHomepage - , getSynopsis - , getCategory - , getExtraSourceFiles - , getAppDir - , getSrcDir - , getGenTests - , getTestDir - , getLanguage - , getGenComments - , getModulesBuildToolsAndDeps - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import System.IO - ( hSetBuffering, stdout, BufferMode(..) ) -import System.Directory - ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents ) -import System.FilePath - ( (), takeBaseName, equalFilePath ) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Control.Monad - ( (>=>) ) -import Control.Arrow - ( (&&&), (***) ) - -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), showCabalSpecVersion ) -import Distribution.Version - ( Version, mkVersion, alterVersion, majorBoundVersion - , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, exposed ) -import qualified Distribution.Package as P -import qualified Distribution.SPDX as SPDX -import Language.Haskell.Extension ( Language(..) ) - -import Distribution.Client.Init.Defaults - ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir ) -import Distribution.Client.Init.FileCreators - ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs - , createTestSuiteIfEligible, writeCabalFile ) -import Distribution.Client.Init.Prompt - ( prompt, promptYesNo, promptStr, promptList, maybePrompt - , promptListOptional ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) - , displayPackageType ) -import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, - SourceFileEntry(..), - scanForModules, neededBuildPrograms ) - -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Configure - ( getInstalledPackages ) -import Distribution.Simple.Compiler - ( PackageDBStack, Compiler ) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, moduleNameIndex ) -import Distribution.Simple.Utils - ( die' ) - -import Distribution.Solver.Types.PackageIndex - ( elemByPackageName ) - -import Distribution.Client.IndexUtils - ( getSourcePackages ) -import Distribution.Client.Types - ( SourcePackageDb(..) ) -import Distribution.Client.Setup - ( RepoContext(..) ) - -initCabal :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> InitFlags - -> IO () -initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - hSetBuffering stdout NoBuffering - - initFlags' <- extendFlags verbosity installedPkgIndex sourcePkgDb initFlags - - case license initFlags' of - Flag SPDX.NONE -> return () - _ -> writeLicense initFlags' - writeChangeLog initFlags' - createDirectories (sourceDirs initFlags') - createLibHs initFlags' - createDirectories (applicationDirs initFlags') - createMainHs initFlags' - createTestSuiteIfEligible initFlags' - success <- writeCabalFile initFlags' - - when success $ generateWarnings initFlags' - ---------------------------------------------------------------------------- --- Flag acquisition ----------------------------------------------------- ---------------------------------------------------------------------------- - --- | Fill in more details in InitFlags by guessing, discovering, or prompting --- the user. -extendFlags :: Verbosity -> InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags -extendFlags verbosity pkgIx sourcePkgDb = - getSimpleProject - >=> getLibOrExec - >=> getCabalVersion - >=> getPackageName verbosity sourcePkgDb False - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getExtraSourceFiles - >=> getAppDir - >=> getSrcDir - >=> getGenTests - >=> getTestDir - >=> getLanguage - >=> getGenComments - >=> getModulesBuildToolsAndDeps pkgIx - --- | Combine two actions which may return a value, preferring the first. That --- is, run the second action only if the first doesn't return a value. -infixr 1 ?>> -(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) -f ?>> g = do - ma <- f - if isJust ma - then return ma - else g - --- | Ask if a simple project with sensible defaults should be created. -getSimpleProject :: InitFlags -> IO InitFlags -getSimpleProject flags = do - simpleProj <- return (flagToMaybe $ simpleProject flags) - ?>> maybePrompt flags - (promptYesNo - "Should I generate a simple project with sensible defaults" - (Just True)) - return $ case maybeToFlag simpleProj of - Flag True -> - flags { interactive = Flag False - , simpleProject = Flag True - , packageType = Flag LibraryAndExecutable - , cabalVersion = Flag defaultCabalVersion - } - simpleProjFlag@_ -> - flags { simpleProject = simpleProjFlag } - - --- | Get the version of the cabal spec to use. --- --- The spec version can be specified by the InitFlags cabalVersion field. If --- none is specified then the user is prompted to pick from a list of --- supported versions (see code below). -getCabalVersion :: InitFlags -> IO InitFlags -getCabalVersion flags = do - cabVer <- return (flagToMaybe $ cabalVersion flags) - ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` - promptList "Please choose version of the Cabal specification to use" - [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0] - (Just defaultCabalVersion) displayCabalVersion False) - ?>> return (Just defaultCabalVersion) - - return $ flags { cabalVersion = maybeToFlag cabVer } - - where - displayCabalVersion :: CabalSpecVersion -> String - displayCabalVersion v = case v of - CabalSpecV1_10 -> "1.10 (legacy)" - CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" - CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" - CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" - CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" - _ -> showCabalSpecVersion v - - - --- | Get the package name: use the package directory (supplied, or the current --- directory by default) as a guess. It looks at the SourcePackageDb to avoid --- using an existing package name. -getPackageName :: Verbosity -> SourcePackageDb -> Bool -> InitFlags -> IO InitFlags -getPackageName verbosity sourcePkgDb forceAsk flags = do - guess <- maybe (getCurrentDirectory >>= guessPackageName) pure - =<< traverse guessPackageName (flagToMaybe $ packageDir flags) - - pkgName' <- case (flagToMaybe $ packageName flags) >>= maybeForceAsk of - Just pkgName -> return $ Just $ pkgName - _ -> maybePrompt flags (prompt "Package name" (Just guess)) - let pkgName = fromMaybe guess pkgName' - - chooseAgain <- if isPkgRegistered pkgName - then do - answer' <- maybePrompt flags (promptYesNo (promptOtherNameMsg pkgName) (Just True)) - case answer' of - Just answer -> return answer - _ -> die' verbosity $ inUseMsg pkgName - else - return False - - if chooseAgain - then getPackageName verbosity sourcePkgDb True flags - else return $ flags { packageName = Flag pkgName } - - where - maybeForceAsk x = if forceAsk then Nothing else Just x - - isPkgRegistered pkg = elemByPackageName (packageIndex sourcePkgDb) pkg - - inUseMsg pkgName = "The name " ++ (P.unPackageName pkgName) ++ - " is already in use by another package on Hackage." - - promptOtherNameMsg pkgName = (inUseMsg pkgName) ++ - " Do you want to choose a different name" - --- | Package version: use 0.1.0.0 as a last resort, but try prompting the user --- if possible. -getVersion :: InitFlags -> IO InitFlags -getVersion flags = do - let v = Just $ mkVersion [0,1,0,0] - v' <- return (flagToMaybe $ version flags) - ?>> maybePrompt flags (prompt "Package version" v) - ?>> return v - return $ flags { version = maybeToFlag v' } - --- | Choose a license for the package. --- --- The license can come from Initflags (license field), if it is not present --- then prompt the user from a predefined list of licenses. -getLicense :: InitFlags -> IO InitFlags -getLicense flags = do - elic <- return (fmap Right $ flagToMaybe $ license flags) - ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True) - - case elic of - Nothing -> return flags { license = NoFlag } - Just (Right lic) -> return flags { license = Flag lic } - Just (Left str) -> case eitherParsec str of - Right lic -> return flags { license = Flag lic } - -- on error, loop - Left err -> do - putStrLn "The license must be a valid SPDX expression." - putStrLn err - getLicense flags - where - -- perfectly we'll have this and writeLicense (in FileCreators) - -- in a single file - listedLicenses = - SPDX.NONE : - map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) - [ SPDX.BSD_2_Clause - , SPDX.BSD_3_Clause - , SPDX.Apache_2_0 - , SPDX.MIT - , SPDX.MPL_2_0 - , SPDX.ISC - - , SPDX.GPL_2_0_only - , SPDX.GPL_3_0_only - , SPDX.LGPL_2_1_only - , SPDX.LGPL_3_0_only - , SPDX.AGPL_3_0_only - - , SPDX.GPL_2_0_or_later - , SPDX.GPL_3_0_or_later - , SPDX.LGPL_2_1_or_later - , SPDX.LGPL_3_0_or_later - , SPDX.AGPL_3_0_or_later - ] - --- | The author's name and email. Prompt, or try to guess from an existing --- darcs repo. -getAuthorInfo :: InitFlags -> IO InitFlags -getAuthorInfo flags = do - (authorName, authorEmail) <- - (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail - authorName' <- return (flagToMaybe $ author flags) - ?>> maybePrompt flags (promptStr "Author name" authorName) - ?>> return authorName - - authorEmail' <- return (flagToMaybe $ email flags) - ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) - ?>> return authorEmail - - return $ flags { author = maybeToFlag authorName' - , email = maybeToFlag authorEmail' - } - --- | Prompt for a homepage URL for the package. -getHomepage :: InitFlags -> IO InitFlags -getHomepage flags = do - hp <- queryHomepage - hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage URL" hp) - ?>> return hp - - return $ flags { homepage = maybeToFlag hp' } - --- | Right now this does nothing, but it could be changed to do some --- intelligent guessing. -queryHomepage :: IO (Maybe String) -queryHomepage = return Nothing -- get default remote darcs repo? - --- | Prompt for a project synopsis. -getSynopsis :: InitFlags -> IO InitFlags -getSynopsis flags = do - syn <- return (flagToMaybe $ synopsis flags) - ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) - - return $ flags { synopsis = maybeToFlag syn } - --- | Prompt for a package category. --- Note that it should be possible to do some smarter guessing here too, i.e. --- look at the name of the top level source directory. -getCategory :: InitFlags -> IO InitFlags -getCategory flags = do - cat <- return (flagToMaybe $ category flags) - ?>> fmap join (maybePrompt flags - (promptListOptional "Project category" [Codec ..])) - return $ flags { category = maybeToFlag cat } - --- | Try to guess extra source files (don't prompt the user). -getExtraSourceFiles :: InitFlags -> IO InitFlags -getExtraSourceFiles flags = do - extraSrcFiles <- return (extraSrc flags) - ?>> Just `fmap` guessExtraSourceFiles flags - - return $ flags { extraSrc = extraSrcFiles } - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" - --- | Try to guess things to include in the extra-source-files field. --- For now, we just look for things in the root directory named --- 'readme', 'changes', or 'changelog', with any sort of --- capitalization and any extension. -guessExtraSourceFiles :: InitFlags -> IO [FilePath] -guessExtraSourceFiles flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - files <- getDirectoryContents dir - let extraFiles = filter isExtra files - if any isLikeChangeLog extraFiles - then return extraFiles - else return (defaultChangeLog : extraFiles) - - where - isExtra = likeFileNameBase ("README" : changeLogLikeBases) - isLikeChangeLog = likeFileNameBase changeLogLikeBases - likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName - changeLogLikeBases = ["CHANGES", "CHANGELOG"] - --- | Ask whether the project builds a library or executable. -getLibOrExec :: InitFlags -> IO InitFlags -getLibOrExec flags = do - pkgType <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Executable) id `fmap` - promptList "What does the package build" - [Executable, Library, LibraryAndExecutable] - Nothing displayPackageType False) - ?>> return (Just Executable) - - -- If this package contains an executable, get the main file name. - mainFile <- if pkgType == Just Library then return Nothing else - getMainFile flags - - return $ flags { packageType = maybeToFlag pkgType - , mainIs = maybeToFlag mainFile - } - - --- | Try to guess the main file of the executable, and prompt the user to choose --- one of them. Top-level modules including the word 'Main' in the file name --- will be candidates, and shorter filenames will be preferred. -getMainFile :: InitFlags -> IO (Maybe FilePath) -getMainFile flags = - return (flagToMaybe $ mainIs flags) - ?>> do - candidates <- guessMainFileCandidates flags - let showCandidate = either (++" (does not yet exist, but will be created)") id - defaultFile = listToMaybe candidates - maybePrompt flags (either id (either id id) `fmap` - promptList "What is the main module of the executable" - candidates - 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 suite 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 Haskell base language of the package. -getLanguage :: InitFlags -> IO InitFlags -getLanguage flags = do - lang <- return (flagToMaybe $ language flags) - ?>> maybePrompt flags - (either UnknownLanguage id `fmap` - promptList "What base language is the package written in" - [Haskell2010, Haskell98] - (Just Haskell2010) prettyShow True) - ?>> return (Just Haskell2010) - - if invalidLanguage lang - then putStrLn invalidOtherLanguageMsg >> getLanguage flags - else return $ flags { language = maybeToFlag lang } - - where - invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t - invalidLanguage _ = False - - invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ - "Please enter a different language." - --- | Ask whether to generate explanatory comments. -getGenComments :: InitFlags -> IO InitFlags -getGenComments flags = do - genComments <- return (not <$> flagToMaybe (noComments flags)) - ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) - ?>> return (Just False) - return $ flags { noComments = maybeToFlag (fmap not genComments) } - where - promptMsg = "Add informative comments to each field in the cabal file (y/n)" - --- | Ask for the application root directory. -getAppDir :: InitFlags -> IO InitFlags -getAppDir flags = do - appDirs <- noAppDirIfLibraryOnly - ?>> guessAppDir flags - ?>> promptUserForApplicationDir - ?>> setDefault - return $ flags { applicationDirs = appDirs } - where - -- If the packageType==Library, ignore defined appdir. - noAppDirIfLibraryOnly :: IO (Maybe [String]) - noAppDirIfLibraryOnly - | packageType flags == Flag Library = return $ Just [] - | otherwise = return $ applicationDirs flags - - -- Set the default application directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultApplicationDir]) - - -- Prompt the user for the application directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForApplicationDir :: IO (Maybe [String]) - promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Application " ++ mainFile ++ "directory") - [[defaultApplicationDir], ["src-exe"], []] - (Just [defaultApplicationDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - -- The name - mainFile :: String - mainFile = case mainIs flags of - Flag mainPath -> "(" ++ mainPath ++ ") " - _ -> "" - --- | Try to guess app directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'app'. -guessAppDir :: InitFlags -> IO (Maybe [String]) -guessAppDir flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - appIsDir <- doesDirectoryExist (dir "app") - return $ if appIsDir - then Just ["app"] - else Nothing - --- | Ask for the source (library) root directory. -getSrcDir :: InitFlags -> IO InitFlags -getSrcDir flags = do - srcDirs <- noSourceDirIfExecutableOnly - ?>> guessSourceDir flags - ?>> promptUserForSourceDir - ?>> setDefault - - return $ flags { sourceDirs = srcDirs } - - where - -- If the packageType==Executable, then ignore source dir - noSourceDirIfExecutableOnly :: IO (Maybe [String]) - noSourceDirIfExecutableOnly - | packageType flags == Flag Executable = return $ Just [] - | otherwise = return $ sourceDirs flags - - -- Set the default source directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultSourceDir]) - - -- Prompt the user for the source directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForSourceDir :: IO (Maybe [String]) - promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Library source directory") - [[defaultSourceDir], ["lib"], ["src-lib"], []] - (Just [defaultSourceDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - --- | Try to guess source directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'src'. -guessSourceDir :: InitFlags -> IO (Maybe [String]) -guessSourceDir flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - srcIsDir <- doesDirectoryExist (dir "src") - return $ if srcIsDir - then Just ["src"] - else Nothing - --- | Check whether a potential source file is located in one of the --- source directories. -isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool -isSourceFile Nothing sf = isSourceFile (Just ["."]) sf -isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs - --- | Get the list of exposed modules and extra tools needed to build them. -getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags -getModulesBuildToolsAndDeps pkgIx flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - - sourceFiles0 <- scanForModules dir - - let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 - - Just mods <- return (exposedModules flags) - ?>> (return . Just . map moduleName $ sourceFiles) - - tools <- return (buildTools flags) - ?>> (return . Just . neededBuildPrograms $ sourceFiles) - - deps <- return (dependencies flags) - ?>> Just <$> importsToDeps flags - (fromString "Prelude" : -- to ensure we get base as a dep - ( nub -- only need to consider each imported package once - . filter (`notElem` mods) -- don't consider modules from - -- this package itself - . concatMap imports - $ sourceFiles - ) - ) - pkgIx - - exts <- return (otherExts flags) - ?>> (return . Just . nub . concatMap extensions $ sourceFiles) - - -- If we're initializing a library and there were no modules discovered - -- then create an empty 'MyLib' module. - -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because - -- then the executable needs to set 'other-modules: MyLib' or else the build - -- fails. - let (finalModsList, otherMods) = case (packageType flags, mods) of - - -- For an executable leave things as they are. - (Flag Executable, _) -> (mods, otherModules flags) - - -- If a non-empty module list exists don't change anything. - (_, (_:_)) -> (mods, otherModules flags) - - -- Library only: 'MyLib' in 'other-modules' only. - (Flag Library, _) -> ([myLibModule], Nothing) - - -- For a 'LibraryAndExecutable' we need to have special handling. - -- If we don't have a module list (Nothing or empty), then create a Lib. - (_, []) -> - if sourceDirs flags == applicationDirs flags - then ([myLibModule], Just [myLibModule]) - else ([myLibModule], Nothing) - - return $ flags { exposedModules = Just finalModsList - , otherModules = otherMods - , buildTools = tools - , dependencies = deps - , otherExts = exts - } - --- | Given a list of imported modules, retrieve the list of dependencies that --- provide those modules. -importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] -importsToDeps flags mods pkgIx = do - - let modMap :: M.Map ModuleName [InstalledPackageInfo] - modMap = M.map (filter exposed) $ moduleNameIndex pkgIx - - modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] - modDeps = map (id &&& flip M.lookup modMap) mods - - message flags "\nGuessing dependencies..." - nub . catMaybes <$> traverse (chooseDep flags) modDeps - --- Given a module and a list of installed packages providing it, --- choose a dependency (i.e. package + version range) to use for that --- module. -chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) - -> IO (Maybe P.Dependency) - -chooseDep flags (m, Nothing) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - -chooseDep flags (m, Just []) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - - -- We found some packages: group them by name. -chooseDep flags (m, Just ps) - = case pkgGroups of - -- if there's only one group, i.e. multiple versions of a single package, - -- we make it into a dependency, choosing the latest-ish version (see toDep). - [grp] -> Just <$> toDep grp - -- otherwise, we refuse to choose between different packages and make the user - -- do it. - grps -> do message flags ("\nWarning: multiple packages found providing " - ++ prettyShow m - ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) - message flags "You will need to pick one and manually add it to the Build-depends: field." - return Nothing - where - pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) - - desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags) - - -- Given a list of available versions of the same package, pick a dependency. - toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency - - -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries - - -- Otherwise, choose the latest version and issue a warning. - toDep pids = do - message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") - return $ P.Dependency (P.pkgName . NE.head $ pids) - (pvpize desugar . maximum . fmap P.pkgVersion $ pids) - P.mainLibSet --TODO take into account sublibraries - --- | Given a version, return an API-compatible (according to PVP) version range. --- --- If the boolean argument denotes whether to use a desugared --- representation (if 'True') or the new-style @^>=@-form (if --- 'False'). --- --- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the --- same as @0.4.*@). -pvpize :: Bool -> Version -> VersionRange -pvpize False v = majorBoundVersion v -pvpize True v = orLaterVersion v' - `intersectVersionRanges` - earlierVersion (incVersion 1 v') - where v' = alterVersion (take 2) v - --- | Increment the nth version component (counting from 0). -incVersion :: Int -> Version -> Version -incVersion n = alterVersion (incVersion' n) - where - incVersion' 0 [] = [1] - incVersion' 0 (v:_) = [v+1] - incVersion' m [] = replicate m 0 ++ [1] - incVersion' m (v:vs) = v : incVersion' (m-1) vs - --- | Generate warnings for missing fields etc. -generateWarnings :: InitFlags -> IO () -generateWarnings flags = do - message flags "" - when (synopsis flags `elem` [NoFlag, Flag ""]) - (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") - - message flags "You may want to edit the .cabal file and add a Description field." diff --git a/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs index 7f87a28f1f1..7a629dc4bbc 100644 --- a/cabal-install/src/Distribution/Client/Init/Defaults.hs +++ b/cabal-install/src/Distribution/Client/Init/Defaults.hs @@ -12,21 +12,52 @@ -- ----------------------------------------------------------------------------- -module Distribution.Client.Init.Defaults ( - defaultApplicationDir - , defaultSourceDir - , defaultCabalVersion - , myLibModule - ) where - -import Prelude (String) - -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import qualified Distribution.ModuleName as ModuleName - ( fromString ) -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..)) +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +module Distribution.Client.Init.Defaults + +( -- * default init values + defaultApplicationDir +, defaultSourceDir +, defaultCabalVersion +, defaultCabalVersions +, defaultPackageType +, defaultLicense +, defaultLicenseIds +, defaultMainIs +, defaultChangelog +, defaultCategories +, defaultInitFlags +, defaultLanguage +, defaultVersion +, defaultTestDir + -- * MyLib defaults +, myLibModule +, myLibTestFile +, myLibFile +, myLibHs +, myExeHs +, myLibExeHs +, myTestHs +) where + + +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName(fromString) +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +import Distribution.Client.Init.Types (PackageType(..), InitFlags(..), HsFilePath, toHsFilePath) +import qualified Distribution.SPDX.License as SPDX +import qualified Distribution.SPDX.LicenseId as SPDX +import Distribution.Simple.Flag (toFlag) +import Distribution.Verbosity (normal) +import Distribution.Types.Version +import Distribution.Simple + + +-- -------------------------------------------------------------------- -- +-- Default flag and init values + +defaultVersion :: Version +defaultVersion = mkVersion [0,1,0,0] defaultApplicationDir :: String defaultApplicationDir = "app" @@ -34,8 +65,127 @@ defaultApplicationDir = "app" defaultSourceDir :: String defaultSourceDir = "src" +defaultTestDir :: String +defaultTestDir = "test" + defaultCabalVersion :: CabalSpecVersion -defaultCabalVersion = CabalSpecV2_4 +defaultCabalVersion = CabalSpecV3_0 + +defaultPackageType :: PackageType +defaultPackageType = Executable + +defaultChangelog :: FilePath +defaultChangelog = "CHANGELOG.md" + +defaultLicense :: SPDX.License +defaultLicense = SPDX.NONE + +defaultMainIs :: HsFilePath +defaultMainIs = toHsFilePath "Main.hs" + +defaultLanguage :: Language +defaultLanguage = Haskell2010 + +defaultLicenseIds :: [SPDX.LicenseId] +defaultLicenseIds = + [ SPDX.BSD_2_Clause + , SPDX.BSD_3_Clause + , SPDX.Apache_2_0 + , SPDX.MIT + , SPDX.MPL_2_0 + , SPDX.ISC + , SPDX.GPL_2_0_only + , SPDX.GPL_3_0_only + , SPDX.LGPL_2_1_only + , SPDX.LGPL_3_0_only + , SPDX.AGPL_3_0_only + , SPDX.GPL_2_0_or_later + , SPDX.GPL_3_0_or_later + , SPDX.LGPL_2_1_or_later + , SPDX.LGPL_3_0_or_later + , SPDX.AGPL_3_0_or_later + ] + +defaultCategories :: [String] +defaultCategories = + [ "Codec" + , "Concurrency" + , "Control" + , "Data" + , "Database" + , "Development" + , "Distribution" + , "Game" + , "Graphics" + , "Language" + , "Math" + , "Network" + , "Sound" + , "System" + , "Testing" + , "Text" + , "Web" + ] + +defaultCabalVersions :: [CabalSpecVersion] +defaultCabalVersions = + [ CabalSpecV1_10 + , CabalSpecV2_0 + , CabalSpecV2_2 + , CabalSpecV2_4 + , CabalSpecV3_0 + , CabalSpecV3_4 + ] + +defaultInitFlags :: InitFlags +defaultInitFlags = mempty { initVerbosity = toFlag normal } + +-- -------------------------------------------------------------------- -- +-- MyLib defaults myLibModule :: ModuleName myLibModule = ModuleName.fromString "MyLib" + +myLibTestFile :: HsFilePath +myLibTestFile = toHsFilePath "MyLibTest.hs" + +myLibFile :: HsFilePath +myLibFile = toHsFilePath "MyLib.hs" + +-- | Default MyLib.hs file. Used when no Lib.hs exists. +myLibHs :: String +myLibHs = unlines + [ "module MyLib (someFunc) where" + , "" + , "someFunc :: IO ()" + , "someFunc = putStrLn \"someFunc\"" + ] + +myExeHs :: [String] +myExeHs = + [ "module Main where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Hello, Haskell!\"" + ] + +myLibExeHs :: [String] +myLibExeHs = + [ "module Main where" + , "" + , "import qualified MyLib (someFunc)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Hello, Haskell!\"" + , " MyLib.someFunc" + ] + +-- | Default MyLibTest.hs file. +myTestHs :: String +myTestHs = unlines + [ "module Main (main) where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Test suite not yet implemented.\"" + ] diff --git a/cabal-install/src/Distribution/Client/Init/FileCreators.hs b/cabal-install/src/Distribution/Client/Init/FileCreators.hs index 5e4cc6ab95d..7ce2c26be9c 100644 --- a/cabal-install/src/Distribution/Client/Init/FileCreators.hs +++ b/cabal-install/src/Distribution/Client/Init/FileCreators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -12,640 +13,280 @@ -- Functions to create files during 'cabal init'. -- ----------------------------------------------------------------------------- +module Distribution.Client.Init.FileCreators +( -- * Commands + writeProject +, writeLicense +, writeChangeLog +, prepareLibTarget +, prepareExeTarget +, prepareTestTarget +) where + +import Prelude hiding (writeFile) +import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile) + +import Distribution.Client.Utils (getCurrentYear) +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Licenses + ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) +import Distribution.Client.Init.Types hiding (putStrLn, putStr, message) +import qualified Distribution.Client.Init.Types as T +import Distribution.Fields.Pretty (PrettyField(..), showFields') +import qualified Distribution.SPDX as SPDX +import Distribution.Types.PackageName -module Distribution.Client.Init.FileCreators ( +import System.Directory hiding (doesDirectoryExist, doesFileExist, createDirectory, renameDirectory, copyFile) +import System.FilePath ((), (<.>)) - -- * Commands - writeLicense - , writeChangeLog - , createDirectories - , createLibHs - , createMainHs - , createTestSuiteIfEligible - , writeCabalFile +import Distribution.Client.Init.Format - -- * For testing - , generateCabalFile - ) where -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) +-- -------------------------------------------------------------------- -- +-- File generation -import System.FilePath - ( (), (<.>), takeExtension ) +writeProject :: ProjectSettings -> IO () +writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget) + | null pkgName = do + message opts "\nError: no package name given, so no .cabal file can be generated\n" + | otherwise = do -import Distribution.Types.Dependency -import Distribution.Types.VersionRange + -- clear prompt history a bit" + message opts "" -import Data.Time - ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import System.Directory - ( getCurrentDirectory, doesFileExist, copyFile - , createDirectoryIfMissing ) + writeLicense opts pkgDesc + writeChangeLog opts pkgDesc -import Text.PrettyPrint hiding ((<>), mode, cat) + let pkgFields = mkPkgDescription opts pkgDesc -import Distribution.Client.Init.Defaults - ( defaultCabalVersion, myLibModule ) -import Distribution.Client.Init.Licenses - ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), BuildType(..), PackageType(..) ) - -import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype - ( Newtype ) -import Distribution.Fields.Field - ( FieldName ) -import Distribution.License - ( licenseFromSPDX ) -import qualified Distribution.ModuleName as ModuleName - ( toFilePath ) -import Distribution.FieldGrammar.Newtypes - ( SpecVersion(..) ) -import Distribution.PackageDescription.FieldGrammar - ( formatDependencyList, formatExposedModules, formatHsSourceDirs, - formatOtherExtensions, formatOtherModules, formatExtraSourceFiles ) -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Utils - ( toUTF8BS ) -import Distribution.Fields.Pretty - ( PrettyField(..), showFields' ) + libStanza <- prepareLibTarget opts libTarget + exeStanza <- prepareExeTarget opts exeTarget + testStanza <- prepareTestTarget opts testTarget -import qualified Distribution.SPDX as SPDX + writeCabalFile opts $ pkgFields ++ [libStanza, exeStanza, testStanza] + + when (null $ _pkgSynopsis pkgDesc) $ + message opts "\nWarning: no synopsis given. You should edit the .cabal file and add one." -import Distribution.Utils.Path -- TODO + message opts "You may want to edit the .cabal file and add a Description field." + where + pkgName = unPackageName $ _optPkgName opts + + +prepareLibTarget + :: WriteOpts + -> Maybe LibTarget + -> IO (PrettyField FieldAnnotation) +prepareLibTarget _ Nothing = return PrettyEmpty +prepareLibTarget opts (Just libTarget) = do + void $ writeDirectoriesSafe opts srcDirs + -- avoid writing when conflicting exposed paths may + -- exist. + when (expMods == (myLibModule :| [])) $ do + writeFileSafe opts libPath myLibHs + + return $ mkLibStanza opts libTarget + where + expMods = _libExposedModules libTarget + srcDirs = _libSourceDirs libTarget + libPath = case srcDirs of + path:_ -> path _hsFilePath myLibFile + _ -> _hsFilePath myLibFile + +prepareExeTarget + :: WriteOpts + -> Maybe ExeTarget + -> IO (PrettyField FieldAnnotation) +prepareExeTarget _ Nothing = return PrettyEmpty +prepareExeTarget opts (Just exeTarget) = do + void $ writeDirectoriesSafe opts appDirs + void $ writeFileSafe opts mainPath mainHs + return $ mkExeStanza opts exeTarget + where + exeMainIs = _exeMainIs exeTarget + pkgType = _optPkgType opts + appDirs = _exeApplicationDirs exeTarget + mainFile = _hsFilePath exeMainIs + mainPath = case appDirs of + appPath:_ -> appPath mainFile + _ -> mainFile + + mainHs = unlines . mkLiterate exeMainIs $ + if pkgType == LibraryAndExecutable + then myLibExeHs + else myExeHs + +prepareTestTarget + :: WriteOpts + -> Maybe TestTarget + -> IO (PrettyField FieldAnnotation) +prepareTestTarget _ Nothing = return PrettyEmpty +prepareTestTarget opts (Just testTarget) = do + void $ writeDirectoriesSafe opts testDirs' + void $ writeFileSafe opts testPath myTestHs + return $ mkTestStanza opts testTarget + where + testDirs' = _testDirs testTarget + testMainIs = _hsFilePath $ _testMainIs testTarget + testPath = case testDirs' of + p:_ -> p testMainIs + _ -> testMainIs + +writeCabalFile + :: WriteOpts + -> [PrettyField FieldAnnotation] + -- ^ .cabal fields + -> IO () +writeCabalFile opts fields = do + message opts $ "\nGenerating " ++ cabalFileName ++ "..." + exists <- doesFileExist cabalFileName + + if exists && doOverwrite then do + removeFile cabalFileName + writeFileSafe opts cabalFileName cabalContents + else writeFileSafe opts cabalFileName cabalContents + where + doOverwrite = _optOverwrite opts ---------------------------------------------------------------------------- --- File generation ------------------------------------------------------ ---------------------------------------------------------------------------- + cabalContents = showFields' + annCommentLines + postProcessFieldLines + 4 fields --- | Write the LICENSE file, as specified in the InitFlags license field. + cabalFileName = pkgName ++ ".cabal" + pkgName = unPackageName $ _optPkgName opts + +-- | Write the LICENSE file. -- --- For licences that contain the author's name(s), the values are taken +-- For licenses that contain the author's name(s), the values are taken -- from the 'authors' field of 'InitFlags', and if not specified will -- be the string "???". -- --- If the license type is unknown no license file will be created and +-- If the license type is unknown no license file will be prepared and -- a warning will be raised. -writeLicense :: InitFlags -> IO () -writeLicense flags = do - message flags "\nGenerating LICENSE..." +-- +writeLicense :: WriteOpts -> PkgDescription -> IO () +writeLicense writeOpts pkgDesc = do year <- show <$> getCurrentYear - let authors = fromMaybe "???" . flagToMaybe . author $ flags - let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId - isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid - isSimpleLicense _ = Nothing - let licenseFile = - case flagToMaybe (license flags) >>= isSimpleLicense of - Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year - Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year - Just SPDX.Apache_2_0 -> Just apache20 - Just SPDX.MIT -> Just $ mit authors year - Just SPDX.MPL_2_0 -> Just mpl20 - Just SPDX.ISC -> Just $ isc authors year - - -- GNU license come in "only" and "or-later" flavours - -- license file used are the same. - Just SPDX.GPL_2_0_only -> Just gplv2 - Just SPDX.GPL_3_0_only -> Just gplv3 - Just SPDX.LGPL_2_1_only -> Just lgpl21 - Just SPDX.LGPL_3_0_only -> Just lgpl3 - Just SPDX.AGPL_3_0_only -> Just agplv3 - - Just SPDX.GPL_2_0_or_later -> Just gplv2 - Just SPDX.GPL_3_0_or_later -> Just gplv3 - Just SPDX.LGPL_2_1_or_later -> Just lgpl21 - Just SPDX.LGPL_3_0_or_later -> Just lgpl3 - Just SPDX.AGPL_3_0_or_later -> Just agplv3 - - _ -> Nothing - - case licenseFile of - Just licenseText -> writeFileSafe flags "LICENSE" licenseText - Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." - --- | Returns the current calendar year. -getCurrentYear :: IO Integer -getCurrentYear = do - u <- getCurrentTime - z <- getCurrentTimeZone - let l = utcToLocalTime z u - (y, _, _) = toGregorian $ localDay l - return y - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" + case licenseFile year (_pkgAuthor pkgDesc) of + Just licenseText -> do + message writeOpts "\nCreating LICENSE..." + writeFileSafe writeOpts "LICENSE" licenseText + Nothing -> message writeOpts "Warning: unknown license type, you must put a copy in LICENSE yourself." + where + getLid (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = + Just lid + getLid _ = Nothing + + licenseFile year auth = case getLid $ _pkgLicense pkgDesc of + Just SPDX.BSD_2_Clause -> Just $ bsd2 auth year + Just SPDX.BSD_3_Clause -> Just $ bsd3 auth year + Just SPDX.Apache_2_0 -> Just apache20 + Just SPDX.MIT -> Just $ mit auth year + Just SPDX.MPL_2_0 -> Just mpl20 + Just SPDX.ISC -> Just $ isc auth year + Just SPDX.GPL_2_0_only -> Just gplv2 + Just SPDX.GPL_3_0_only -> Just gplv3 + Just SPDX.LGPL_2_1_only -> Just lgpl21 + Just SPDX.LGPL_3_0_only -> Just lgpl3 + Just SPDX.AGPL_3_0_only -> Just agplv3 + Just SPDX.GPL_2_0_or_later -> Just gplv2 + Just SPDX.GPL_3_0_or_later -> Just gplv3 + Just SPDX.LGPL_2_1_or_later -> Just lgpl21 + Just SPDX.LGPL_3_0_or_later -> Just lgpl3 + Just SPDX.AGPL_3_0_or_later -> Just agplv3 + _ -> Nothing -- | Writes the changelog to the current directory. -writeChangeLog :: InitFlags -> IO () -writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do - message flags ("Generating "++ defaultChangeLog ++"...") - writeFileSafe flags defaultChangeLog changeLog +-- +writeChangeLog :: WriteOpts -> PkgDescription -> IO () +writeChangeLog opts pkgDesc + | defaultChangelog `elem` _pkgExtraSrcFiles pkgDesc = do + message opts ("Creating " ++ defaultChangelog ++"...") + writeFileSafe opts defaultChangelog changeLog + | otherwise = return () where changeLog = unlines - [ "# Revision history for " ++ pname + [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc) , "" - , "## " ++ pver ++ " -- YYYY-mm-dd" + , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd" , "" , "* First version. Released on an unsuspecting world." ] - pname = maybe "" prettyShow $ flagToMaybe $ packageName flags - pver = maybe "" prettyShow $ flagToMaybe $ version flags --- | Creates and writes the initialized .cabal file. --- --- Returns @False@ if no package name is specified, @True@ otherwise. -writeCabalFile :: InitFlags -> IO Bool -writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do - message flags "Error: no package name provided." - return False -writeCabalFile flags@(InitFlags{packageName = Flag p}) = do - let cabalFileName = prettyShow p ++ ".cabal" - message flags $ "Generating " ++ cabalFileName ++ "..." - writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) - return True - --- | Write a file \"safely\", backing up any existing version (unless --- the overwrite flag is set). -writeFileSafe :: InitFlags -> FilePath -> String -> IO () -writeFileSafe flags fileName content = do - moveExistingFile flags fileName - writeFile fileName content - --- | Create directories, if they were given, and don't already exist. -createDirectories :: Maybe [String] -> IO () -createDirectories mdirs = case mdirs of - Just dirs -> for_ dirs (createDirectoryIfMissing True) - Nothing -> return () - --- | Create MyLib.hs file, if its the only module in the liste. -createLibHs :: InitFlags -> IO () -createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do - let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" - case sourceDirs flags of - Just (srcPath:_) -> writeLibHs flags (srcPath modFilePath) - _ -> writeLibHs flags modFilePath - --- | Write a MyLib.hs file if it doesn't already exist. -writeLibHs :: InitFlags -> FilePath -> IO () -writeLibHs flags libPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let libFullPath = dir libPath - exists <- doesFileExist libFullPath - unless exists $ do - message flags $ "Generating " ++ libPath ++ "..." - writeFileSafe flags libFullPath myLibHs - --- | Default MyLib.hs file. Used when no Lib.hs exists. -myLibHs :: String -myLibHs = unlines - [ "module MyLib (someFunc) where" - , "" - , "someFunc :: IO ()" - , "someFunc = putStrLn \"someFunc\"" - ] - --- | Create Main.hs, but only if we are init'ing an executable and --- the mainIs flag has been provided. -createMainHs :: InitFlags -> IO () -createMainHs flags = - if hasMainHs flags then - case applicationDirs flags of - Just (appPath:_) -> writeMainHs flags (appPath mainFile) - _ -> writeMainHs flags mainFile - else return () - where - mainFile = case mainIs flags of - Flag x -> x - NoFlag -> error "createMainHs: no mainIs" - --- | Write a main file if it doesn't already exist. -writeMainHs :: InitFlags -> FilePath -> IO () -writeMainHs flags mainPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let mainFullPath = dir mainPath - exists <- doesFileExist mainFullPath - unless exists $ do - message flags $ "Generating " ++ mainPath ++ "..." - writeFileSafe flags mainFullPath (mainHs flags) - --- | Returns true if a main file exists. -hasMainHs :: InitFlags -> Bool -hasMainHs flags = case mainIs flags of - Flag _ -> (packageType flags == Flag Executable - || packageType flags == Flag LibraryAndExecutable) - _ -> False - --- | Default Main.(l)hs file. Used when no Main.(l)hs exists. --- --- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. -mainHs :: InitFlags -> String -mainHs flags = (unlines . map prependPrefix) $ case packageType flags of - Flag LibraryAndExecutable -> - [ "module Main where" - , "" - , "import qualified MyLib (someFunc)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Hello, Haskell!\"" - , " MyLib.someFunc" - ] - _ -> - [ "module Main where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Hello, Haskell!\"" - ] - where - prependPrefix :: String -> String - prependPrefix "" = "" - prependPrefix line - | isLiterate = "> " ++ line - | otherwise = line - isLiterate = case mainIs flags of - Flag mainPath -> takeExtension mainPath == ".lhs" - _ -> False - --- | Create a test suite for the package if eligible. -createTestSuiteIfEligible :: InitFlags -> IO () -createTestSuiteIfEligible flags = - when (eligibleForTestSuite flags) $ do - createDirectories (testDirs flags) - createTestHs flags - --- | The name of the test file to generate (if --tests is specified). -testFile :: String -testFile = "MyLibTest.hs" - --- | Create MyLibTest.hs, but only if we are init'ing a library and --- the initializeTestSuite flag has been set. --- --- It is up to the caller to verify that the package is eligible --- for test suite initialization (see eligibleForTestSuite). -createTestHs :: InitFlags -> IO () -createTestHs 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 () -moveExistingFile flags fileName = - unless (overwrite flags == Flag True) $ do - e <- doesFileExist fileName - when e $ do - newName <- findNewName fileName - message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName - copyFile fileName newName - - --- | Given a file path find a new name for the file that does not --- already exist. -findNewName :: FilePath -> IO FilePath -findNewName oldName = findNewName' 0 +-- -------------------------------------------------------------------- -- +-- Utilities + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: Interactive m => WriteOpts -> String -> m () +message opts = T.message (_optVerbosity opts) + +-- | Write a file \"safely\" if it doesn't exist, backing up any existing version when +-- the overwrite flag is set. +writeFileSafe :: WriteOpts -> FilePath -> String -> IO () +writeFileSafe opts fileName content = do + litExists <- doesFileExist fileName + moveExistingFile litExists + + when (doOverwrite || not litExists) $ + writeFile fileName content where - findNewName' :: Integer -> IO FilePath - findNewName' n = do + doOverwrite = _optOverwrite opts + + moveExistingFile exists + | exists && doOverwrite = do + newName <- findNewName fileName (0 :: Int) + message opts $ concat + [ "Warning: " + , fileName + , " already exists. Backing up old version in " + , newName + ] + + copyFile fileName newName + | exists && not doOverwrite = message opts $ concat + [ "Warning: " + , fileName + , " already exists. Skipping..." + ] + | otherwise = return () + + findNewName oldName n = do let newName = oldName <.> ("save" ++ show n) e <- doesFileExist newName - if e then findNewName' (n+1) else return newName - - --- | Generate a .cabal file from an InitFlags structure. -generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = - showFields' annCommentLines postProcessFieldLines 4 $ catMaybes - [ fieldP "cabal-version" (Flag . SpecVersion $ specVer) - [] - False - - , field "name" (packageName c) - ["Initial package description '" ++ fileName ++ "' generated by", - "'cabal init'. For further documentation, see:", - " http://haskell.org/cabal/users-guide/", - "", - "The name of the package."] - True - - , field "version" (version c) - ["The package version.", - "See the Haskell package versioning policy (PVP) for standards", - "guiding when and how versions should be incremented.", - "https://pvp.haskell.org", - "PVP summary: +-+------- breaking API changes", - " | | +----- non-breaking API additions", - " | | | +--- code changes with no API change"] - True - - , fieldS "synopsis" (synopsis c) - ["A short (one-line) description of the package."] - True - - , fieldS "description" NoFlag - ["A longer description of the package."] - True - - , fieldS "homepage" (homepage c) - ["URL for the project homepage or repository."] - False - - , fieldS "bug-reports" NoFlag - ["A URL where users can report bugs."] - True - - , fieldS "license" licenseStr - ["The license under which the package is released."] - True - - , case license c of - NoFlag -> Nothing - Flag SPDX.NONE -> Nothing - _ -> fieldS "license-file" (Flag "LICENSE") - ["The file containing the license text."] - True - - , fieldS "author" (author c) - ["The package author(s)."] - True - - , fieldS "maintainer" (email c) - ["An email address to which users can send suggestions, bug reports, and patches."] - True - - , fieldS "copyright" NoFlag - ["A copyright notice."] - True - - , fieldS "category" (either id prettyShow `fmap` category c) - [] - True - - , fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple") - [] - False - - , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c)) - ["Extra files to be distributed with the package, such as examples or a README."] - True - ] - ++ - (case packageType c of - Flag Executable -> [executableStanza] - Flag Library -> [libraryStanza] - Flag LibraryAndExecutable -> [libraryStanza, executableStanza] - _ -> []) - ++ - if eligibleForTestSuite c then [testSuiteStanza] else [] + if e then findNewName oldName (n+1) else return newName - where - specVer :: CabalSpecVersion - specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) - - licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c - | otherwise = prettyShow <$> license c - - generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation] - generateBuildInfo buildType c' = catMaybes - [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods) - [ case buildType of - LibBuild -> "Modules included in this library but not exported." - ExecBuild -> "Modules included in this executable, other than Main."] - True - - , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c)) - ["LANGUAGE extensions used by modules in this package."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies) - ["Other library packages from which modules are imported."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ case buildType of - LibBuild -> sourceDirs c - ExecBuild -> applicationDirs c) - ["Directories containing source files."] - True - - , fieldS "build-tools" (listFieldS $ buildTools c) - ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] - False - - , field "default-language" (language c) - ["Base language which the package is written in."] - True - ] - -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). - where - buildDependencies :: Maybe [Dependency] - buildDependencies = (++ myLibDep) <$> dependencies c' - - myLibDep :: [Dependency] - myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild - then case packageName c' of - Flag pkgName -> - [mkDependency pkgName anyVersion mainLibSet] - _ -> [] - else [] - - -- Only include 'MyLib' in 'other-modules' of the executable. - otherModsFromFlag = otherModules c' - otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] - then Nothing - else otherModsFromFlag - - listFieldS :: Maybe [String] -> Flag String - listFieldS Nothing = NoFlag - listFieldS (Just []) = NoFlag - listFieldS (Just xs) = Flag . intercalate ", " $ xs - - -- | Construct a 'PrettyField' from a field that can be automatically - -- converted to a 'Doc' via 'display'. - field :: Pretty t - => FieldName - -> Flag t - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a 'String' field. - fieldS :: FieldName -- ^ Name of the field - -> Flag String -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied. - fieldP :: Pretty a - => FieldName - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldP fieldName fieldContentsFlag fieldComments includeField = - fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField - - -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper. - fieldPAla - :: (Pretty b, Newtype a b) - => FieldName - -> (a -> b) - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField = - fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField - - -- | Construct a 'PrettyField' from a 'Doc' Flag. - fieldD :: FieldName -- ^ Name of the field - -> Flag Doc -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldD fieldName fieldContentsFlag fieldComments includeField = - case fieldContentsFlag of - NoFlag -> - -- If there is no content, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - - Flag fieldContents -> - if isEmpty fieldContents - then - -- If the doc is empty, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - else - -- If the doc is not empty, produce a field. - Just $ case (noComments c, minimal c) of - -- If the "--no-comments" flag is set, strip comments. - (Flag True, _) -> - fieldSWithContents fieldName fieldContents [] - -- If the "--minimal" flag is set, strip comments. - (_, Flag True) -> - fieldSWithContents fieldName fieldContents [] - -- Otherwise, include comments. - (_, _) -> - fieldSWithContents fieldName fieldContents fieldComments - - -- | Optionally produce a field with no content (depending on flags). - fieldSEmptyContents :: FieldName - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldSEmptyContents fieldName fieldComments includeField - | not includeField || (minimal c == Flag True) = - Nothing - | otherwise = - Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty) - - -- | Produce a field with content. - fieldSWithContents :: FieldName - -> Doc - -> [String] - -> PrettyField FieldAnnotation - fieldSWithContents fieldName fieldContents fieldComments = - PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents - - executableStanza :: PrettyField FieldAnnotation - executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes - [ fieldS "main-is" (mainIs c) - [".hs or .lhs file containing the Main module."] - True - ] - ++ - generateBuildInfo ExecBuild c - where - exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c) - - libraryStanza :: PrettyField FieldAnnotation - libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes - [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c)) - ["Modules exported by the library."] - True - ] - ++ - generateBuildInfo LibBuild c - - - testSuiteStanza :: PrettyField FieldAnnotation - testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes - [ field "default-language" (language c) - ["Base language which the package is written in."] - True - - , fieldS "type" (Flag "exitcode-stdio-1.0") - ["The interface type and version of the test suite."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ testDirs c) -- TODO - ["Directories containing source files."] - True - - , fieldS "main-is" (Flag testFile) - ["The entrypoint to the test suite."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag (dependencies c)) - ["Test dependencies."] - True - ] - where - testSuiteName = - text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c) - --- | Annotations for cabal file PrettyField. -data FieldAnnotation = FieldAnnotation - { annCommentedOut :: Bool - -- ^ True iif the field and its contents should be commented out. - , annCommentLines :: [String] - -- ^ Comment lines to place before the field or section. - } - --- | A field annotation instructing the pretty printer to comment out the field --- and any contents, with no comments. -commentedOutWithComments :: [String] -> FieldAnnotation -commentedOutWithComments = FieldAnnotation True . map ("-- " ++) - --- | A field annotation with the specified comment lines. -withComments :: [String] -> FieldAnnotation -withComments = FieldAnnotation False - --- | A field annotation with no comments. -annNoComments :: FieldAnnotation -annNoComments = FieldAnnotation False [] - -postProcessFieldLines :: FieldAnnotation -> [String] -> [String] -postProcessFieldLines ann - | annCommentedOut ann = map ("-- " ++) - | otherwise = id +writeDirectoriesSafe :: WriteOpts -> [String] -> IO () +writeDirectoriesSafe opts dirs = for_ dirs $ \dir -> do + exists <- doesDirectoryExist dir + moveExistingDir dir exists + + let action = if doOverwrite + then "Overwriting" + else "Creating or using already existing" + + message opts $ action ++ " directory ./" ++ dir ++ "..." + unless exists $ + createDirectory dir + where + doOverwrite = _optOverwrite opts + + moveExistingDir oldDir exists + | exists && doOverwrite = do + newDir <- findNewDir oldDir (0 :: Int) + message opts $ concat + [ "Warning: " + , oldDir + , " already exists. Backing up old version in " + , newDir + ] + + renameDirectory oldDir newDir + | exists && doOverwrite = removeDirectoryRecursive oldDir + | otherwise = return () + + findNewDir oldDir n = do + let newDir = oldDir <.> ("save" ++ show n) + e <- doesDirectoryExist newDir + if e then findNewDir oldDir (n+1) else return newDir diff --git a/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs new file mode 100644 index 00000000000..bf67c323c3a --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.Init.FlagExtractors +( -- * Flag extractors + getPackageDir +, getSimpleProject +, getMinimal +, getCabalVersion +, getPackageName +, getVersion +, getLicense +, getAuthor +, getEmail +, getHomepage +, getSynopsis +, getCategory +, getExtraSrcFiles +, getPackageType +, getMainFile +, getInitializeTestSuite +, getTestDirs +, getLanguage +, getNoComments +, getAppDirs +, getSrcDirs +, getExposedModules +, getBuildTools +, getDependencies +, getOtherExts +, getOverwrite +, getOtherModules + -- * Shared prompts +, simpleProjectPrompt +, initializeTestSuitePrompt +, packageTypePrompt +, testMainPrompt +) where + + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) + +import qualified Data.List.NonEmpty as NEL + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.PackageName (PackageName) +import qualified Distribution.SPDX as SPDX +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Types +import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe) +import Distribution.Simple.Flag (flagElim) + +import Language.Haskell.Extension (Language(..), Extension(..)) +import Distribution.Client.Init.Prompt + + + +-- -------------------------------------------------------------------- -- +-- Flag extraction + +getPackageDir :: Interactive m => InitFlags -> m FilePath +getPackageDir = flagElim getCurrentDirectory return . packageDir + +-- | Ask if a simple project with sensible defaults should be created. +getSimpleProject :: Interactive m => InitFlags -> m Bool -> m Bool +getSimpleProject flags = fromFlagOrPrompt (simpleProject flags) + +-- | Extract minimal cabal file flag (implies nocomments) +getMinimal :: Interactive m => InitFlags -> m Bool +getMinimal = return . fromFlagOrDefault False . minimal + +-- | Get the version of the cabal spec to use. +-- +-- The spec version can be specified by the InitFlags cabalVersion field. If +-- none is specified then the user is prompted to pick from a list of +-- supported versions (see code below). +getCabalVersion :: Interactive m => InitFlags -> m CabalSpecVersion -> m CabalSpecVersion +getCabalVersion flags = fromFlagOrPrompt (cabalVersion flags) + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. It looks at the SourcePackageDb to avoid +-- using an existing package name. +getPackageName :: Interactive m => InitFlags -> m PackageName -> m PackageName +getPackageName flags = fromFlagOrPrompt (packageName flags) + +-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user +-- if possible. +getVersion :: Interactive m => InitFlags -> m Version -> m Version +getVersion flags = fromFlagOrPrompt (version flags) + +-- | Choose a license for the package. +-- The license can come from Initflags (license field), if it is not present +-- then prompt the user from a predefined list of licenses. +getLicense :: Interactive m => InitFlags -> m SPDX.License -> m SPDX.License +getLicense flags = fromFlagOrPrompt (license flags) + +-- | The author's name. Prompt, or try to guess from an existing +-- darcs repo. +getAuthor :: Interactive m => InitFlags -> m String -> m String +getAuthor flags = fromFlagOrPrompt (author flags) + +-- | The author's email. Prompt, or try to guess from an existing +-- darcs repo. +getEmail :: Interactive m => InitFlags -> m String -> m String +getEmail flags = fromFlagOrPrompt (email flags) + +-- | Prompt for a homepage URL for the package. +getHomepage :: Interactive m => InitFlags -> m String -> m String +getHomepage flags = fromFlagOrPrompt (homepage flags) + +-- | Prompt for a project synopsis. +getSynopsis :: Interactive m => InitFlags -> m String -> m String +getSynopsis flags = fromFlagOrPrompt (synopsis flags) + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: Interactive m => InitFlags -> m String -> m String +getCategory flags = fromFlagOrPrompt (category flags) + +-- | Try to guess extra source files (don't prompt the user). +getExtraSrcFiles :: Interactive m => InitFlags -> m (NonEmpty String) +getExtraSrcFiles = pure + . flagElim (defaultChangelog NEL.:| []) NEL.fromList + . extraSrc + +-- | Ask whether the project builds a library or executable. +getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType +getPackageType flags = fromFlagOrPrompt (packageType flags) + +getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath +getMainFile flags act = case mainIs flags of + Flag a + | isHsFilePath a -> return $ toHsFilePath a + | otherwise -> act + NoFlag -> act + +getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool +getInitializeTestSuite flags = fromFlagOrPrompt (initializeTestSuite flags) + +getTestDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getTestDirs flags = fromFlagOrPrompt (testDirs flags) + +-- | Ask for the Haskell base language of the package. +getLanguage :: Interactive m => InitFlags -> m Language -> m Language +getLanguage flags = fromFlagOrPrompt (language flags) + +-- | Ask whether to generate explanatory comments. +getNoComments :: Interactive m => InitFlags -> m Bool -> m Bool +getNoComments flags = fromFlagOrPrompt (noComments flags) + +-- | Ask for the application root directory. +getAppDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getAppDirs flags = fromFlagOrPrompt (applicationDirs flags) + +-- | Ask for the source (library) root directory. +getSrcDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getSrcDirs flags = fromFlagOrPrompt (sourceDirs flags) + +-- | Retrieve the list of exposed modules +getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName) +getExposedModules = return + . fromMaybe (myLibModule NEL.:| []) + . join + . flagToMaybe + . fmap NEL.nonEmpty + . exposedModules + +-- | Retrieve the list of other modules +getOtherModules :: Interactive m => InitFlags -> m [ModuleName] +getOtherModules = return . fromFlagOrDefault [] . otherModules + +-- | Retrieve the list of build tools +getBuildTools :: Interactive m => InitFlags -> m [String] +getBuildTools = return . fromFlagOrDefault [] . buildTools + +-- | Retrieve the list of dependencies +getDependencies + :: Interactive m + => InitFlags + -> m [Dependency] + -> m [Dependency] +getDependencies flags = fromFlagOrPrompt (dependencies flags) + + +-- | Retrieve the list of extensions +getOtherExts :: Interactive m => InitFlags -> m [Extension] +getOtherExts = return . fromFlagOrDefault [] . otherExts + +-- | Tell whether to overwrite files on write +-- +getOverwrite :: Interactive m => InitFlags -> m Bool +getOverwrite = return . fromFlagOrDefault False . overwrite + +-- -------------------------------------------------------------------- -- +-- Shared prompts + +simpleProjectPrompt :: Interactive m => InitFlags -> m Bool +simpleProjectPrompt flags = getSimpleProject flags $ + promptYesNo + "Should I generate a simple project with sensible defaults" + (Just True) + +initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool +initializeTestSuitePrompt flags = getInitializeTestSuite flags $ + promptYesNo + "Should I generate a test suite for the library" + (Just True) + +packageTypePrompt :: Interactive m => InitFlags -> m PackageType +packageTypePrompt flags = getPackageType flags $ do + pt <- promptList "What does the package build" + packageTypes + (Just "Executable") + Nothing + False + + return $ fromMaybe Executable (parsePackageType pt) + where + packageTypes = + [ "Library" + , "Executable" + , "Library and Executable" + ] + + parsePackageType = \case + "Library" -> Just Library + "Executable" -> Just Executable + "Library and Executable" -> Just LibraryAndExecutable + _ -> Nothing + +testMainPrompt :: Interactive m => m HsFilePath +testMainPrompt = do + fp <- promptList "What is the main module of the test suite?" + [defaultMainIs', "Main.lhs"] + (Just defaultMainIs') + Nothing + True + + let hs = toHsFilePath fp + + case _hsFileType hs of + InvalidHsPath -> do + putStrLn $ concat + [ "Main file " + , show hs + , " is not a valid haskell file. Source files must end in .hs or .lhs." + ] + testMainPrompt + _ -> return hs + where + defaultMainIs' = show defaultMainIs + +-- -------------------------------------------------------------------- -- +-- utilities + +-- | If a flag is defined, return its value or else execute +-- an interactive action. +-- +fromFlagOrPrompt + :: Interactive m + => Flag a + -> m a + -> m a +fromFlagOrPrompt flag action = flagElim action return flag diff --git a/cabal-install/src/Distribution/Client/Init/Format.hs b/cabal-install/src/Distribution/Client/Init/Format.hs new file mode 100644 index 00000000000..cc5906fb66c --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/Format.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Distribution.Client.Init.Format +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Pretty printing and field formatting utilities used for file creation. +-- +module Distribution.Client.Init.Format +( -- * cabal file formatters + listFieldS +, field +, fieldD +, commentedOutWithComments +, withComments +, annNoComments +, postProcessFieldLines + -- * stanza generation +, mkLibStanza +, mkExeStanza +, mkTestStanza +, mkPkgDescription +) where + + +import Distribution.Pretty +import Distribution.Fields +import Distribution.Client.Init.Types +import Text.PrettyPrint +import Distribution.Solver.Compat.Prelude hiding (empty) +import Distribution.PackageDescription.FieldGrammar +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Package (unPackageName) +import qualified Distribution.SPDX.License as SPDX +import Distribution.CabalSpecVersion + + +-- | Construct a 'PrettyField' from a field that can be automatically +-- converted to a 'Doc' via 'display'. +field + :: Pretty b + => FieldName + -> (a -> b) + -> a + -> [String] + -> Bool + -> WriteOpts + -> PrettyField FieldAnnotation +field fieldName modifier fieldContents = + fieldD fieldName (pretty $ modifier fieldContents) + +-- | Construct a 'PrettyField' from a 'Doc' Flag. +fieldD + :: FieldName -- ^ Name of the field + -> Doc -- ^ Field contents + -> [String] -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> WriteOpts + -> PrettyField FieldAnnotation +fieldD fieldName fieldContents fieldComments includeField opts + | fieldContents == empty = + -- If there is no content, optionally produce a commented out field. + fieldSEmptyContents fieldComments + | otherwise = + -- If the "--no-comments" flag is set, strip comments. + let comments = if hasNoComments + then [] + else fieldComments + + -- If the "--minimal" flag is set, strip comments. + in fieldSWithContents comments + where + isMinimal = _optMinimal opts + hasNoComments = _optNoComments opts + + fieldSEmptyContents cs + | not includeField || isMinimal = PrettyEmpty + | otherwise = PrettyField + (commentedOutWithComments cs) + fieldName + empty + + fieldSWithContents cs = + PrettyField (withComments (map ("-- " ++) cs)) fieldName fieldContents + + +-- | A field annotation instructing the pretty printer to comment out the field +-- and any contents, with no comments. +commentedOutWithComments :: [String] -> FieldAnnotation +commentedOutWithComments = FieldAnnotation True . map ("-- " ++) + +-- | A field annotation with the specified comment lines. +withComments :: [String] -> FieldAnnotation +withComments = FieldAnnotation False + +-- | A field annotation with no comments. +annNoComments :: FieldAnnotation +annNoComments = FieldAnnotation False [] + +postProcessFieldLines :: FieldAnnotation -> [String] -> [String] +postProcessFieldLines ann + | annCommentedOut ann = fmap ("-- " ++) + | otherwise = id + +-- -------------------------------------------------------------------- -- +-- Stanzas + +mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation +mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "library") [] + [ field "exposed-modules" formatExposedModules (toList expMods) + ["Modules exported by the library."] + True + opts + + , field "other-modules" formatOtherModules otherMods + ["Modules included in this library but not exported."] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + + , field "build-depends" formatDependencyList deps + ["Other library packages from which modules are imported."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs (unsafeMakeSymbolicPath <$> srcDirs) + ["Directories containing source files."] + True + opts + + , field "build-tools" listFieldS tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + + , field "default-language" id lang + ["Base language which the package is written in."] + True + opts + ] + +mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation +mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "executable") [exeName] + [ field "main-is" unsafeFromHs exeMain + [".hs or .lhs file containing the Main module."] + True + opts + + , field "other-modules" formatOtherModules otherMods + [ "Modules included in this executable, other than Main." ] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + , field "build-depends" formatDependencyList deps + ["Other library packages from which modules are imported."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs + (unsafeMakeSymbolicPath <$> appDirs) + ["Directories containing source files."] + True + opts + + , field "build-tools" listFieldS tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + + , field "default-language" id lang + ["Base language which the package is written in."] + True + opts + ] + where + exeName = pretty $ _optPkgName opts + + +mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation +mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "test-suite") [suiteName] + [ field "default-language" id lang + ["Base language which the package is written in."] + True + opts + , field "other-modules" formatOtherModules otherMods + [ "Modules included in this executable, other than Main." ] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + + , field "type" text "exitcode-stdio-1.0" + ["The interface type and version of the test suite."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs + (unsafeMakeSymbolicPath <$> dirs) + ["Directories containing source files."] + True + opts + + , field "main-is" unsafeFromHs testMain + ["The entrypoint to the test suite."] + True + opts + + , field "build-depends" formatDependencyList deps + ["Test dependencies."] + True + opts + + , field "build-tools" listFieldS tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + ] + where + suiteName = text $ unPackageName (_optPkgName opts) ++ "-test" + +mkPkgDescription :: WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation] +mkPkgDescription opts pkgDesc = + [ field "cabal-version" text (showCabalSpecVersion cabalSpec) [] False opts + , field "name" pretty (_pkgName pkgDesc) + ["Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by" + , "'cabal init'. For further documentation, see:" + , " http://haskell.org/cabal/users-guide/" + , "" + , "The name of the package." + ] + True + opts + + , field "version" pretty (_pkgVersion pkgDesc) + ["The package version.", + "See the Haskell package versioning policy (PVP) for standards", + "guiding when and how versions should be incremented.", + "https://pvp.haskell.org", + "PVP summary: +-+------- breaking API changes", + " | | +----- non-breaking API additions", + " | | | +--- code changes with no API change"] + True + opts + + , field "synopsis" text (_pkgSynopsis pkgDesc) + ["A short (one-line) description of the package."] + True + opts + + , field "description" text "" + ["A longer description of the package."] + True + opts + + , field "homepage" text (_pkgHomePage pkgDesc) + ["URL for the project homepage or repository."] + False + opts + + , field "bug-reports" text "" + ["A URL where users can report bugs."] + False + opts + + , field "license" pretty (_pkgLicense pkgDesc) + ["The license under which the package is released."] + True + opts + + , case _pkgLicense pkgDesc of + SPDX.NONE -> PrettyEmpty + _ -> field "license-file" text "LICENSE" + ["The file containing the license text."] + False + opts + + , field "author" text (_pkgAuthor pkgDesc) + ["The package author(s)."] + True + opts + + , field "maintainer" text (_pkgEmail pkgDesc) + ["An email address to which users can send suggestions, bug reports, and patches."] + True + opts + + , field "copyright" text "" + ["A copyright notice."] + True + opts + + , field "category" text (_pkgCategory pkgDesc) + [] + False + opts + , if cabalSpec < CabalSpecV2_2 + then PrettyEmpty + else field "build-type" text "Simple" + [] + False + opts + + , field "extra-source-files" formatExtraSourceFiles (toList $ _pkgExtraSrcFiles pkgDesc) + ["Extra files to be distributed with the package, such as examples or a README."] + True + opts + ] + where + cabalSpec = _pkgCabalVersion pkgDesc + +-- -------------------------------------------------------------------- -- +-- Utils + +listFieldS :: [String] -> Doc +listFieldS = text . intercalate ", " + + +unsafeFromHs :: HsFilePath -> Doc +unsafeFromHs = text . _hsFilePath diff --git a/cabal-install/src/Distribution/Client/Init/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/Heuristics.hs deleted file mode 100644 index f561af091fa..00000000000 --- a/cabal-install/src/Distribution/Client/Init/Heuristics.hs +++ /dev/null @@ -1,396 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Heuristics --- Copyright : (c) Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Heuristics ( - guessPackageName, - scanForModules, SourceFileEntry(..), - neededBuildPrograms, - guessMainFileCandidates, - guessAuthorNameMail, - knownCategories, -) where - -import Prelude () -import qualified Data.ByteString as BS -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeHead, safeTail, safeLast) - -import Distribution.Simple.Setup (Flag(..), flagToMaybe) -import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import qualified Distribution.Package as P -import qualified Distribution.PackageDescription as PD - ( category, packageDescription ) -import Distribution.Client.Utils - ( tryCanonicalizePath ) -import Language.Haskell.Extension ( Extension ) - -import Distribution.Solver.Types.PackageIndex - ( allPackagesByName ) -import Distribution.Solver.Types.SourcePackage - ( srcpkgDescription ) - -import Distribution.Client.Types ( SourcePackageDb(..) ) -import Data.Char ( isLower ) -import Data.List ( isInfixOf ) -import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getCurrentDirectory, getDirectoryContents, - doesDirectoryExist, doesFileExist, getHomeDirectory, ) -import Distribution.Compat.Environment ( getEnvironment ) -import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), (<.>), splitDirectories, makeRelative ) - -import Distribution.Client.Init.Types ( InitFlags(..) ) -import Distribution.Client.Compat.Process ( readProcessWithExitCode ) - -import qualified Distribution.Utils.ShortText as ShortText - --- | Return a list of candidate main files for this executable: top-level --- modules including the word 'Main' in the file name. The list is sorted in --- order of preference, shorter file names are preferred. 'Right's are existing --- candidates and 'Left's are those that do not yet exist. -guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath] -guessMainFileCandidates flags = do - dir <- - maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - files <- getDirectoryContents dir - let existingCandidates = filter isMain files - -- We always want to give the user at least one default choice. If either - -- Main.hs or Main.lhs has already been created, then we don't want to - -- suggest the other; however, if neither has been created, then we - -- suggest both. - newCandidates = - if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"] - then [] - else ["Main.hs", "Main.lhs"] - candidates = - sortBy (\x y -> comparing (length . either id id) x y - `mappend` compare x y) - (map Left newCandidates ++ map Right existingCandidates) - return candidates - - where - isMain f = (isInfixOf "Main" f || isInfixOf "main" f) - && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f) - --- | Guess the package name based on the given root directory. -guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) - . tryCanonicalizePath - where - -- Treat each span of non-alphanumeric characters as a hyphen. Each - -- hyphenated component of a package name must contain at least one - -- alphabetic character. An arbitrary character ('x') will be prepended if - -- this is not the case for the first component, and subsequent components - -- will simply be run together. For example, "1+2_foo-3" will become - -- "x12-foo3". - repair = repair' ('x' :) id - repair' invalid valid x = case dropWhile (not . isAlphaNum) x of - "" -> repairComponent "" - x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' - in c ++ repairRest r - where - repairComponent c | all isDigit c = invalid c - | otherwise = valid c - repairRest = repair' id ('-' :) - --- |Data type of source files found in the working directory -data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - , imports :: [ModuleName] - , extensions :: [Extension] - } deriving Show - -sfToFileName :: FilePath -> SourceFileEntry -> FilePath -sfToFileName projectRoot (SourceFileEntry relPath m ext _ _) - = projectRoot relPath toFilePath m <.> ext - --- |Search for source files in the given directory --- and return pairs of guessed Haskell source path and --- module names. -scanForModules :: FilePath -> IO [SourceFileEntry] -scanForModules rootDir = scanForModulesIn rootDir rootDir - -scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] -scanForModulesIn projectRoot srcRoot = scan srcRoot [] - where - scan dir hierarchy = do - entries <- getDirectoryContents (projectRoot dir) - (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries) - let modules = catMaybes [ guessModuleName hierarchy file - | file <- files - , maybe False isUpper (safeHead file) ] - modules' <- traverse (findImportsAndExts projectRoot) modules - recMods <- traverse (scanRecursive dir hierarchy) dirs - return $ concat (modules' : recMods) - tagIsDir parent entry = do - isDir <- doesDirectoryExist (parent entry) - return $ (if isDir then Right else Left) entry - guessModuleName hierarchy entry - | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = - SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure [] - | otherwise = Nothing - where - relRoot = makeRelative projectRoot srcRoot - unqualModName = dropExtension entry - modName = simpleParsec - $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e - scanRecursive parent hierarchy entry - | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) - | maybe False isLower (safeHead entry) && not (ignoreDir entry) = - scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) - | otherwise = return [] - ignoreDir ('.':_) = True - ignoreDir dir = dir `elem` ["dist", "_darcs"] - --- | Read the contents of the handle and parse for Language pragmas --- and other module names that might be part of this project. -findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry -findImportsAndExts projectRoot sf = do - s <- fromUTF8BS <$> BS.readFile (sfToFileName projectRoot sf) - - let modules = mapMaybe - ( getModName - . drop 1 - . filter (not . null) - . dropWhile (/= "import") - . words - ) - . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering - . lines - $ s - - -- TODO: We should probably make a better attempt at parsing - -- comments above. Unfortunately we can't use a full-fledged - -- Haskell parser since cabal's dependencies must be kept at a - -- minimum. - - -- A poor man's LANGUAGE pragma parser. - exts = mapMaybe simpleParsec - . concatMap getPragmas - . filter isLANGUAGEPragma - . map fst - . drop 1 - . takeWhile (not . null . snd) - . iterate (takeBraces . snd) - $ ("",s) - - takeBraces = break (== '}') . dropWhile (/= '{') - - isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`) - - getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13 - - splitCommas "" = [] - splitCommas xs = x : splitCommas (drop 1 y) - where (x,y) = break (==',') xs - - return sf { imports = modules - , extensions = exts - } - - where getModName :: [String] -> Maybe ModuleName - getModName [] = Nothing - getModName ("qualified":ws) = getModName ws - getModName (ms:_) = simpleParsec ms - - - --- Unfortunately we cannot use the version exported by Distribution.Simple.Program -knownSuffixHandlers :: [(String,String)] -knownSuffixHandlers = - [ ("gc", "greencard") - , ("chs", "chs") - , ("hsc", "hsc2hs") - , ("x", "alex") - , ("y", "happy") - , ("ly", "happy") - , ("cpphs", "cpp") - ] - -sourceExtensions :: [String] -sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers - -neededBuildPrograms :: [SourceFileEntry] -> [String] -neededBuildPrograms entries = - [ handler - | ext <- nubSet (map fileExtension entries) - , handler <- maybeToList (lookup ext knownSuffixHandlers) - ] - --- | Guess author and email using darcs and git configuration options. Use --- the following in decreasing order of preference: --- --- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*) --- 2. Local repo configs --- 3. Global vcs configs --- 4. The generic $EMAIL --- --- Name and email are processed separately, so the guess might end up being --- a name from DARCS_EMAIL and an email from git config. --- --- Darcs has preference, for tradition's sake. -guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = fmap authorGuessPure authorGuessIO - --- Ordered in increasing preference, since Flag-as-monoid is identical to --- Last. -authorGuessPure :: AuthorGuessIO -> AuthorGuess -authorGuessPure (AuthorGuessIO { authorGuessEnv = env - , authorGuessLocalDarcs = darcsLocalF - , authorGuessGlobalDarcs = darcsGlobalF - , authorGuessLocalGit = gitLocal - , authorGuessGlobalGit = gitGlobal }) - = mconcat - [ emailEnv env - , gitGlobal - , darcsCfg darcsGlobalF - , gitLocal - , darcsCfg darcsLocalF - , gitEnv env - , darcsEnv env - ] - -authorGuessIO :: IO AuthorGuessIO -authorGuessIO = AuthorGuessIO - <$> getEnvironment - <*> (maybeReadFile $ "_darcs" "prefs" "author") - <*> (maybeReadFile =<< liftM ( (".darcs" "author")) getHomeDirectory) - <*> gitCfg Local - <*> gitCfg Global - --- Types and functions used for guessing the author are now defined: - -type AuthorGuess = (Flag String, Flag String) -type Enviro = [(String, String)] -data GitLoc = Local | Global -data AuthorGuessIO = AuthorGuessIO { - authorGuessEnv :: Enviro, -- ^ Environment lookup table - authorGuessLocalDarcs :: (Maybe String), -- ^ Contents of local darcs author info - authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info - authorGuessLocalGit :: AuthorGuess, -- ^ Git config --local - authorGuessGlobalGit :: AuthorGuess -- ^ Git config --global - } - -darcsEnv :: Enviro -> AuthorGuess -darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" - -gitEnv :: Enviro -> AuthorGuess -gitEnv env = (name, mail) - where - name = maybeFlag "GIT_AUTHOR_NAME" env - mail = maybeFlag "GIT_AUTHOR_EMAIL" env - -darcsCfg :: Maybe String -> AuthorGuess -darcsCfg = maybe mempty nameAndMail - -emailEnv :: Enviro -> AuthorGuess -emailEnv env = (mempty, mail) - where - mail = maybeFlag "EMAIL" env - -gitCfg :: GitLoc -> IO AuthorGuess -gitCfg which = do - name <- gitVar which "user.name" - mail <- gitVar which "user.email" - return (name, mail) - -gitVar :: GitLoc -> String -> IO (Flag String) -gitVar which = fmap happyOutput . gitConfigQuery which - -happyOutput :: (ExitCode, a, t) -> Flag a -happyOutput v = case v of - (ExitSuccess, s, _) -> Flag s - _ -> mempty - -gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String) -gitConfigQuery which key = - fmap trim' $ readProcessWithExitCode "git" ["config", w, key] "" - where - w = case which of - Local -> "--local" - Global -> "--global" - trim' (a, b, c) = (a, trim b, c) - -maybeFlag :: String -> Enviro -> Flag String -maybeFlag k = maybe mempty Flag . lookup k - --- | Read the first non-comment, non-trivial line of a file, if it exists -maybeReadFile :: String -> IO (Maybe String) -maybeReadFile f = do - exists <- doesFileExist f - if exists - then fmap getFirstLine $ readFile f - else return Nothing - where - getFirstLine content = - let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content - in case nontrivialLines of - [] -> Nothing - (l:_) -> Just l - --- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached -knownCategories :: SourcePackageDb -> [String] -knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet - [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) - , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg - , cat <- splitString ',' $ ShortText.fromShortText catList - ] - --- Parse name and email, from darcs pref files or environment variable -nameAndMail :: String -> (Flag String, Flag String) -nameAndMail str - | all isSpace nameOrEmail = mempty - | null erest = (mempty, Flag $ trim nameOrEmail) - | otherwise = (Flag $ trim nameOrEmail, Flag mail) - where - (nameOrEmail,erest) = break (== '<') str - (mail,_) = break (== '>') (safeTail erest) - -trim :: String -> String -trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse - where - removeLeadingSpace = dropWhile isSpace - --- split string at given character, and remove whitespace -splitString :: Char -> String -> [String] -splitString sep str = go str where - go s = if null s' then [] else tok : go rest where - s' = dropWhile (\c -> c == sep || isSpace c) s - (tok,rest) = break (==sep) s' - -nubSet :: (Ord a) => [a] -> [a] -nubSet = Set.toList . Set.fromList - -{- -test db testProjectRoot = do - putStrLn "Guessed package name" - (guessPackageName >=> print) testProjectRoot - putStrLn "Guessed name and email" - guessAuthorNameMail >>= print - - mods <- scanForModules testProjectRoot - - putStrLn "Guessed modules" - mapM_ print mods - putStrLn "Needed build programs" - print (neededBuildPrograms mods) - - putStrLn "List of known categories" - print $ knownCategories db --} diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs new file mode 100644 index 00000000000..2aef676763a --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Command +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Interactive.Command +( -- * Commands + createProject + -- ** Target generation +, genPkgDescription +, genLibTarget +, genExeTarget +, genTestTarget + -- ** Prompts +, cabalVersionPrompt +, packageNamePrompt +, versionPrompt +, licensePrompt +, authorPrompt +, emailPrompt +, homepagePrompt +, synopsisPrompt +, categoryPrompt +, mainFilePrompt +, testDirsPrompt +, languagePrompt +, noCommentsPrompt +, appDirsPrompt +, dependenciesPrompt +, srcDirsPrompt +) where + + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) + + +import Distribution.CabalSpecVersion (CabalSpecVersion(..), showCabalSpecVersion) +import Distribution.Version (Version) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.PackageName (PackageName, unPackageName) +import qualified Distribution.SPDX as SPDX +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.FlagExtractors +import Distribution.Client.Init.Prompt +import Distribution.Client.Init.Types +import Distribution.Client.Init.Utils +import Distribution.Simple.Setup (Flag(..)) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Solver.Types.PackageIndex (elemByPackageName) + +import Language.Haskell.Extension (Language(..)) + + + +-- | Main driver for interactive prompt code. +-- +createProject + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject v pkgIx srcDb initFlags = do + + -- The workflow is as follows: + -- + -- 1. Get the package type, supplied as either a program input or + -- via user prompt. This determines what targets will be built + -- in later steps. + -- + -- 2. Generate package description and the targets specified by + -- the package type. Once this is done, a prompt for building + -- test suites is initiated, and this determines if we build + -- test targets as well. Then we ask if the user wants to + -- comment their .cabal file with pretty comments. + -- + -- 3. The targets are passed to the file creator script, and associated + -- directories/files/modules are created, with the a .cabal file + -- being generated as a final result. + -- + + pkgType <- packageTypePrompt initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- getPackageDir initFlags + pkgDesc <- genPkgDescription initFlags srcDb + + let pkgName = _pkgName pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + + case pkgType of + Library -> do + libTarget <- genLibTarget initFlags pkgIx + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags pkgIx + + comments <- noCommentsPrompt initFlags + + return $ ProjectSettings + (mkOpts comments) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genExeTarget initFlags pkgIx + comments <- noCommentsPrompt initFlags + + return $ ProjectSettings + (mkOpts comments) pkgDesc Nothing + (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genLibTarget initFlags pkgIx + + exeTarget <- addLibDepToExe pkgName <$> + genExeTarget initFlags pkgIx + + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags pkgIx + + comments <- noCommentsPrompt initFlags + + return $ ProjectSettings + (mkOpts comments) pkgDesc (Just libTarget) + (Just exeTarget) testTarget + where + -- Add package name as dependency of test suite + -- + addLibDepToTest _ Nothing = Nothing + addLibDepToTest n (Just t) = Just $ t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } + + -- Add package name as dependency of executable + -- + addLibDepToExe n exe = exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } + +-- -------------------------------------------------------------------- -- +-- Target and pkg description generation + +-- | Extract flags relevant to a package description and interactively +-- generate a 'PkgDescription' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genPkgDescription + :: Interactive m + => InitFlags + -> SourcePackageDb + -> m PkgDescription +genPkgDescription flags srcDb = PkgDescription + <$> cabalVersionPrompt flags + <*> packageNamePrompt srcDb flags + <*> versionPrompt flags + <*> licensePrompt flags + <*> authorPrompt flags + <*> emailPrompt flags + <*> homepagePrompt flags + <*> synopsisPrompt flags + <*> categoryPrompt flags + <*> getExtraSrcFiles flags + + +-- | Extract flags relevant to a library target and interactively +-- generate a 'LibTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genLibTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m LibTarget +genLibTarget flags pkgs = LibTarget + <$> srcDirsPrompt flags + <*> languagePrompt flags "library" + <*> getExposedModules flags + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + +-- | Extract flags relevant to a executable target and interactively +-- generate a 'ExeTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genExeTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m ExeTarget +genExeTarget flags pkgs = ExeTarget + <$> mainFilePrompt flags + <*> appDirsPrompt flags + <*> languagePrompt flags "executable" + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + +-- | Extract flags relevant to a test target and interactively +-- generate a 'TestTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +-- Note: this workflow is only enabled if the user answers affirmatively +-- when prompted, or if the user passes in the flag to enable +-- test suites at command line. +-- +genTestTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m (Maybe TestTarget) +genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go + where + go initialized + | not initialized = return Nothing + | otherwise = fmap Just $ TestTarget + <$> testMainPrompt + <*> testDirsPrompt flags + <*> languagePrompt flags "test suite" + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + + +-- -------------------------------------------------------------------- -- +-- Prompts + +cabalVersionPrompt :: Interactive m => InitFlags -> m CabalSpecVersion +cabalVersionPrompt flags = getCabalVersion flags $ do + v <- promptList "Please choose version of the Cabal specification to use" + ppVersions + (Just ppDefault) + (Just takeVersion) + False + -- take just the version numbers for convenience + return $ parseCabalVersion (takeVersion v) + where + -- only used when presenting the default in prompt + takeVersion = takeWhile (/= ' ') + + ppDefault = displayCabalVersion defaultCabalVersion + ppVersions = displayCabalVersion <$> defaultCabalVersions + + parseCabalVersion :: String -> CabalSpecVersion + parseCabalVersion "1.10" = CabalSpecV1_10 + parseCabalVersion "2.0" = CabalSpecV2_0 + parseCabalVersion "2.2" = CabalSpecV2_2 + parseCabalVersion "2.4" = CabalSpecV2_4 + parseCabalVersion "3.0" = CabalSpecV3_0 + parseCabalVersion "3.4" = CabalSpecV3_4 + parseCabalVersion _ = defaultCabalVersion -- 2.4 + + displayCabalVersion :: CabalSpecVersion -> String + displayCabalVersion v = case v of + CabalSpecV1_10 -> "1.10 (legacy)" + CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" + CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" + CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" + CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" + CabalSpecV3_4 -> "3.4 (+ support for 'pkg:sublib' syntax, active repo configuration, rich index-state syntax)" + _ -> showCabalSpecVersion v + +packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName +packageNamePrompt srcDb flags = getPackageName flags $ do + defName <- case packageDir flags of + Flag b -> return $ filePathToPkgName b + NoFlag -> currentDirPkgName + + go $ Just defName + where + go defName = prompt "Package name" defName >>= \n -> + if isPkgRegistered n + then do + don'tUseName <- promptYesNo (promptOtherNameMsg n) (Just True) + if don'tUseName + then do + putStrLn (inUseMsg n) + go defName + else return n + else return n + + isPkgRegistered = elemByPackageName (packageIndex srcDb) + + inUseMsg pn = "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." + + promptOtherNameMsg pn = inUseMsg pn ++ " Do you want to choose a different name" + +versionPrompt :: Interactive m => InitFlags -> m Version +versionPrompt flags = getVersion flags go + where + go = do + vv <- promptStr "Package version" (Just $ prettyShow defaultVersion) + case simpleParsec vv of + Nothing -> do + putStrLn + $ "Version must be a valid PVP format (e.g. 0.1.0.0): " + ++ vv + go + Just v -> return v + +licensePrompt :: Interactive m => InitFlags -> m SPDX.License +licensePrompt flags = getLicense flags $ do + l <- promptList "Please choose a license" + licenses + Nothing + Nothing + True + + case simpleParsec l of + Nothing -> do + putStrLn "The license must be a valid SPDX expression." + licensePrompt flags + Just l' -> return l' + where + licenses = SPDX.licenseId <$> defaultLicenseIds + +authorPrompt :: Interactive m => InitFlags -> m String +authorPrompt flags = getAuthor flags $ + promptStr "Author name" Nothing + +emailPrompt :: Interactive m => InitFlags -> m String +emailPrompt flags = getEmail flags $ + promptStr "Maintainer email" Nothing + +homepagePrompt :: Interactive m => InitFlags -> m String +homepagePrompt flags = getHomepage flags $ + promptStr "Project homepage URL" Nothing + +synopsisPrompt :: Interactive m => InitFlags -> m String +synopsisPrompt flags = getSynopsis flags $ + promptStr "Project synopsis" Nothing + +categoryPrompt :: Interactive m => InitFlags -> m String +categoryPrompt flags = getCategory flags $ promptList + "Project category" defaultCategories + (Just "") (Just matchNone) True + where + matchNone s + | null s = "(none)" + | otherwise = s + +mainFilePrompt :: Interactive m => InitFlags -> m HsFilePath +mainFilePrompt flags = getMainFile flags go + where + defaultMainIs' = show defaultMainIs + go = do + fp <- promptList "What is the main module of the executable" + [defaultMainIs', "Main.lhs"] + (Just defaultMainIs') + Nothing + True + + let hs = toHsFilePath fp + + case _hsFileType hs of + InvalidHsPath -> do + putStrLn $ concat + [ "Main file " + , show hs + , " is not a valid haskell file. Source files must end in .hs or .lhs." + ] + go + + _ -> return hs + +testDirsPrompt :: Interactive m => InitFlags -> m [String] +testDirsPrompt flags = getTestDirs flags $ do + dir <- promptStr "Test directory" (Just defaultTestDir) + return [dir] + +languagePrompt :: Interactive m => InitFlags -> String -> m Language +languagePrompt flags pkgType = getLanguage flags $ do + lang <- promptList ("Choose a language for your " ++ pkgType) + ["Haskell2010", "Haskell98"] + (Just "Haskell2010") + Nothing + True + + case lang of + "Haskell2010" -> return Haskell2010 + "Haskell98" -> return Haskell98 + l | all isAlphaNum l -> return $ UnknownLanguage l + _ -> do + putStrLn + $ "\nThe language must be alphanumeric. " + ++ "Please enter a different language." + + languagePrompt flags pkgType + +noCommentsPrompt :: Interactive m => InitFlags -> m Bool +noCommentsPrompt flags = getNoComments flags $ do + doComments <- promptYesNo + "Add informative comments to each field in the cabal file. (y/n)" + (Just True) + + -- + -- if --no-comments is flagged, then we choose not to generate comments + -- for fields in the cabal file, but it's a nicer UX to present the + -- affirmative question which must be negated. + -- + + return (not doComments) + +-- | Ask for the application root directory. +appDirsPrompt :: Interactive m => InitFlags -> m [String] +appDirsPrompt flags = getAppDirs flags $ do + dir <- promptList promptMsg + [defaultApplicationDir, "exe", "src-exe"] + (Just defaultApplicationDir) + Nothing + True + + return [dir] + where + promptMsg = case mainIs flags of + Flag p -> "Application (" ++ p ++ ") directory" + NoFlag -> "Application directory" + +-- | Ask for the source (library) root directory. +srcDirsPrompt :: Interactive m => InitFlags -> m [String] +srcDirsPrompt flags = getSrcDirs flags $ do + dir <- promptList "Library source directory" + [defaultSourceDir, "lib", "src-lib"] + (Just defaultSourceDir) + Nothing + True + + return [dir] + +dependenciesPrompt + :: Interactive m + => InstalledPackageIndex + -> InitFlags + -> m [Dependency] +dependenciesPrompt pkgIx flags = getDependencies flags $ + retrieveDependencies flags [fromString "Prelude"] pkgIx diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs new file mode 100644 index 00000000000..939f0e134b2 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.Init.NonInteractive.Command +( genPkgDescription +, genLibTarget +, genExeTarget +, genTestTarget +, createProject +, packageTypeHeuristics +, authorHeuristics +, emailHeuristics +, cabalVersionHeuristics +, packageNameHeuristics +, versionHeuristics +, mainFileHeuristics +, testDirsHeuristics +, initializeTestSuiteHeuristics +, exposedModulesHeuristics +, libOtherModulesHeuristics +, exeOtherModulesHeuristics +, testOtherModulesHeuristics +, buildToolsHeuristics +, dependenciesHeuristics +, otherExtsHeuristics +, licenseHeuristics +, homepageHeuristics +, synopsisHeuristics +, categoryHeuristics +, extraSourceFilesHeuristics +, appDirsHeuristics +, srcDirsHeuristics +, languageHeuristics +, noCommentsHeuristics +, minimalHeuristics +, overwriteHeuristics +) where +import Distribution.Client.Init.Types + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last, head) + +import Data.List (last, head) +import qualified Data.List.NonEmpty as NEL + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName, components) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.PackageName (PackageName, unPackageName) +import qualified Distribution.SPDX as SPDX +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.NonInteractive.Heuristics +import Distribution.Client.Init.Utils +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Setup (Flag(..)) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Solver.Types.PackageIndex (elemByPackageName) +import Distribution.Utils.Generic (safeHead) + +import Language.Haskell.Extension (Language(..), Extension(..)) + +import System.FilePath (splitDirectories, ()) + + +-- | Main driver for interactive prompt code. +-- +createProject + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject v pkgIx srcDb initFlags = do + + -- The workflow is as follows: + -- + -- 1. Get the package type, supplied as either a program input or + -- via user prompt. This determines what targets will be built + -- in later steps. + -- + -- 2. Determine whether we generate simple targets or prompt the + -- user for inputs when not supplied as a flag. In general, + -- flag inputs are preferred, and "simple" here means + -- reasonable defaults defined in @Defaults.hs@. + -- + -- 3. Generate package description and the targets specified by + -- the package type. Once this is done, a prompt for building + -- test suites is initiated, and this determines if we build + -- test targets as well. Then we ask if the user wants to + -- comment their .cabal file with pretty comments. + -- + -- 4. The targets are passed to the file creator script, and associated + -- directories/files/modules are created, with the a .cabal file + -- being generated as a final result. + -- + + pkgType <- packageTypeHeuristics initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- packageDirHeuristics initFlags + pkgDesc <- genPkgDescription initFlags srcDb + comments <- noCommentsHeuristics initFlags + + let pkgName = _pkgName pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + + case pkgType of + Library -> do + libTarget <- genLibTarget initFlags pkgIx + testTarget <- genTestTarget initFlags pkgIx + + return $ ProjectSettings + (mkOpts comments) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genExeTarget initFlags pkgIx + + return $ ProjectSettings + (mkOpts comments) pkgDesc Nothing + (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genLibTarget initFlags pkgIx + exeTarget <- genExeTarget initFlags pkgIx + testTarget <- genTestTarget initFlags pkgIx + + return $ ProjectSettings + (mkOpts comments) pkgDesc (Just libTarget) + (Just exeTarget) testTarget + +genPkgDescription + :: Interactive m + => InitFlags + -> SourcePackageDb + -> m PkgDescription +genPkgDescription flags srcDb = PkgDescription + <$> cabalVersionHeuristics flags + <*> packageNameHeuristics srcDb flags + <*> versionHeuristics flags + <*> licenseHeuristics flags + <*> authorHeuristics flags + <*> emailHeuristics flags + <*> homepageHeuristics flags + <*> synopsisHeuristics flags + <*> categoryHeuristics flags + <*> extraSourceFilesHeuristics flags + +genLibTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m LibTarget +genLibTarget flags pkgs = do + srcDirs <- srcDirsHeuristics flags + let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs + LibTarget srcDirs + <$> languageHeuristics flags + <*> exposedModulesHeuristics flags + <*> libOtherModulesHeuristics flags + <*> otherExtsHeuristics flags srcDir + <*> dependenciesHeuristics flags srcDir pkgs + <*> buildToolsHeuristics flags srcDir + +genExeTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m ExeTarget +genExeTarget flags pkgs = do + appDirs <- appDirsHeuristics flags + let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs + ExeTarget + <$> mainFileHeuristics flags + <*> pure appDirs + <*> languageHeuristics flags + <*> exeOtherModulesHeuristics flags + <*> otherExtsHeuristics flags appDir + <*> dependenciesHeuristics flags appDir pkgs + <*> buildToolsHeuristics flags appDir + +genTestTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m (Maybe TestTarget) +genTestTarget flags pkgs = do + initialized <- initializeTestSuiteHeuristics flags + testDirs' <- testDirsHeuristics flags + let testDir = fromMaybe defaultTestDir $ safeHead testDirs' + if not initialized + then return Nothing + else fmap Just $ TestTarget + <$> testMainHeuristics flags + <*> pure testDirs' + <*> languageHeuristics flags + <*> testOtherModulesHeuristics flags + <*> otherExtsHeuristics flags testDir + <*> dependenciesHeuristics flags testDir pkgs + <*> buildToolsHeuristics flags testDir + +-- -------------------------------------------------------------------- -- +-- Get flags from init config + +minimalHeuristics :: Interactive m => InitFlags -> m Bool +minimalHeuristics = getMinimal + +overwriteHeuristics :: Interactive m => InitFlags -> m Bool +overwriteHeuristics = getOverwrite + +packageDirHeuristics :: Interactive m => InitFlags -> m FilePath +packageDirHeuristics = getPackageDir + +-- | Get the version of the cabal spec to use. +-- The spec version can be specified by the InitFlags cabalVersion field. If +-- none is specified then the default version is used. +cabalVersionHeuristics :: Interactive m => InitFlags -> m CabalSpecVersion +cabalVersionHeuristics flags = getCabalVersion flags guessCabalSpecVersion + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. It looks at the SourcePackageDb to avoid +-- using an existing package name. +packageNameHeuristics :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName +packageNameHeuristics sourcePkgDb flags = getPackageName flags $ do + defName <- guessPackageName =<< case packageDir flags of + Flag a -> return a + NoFlag -> last . splitDirectories <$> getCurrentDirectory + + when (isPkgRegistered defName) + $ putStrLn (inUseMsg defName) + + return defName + + where + isPkgRegistered = elemByPackageName (packageIndex sourcePkgDb) + + inUseMsg pn = "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." + +-- | Package version: use 0.1.0.0 as a last resort +versionHeuristics :: Interactive m => InitFlags -> m Version +versionHeuristics flags = getVersion flags $ return defaultVersion + +-- | Choose a license for the package. +-- The license can come from Initflags (license field), if it is not present +-- then prompt the user from a predefined list of licenses. +licenseHeuristics :: Interactive m => InitFlags -> m SPDX.License +licenseHeuristics flags = getLicense flags $ guessLicense flags + +-- | The author's name. Prompt, or try to guess from an existing +-- darcs repo. +authorHeuristics :: Interactive m => InitFlags -> m String +authorHeuristics flags = getAuthor flags guessAuthorEmail + +-- | The author's email. Prompt, or try to guess from an existing +-- darcs repo. +emailHeuristics :: Interactive m => InitFlags -> m String +emailHeuristics flags = getEmail flags guessAuthorName + +-- | Prompt for a homepage URL for the package. +homepageHeuristics :: Interactive m => InitFlags -> m String +homepageHeuristics flags = getHomepage flags $ return "" + +-- | Prompt for a project synopsis. +synopsisHeuristics :: Interactive m => InitFlags -> m String +synopsisHeuristics flags = getSynopsis flags $ return "" + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +categoryHeuristics :: Interactive m => InitFlags -> m String +categoryHeuristics flags = getCategory flags $ return "(none)" + +-- | Try to guess extra source files. +extraSourceFilesHeuristics :: Interactive m => InitFlags -> m (NonEmpty FilePath) +extraSourceFilesHeuristics flags = case extraSrc flags of + Flag x | not (null x) -> return $ NEL.fromList x + _ -> guessExtraSourceFiles flags + +-- | Try to guess if the project builds a library, an executable, or both. +packageTypeHeuristics :: Interactive m => InitFlags -> m PackageType +packageTypeHeuristics flags = getPackageType flags $ guessPackageType flags + +-- | Try to guess the main file, if nothing is found, fallback +-- to a default value. +mainFileHeuristics :: Interactive m => InitFlags -> m HsFilePath +mainFileHeuristics flags = do + appDir <- head <$> appDirsHeuristics flags + getMainFile flags . guessMainFile $ appDir + +testMainHeuristics :: Interactive m => InitFlags -> m HsFilePath +testMainHeuristics flags = do + testDir <- head <$> testDirsHeuristics flags + guessMainFile testDir + +initializeTestSuiteHeuristics :: Interactive m => InitFlags -> m Bool +initializeTestSuiteHeuristics flags = getInitializeTestSuite flags $ return False + +testDirsHeuristics :: Interactive m => InitFlags -> m [String] +testDirsHeuristics flags = getTestDirs flags $ return [defaultTestDir] + +-- | Ask for the Haskell base language of the package. +languageHeuristics :: Interactive m => InitFlags -> m Language +languageHeuristics flags = getLanguage flags guessLanguage + +-- | Ask whether to generate explanatory comments. +noCommentsHeuristics :: Interactive m => InitFlags -> m Bool +noCommentsHeuristics flags = getNoComments flags $ return False + +-- | Ask for the application root directory. +appDirsHeuristics :: Interactive m => InitFlags -> m [String] +appDirsHeuristics flags = getAppDirs flags $ guessApplicationDirectories flags + +-- | Ask for the source (library) root directory. +srcDirsHeuristics :: Interactive m => InitFlags -> m [String] +srcDirsHeuristics flags = getSrcDirs flags $ guessSourceDirectories flags + +-- | Retrieve the list of exposed modules +exposedModulesHeuristics :: Interactive m => InitFlags -> m (NonEmpty ModuleName) +exposedModulesHeuristics flags = do + mods <- case exposedModules flags of + Flag x -> return x + NoFlag -> do + srcDir <- fromMaybe defaultSourceDir . safeHead <$> srcDirsHeuristics flags + + modules <- filter isHaskell <$> listFilesRecursive srcDir + modulesNames <- traverse retrieveModuleName modules + + otherModules' <- libOtherModulesHeuristics flags + return $ filter (`notElem` otherModules') modulesNames + + return $ if null mods + then myLibModule NEL.:| [] + else NEL.fromList mods + +-- | Retrieve the list of other modules for Libraries, filtering them +-- based on the last component of the module name +libOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +libOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let otherCandidates = ["Internal", "Utils"] + srcDir = case sourceDirs flags of + Flag x -> fromMaybe defaultSourceDir $ safeHead x + NoFlag -> defaultSourceDir + + libDir <- ( srcDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist libDir + if exists + then do + otherModules' <- filter isHaskell <$> listFilesRecursive libDir + filter ((`elem` otherCandidates) . last . components) + <$> traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of other modules for Executables, it lists everything +-- that is a Haskell file within the application directory, excluding the main file +exeOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +exeOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let appDir = case applicationDirs flags of + Flag x -> fromMaybe defaultApplicationDir $ safeHead x + NoFlag -> defaultApplicationDir + + exeDir <- ( appDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist exeDir + if exists + then do + otherModules' <- filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive exeDir + traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of other modules for Tests, it lists everything +-- that is a Haskell file within the tests directory, excluding the main file +testOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +testOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let testDir = case testDirs flags of + Flag x -> fromMaybe defaultTestDir $ safeHead x + NoFlag -> defaultTestDir + + testDir' <- ( testDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist testDir' + if exists + then do + otherModules' <- filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive testDir' + traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of build tools +buildToolsHeuristics :: Interactive m => InitFlags -> FilePath -> m [String] +buildToolsHeuristics flags fp = case buildTools flags of + Flag x -> return x + NoFlag -> retrieveBuildTools fp + +-- | Retrieve the list of dependencies +dependenciesHeuristics :: Interactive m => InitFlags -> FilePath -> InstalledPackageIndex -> m [Dependency] +dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do + sources <- retrieveSourceFiles fp + + let mods = case exposedModules flags of + Flag x -> x + NoFlag -> map moduleName sources + + retrieveDependencies flags + ( nub -- skips duplicates + ( fromString "Prelude" -- gets base as dependency + : (filter (`notElem` mods) -- skips modules from this own package + . concatMap imports $ sources))) + pkgIx + +-- | Retrieve the list of extensions +otherExtsHeuristics :: Interactive m => InitFlags -> FilePath -> m [Extension] +otherExtsHeuristics flags fp = case otherExts flags of + Flag x -> return x + NoFlag -> do + sources <- listFilesRecursive fp + extensions' <- traverse retrieveModuleExtensions . filter isHaskell $ sources + + return $ nub . join $ extensions' diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs new file mode 100644 index 00000000000..93348ada043 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.NonInteractive.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.NonInteractive.Heuristics + ( guessPackageName + , guessMainFile + , guessLicense + , guessExtraSourceFiles + , guessAuthorName + , guessAuthorEmail + , guessCabalSpecVersion + , guessLanguage + , guessPackageType + , guessSourceDirectories + , guessApplicationDirectories + ) where + +import Prelude (read) +import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many) +import Distribution.Utils.Generic (safeLast) + +import Distribution.Simple.Setup (fromFlagOrDefault) + +import Text.Parsec +import qualified Data.List as L +import qualified Data.List.NonEmpty as NEL +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Types hiding (break) +import Distribution.Client.Init.Utils +import qualified Distribution.SPDX as SPDX +import System.FilePath +import Distribution.CabalSpecVersion +import Language.Haskell.Extension +import Distribution.Version +import Distribution.Types.PackageName (PackageName, mkPackageName) + + + +-- | Guess the main file, returns a default value if none is found. +guessMainFile :: Interactive m => FilePath -> m HsFilePath +guessMainFile pkgDir = do + files <- filter isMain <$> listFilesRecursive pkgDir + + return $ if null files + then defaultMainIs + else toHsFilePath $ L.head files + +-- | Juggling characters around to guess the desired cabal version based on +-- the system's cabal version. +guessCabalSpecVersion :: Interactive m => m CabalSpecVersion +guessCabalSpecVersion = do + (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] "" + case runParser versionParser () "" verString of + Right ver@(_:_) -> return $ + read $ "CabalSpecV" ++ format' ver + _ -> return defaultCabalVersion + + where + format' [] = [] + format' ('.':xs) = '_' : takeWhile (/= '.') xs + format' (x:xs) = x : format' xs + +-- | Guess the language specification based on the GHC version +guessLanguage :: Interactive m => m Language +guessLanguage = do + (_, verString, _) <- readProcessWithExitCode "ghc" ["--version"] "" + case simpleParsec <$> runParser versionParser () "" verString of + Right (Just ver) -> return $ + if ver < mkVersion [7,0,1] + then Haskell98 + else Haskell2010 + _ -> return defaultLanguage + +-- | Guess the package name based on the given root directory. +guessPackageName :: Interactive m => FilePath -> m PackageName +guessPackageName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) + . tryCanonicalizePath + where + -- Treat each span of non-alphanumeric characters as a hyphen. Each + -- hyphenated component of a package name must contain at least one + -- alphabetic character. An arbitrary character ('x') will be prepended if + -- this is not the case for the first component, and subsequent components + -- will simply be run together. For example, "1+2_foo-3" will become + -- "x12-foo3". + repair = repair' ('x' :) id + repair' invalid valid x = case dropWhile (not . isAlphaNum) x of + "" -> repairComponent "" + x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' + in c ++ repairRest r + where + repairComponent c | all isDigit c = invalid c + | otherwise = valid c + repairRest = repair' id ('-' :) + +-- | Try to guess the license from an already existing @LICENSE@ file in +-- the package directory, comparing the file contents with the ones +-- listed in @Licenses.hs@, for now it only returns a default value. +guessLicense :: Interactive m => InitFlags -> m SPDX.License +guessLicense _ = return SPDX.NONE + +guessExtraSourceFiles :: Interactive m => InitFlags -> m (NonEmpty FilePath) +guessExtraSourceFiles flags = do + pkgDir <- fromFlagOrDefault getCurrentDirectory $ fmap return $ packageDir flags + files <- getDirectoryContents pkgDir + + let extSrcCandidates = ["CHANGES", "CHANGELOG", "README"] + extraSrc' = [y | x <- extSrcCandidates, y <- files, x == map toUpper (takeBaseName y)] + + return $ if null extraSrc' + then defaultChangelog NEL.:| [] + else NEL.fromList extraSrc' + +-- | Try to guess the package type from the files in the package directory, +-- looking for unique characteristics from each type, defaults to Executable. +guessPackageType :: Interactive m => InitFlags -> m PackageType +guessPackageType flags = do + let lastDir dirs = L.last . splitDirectories $ dirs + srcCandidates = [defaultSourceDir, "src", "source"] + testCandidates = [defaultTestDir, "test", "tests"] + + pkgDir <- fromFlagOrDefault getCurrentDirectory $ fmap return $ packageDir flags + files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir + + let hasExe = not $ null [f | f <- files, isMain $ takeFileName f] + hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates] + + return $ case (hasLib, hasExe) of + (True, True) -> LibraryAndExecutable + (True, False) -> Library + _ -> Executable + +-- | Try to guess the application directories from the package directory, +-- using a default value as fallback. +guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath] +guessApplicationDirectories flags = do + pkgDirs <- listDirectory =<< fromFlagOrDefault getCurrentDirectory + (fmap return $ packageDir flags) + + let candidates = [defaultApplicationDir, "app", "src-exe"] in + return $ case [y | x <- candidates, y <- pkgDirs, x == y] of + [] -> [defaultApplicationDir] + x -> nub x + +-- | Try to guess the source directories, using a default value as fallback. +guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath] +guessSourceDirectories flags = do + pkgDir <- fromFlagOrDefault getCurrentDirectory $ fmap return $ packageDir flags + + doesDirectoryExist (pkgDir "src") >>= return . \case + False -> [defaultSourceDir] + True -> ["src"] + +-- | Guess author and email using git configuration options. +guessAuthorName :: Interactive m => m String +guessAuthorName = guessGitInfo "user.name" + +guessAuthorEmail :: Interactive m => m String +guessAuthorEmail = guessGitInfo "user.email" + +guessGitInfo :: Interactive m => String -> m String +guessGitInfo target = do + info <- readProcessWithExitCode "git" ["config", "--local", target] "" + if null $ snd' info + then trim . snd' <$> readProcessWithExitCode "git" ["config", "--global", target] "" + else return . trim $ snd' info + + where + snd' (_, x, _) = x diff --git a/cabal-install/src/Distribution/Client/Init/Prompt.hs b/cabal-install/src/Distribution/Client/Init/Prompt.hs index 00332782705..ebc995f2ef5 100644 --- a/cabal-install/src/Distribution/Client/Init/Prompt.hs +++ b/cabal-install/src/Distribution/Client/Init/Prompt.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init.Prompt @@ -12,134 +14,153 @@ -- ----------------------------------------------------------------------------- -module Distribution.Client.Init.Prompt ( +module Distribution.Client.Init.Prompt +( prompt +, promptYesNo +, promptStr +, promptList +) where - -- * Commands - prompt - , promptYesNo - , promptStr - , promptList - , promptListOptional - , maybePrompt - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) +import Prelude hiding (break, putStrLn, getLine, putStr) +import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn) import Distribution.Client.Init.Types - ( InitFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..) ) - --- | Run a prompt or not based on the interactive flag of the --- InitFlags structure. -maybePrompt :: InitFlags -> IO t -> IO (Maybe t) -maybePrompt flags p = - case interactive flags of - Flag True -> Just `fmap` p - _ -> return Nothing -- | Create a prompt with optional default value that returns a --- String. -promptStr :: String -> Maybe String -> IO String -promptStr = promptDefault' Just id +-- String. +promptStr :: Interactive m => String -> Maybe String -> m String +promptStr = promptDefault Right id -- | Create a yes/no prompt with optional default value. -promptYesNo :: String -- ^ prompt message - -> Maybe Bool -- ^ optional default value - -> IO Bool +promptYesNo + :: Interactive m + => String + -- ^ prompt message + -> Maybe Bool + -- ^ optional default value + -> m Bool promptYesNo = - promptDefault' recogniseYesNo showYesNo + promptDefault recogniseYesNo showYesNo where - recogniseYesNo s | s == "y" || s == "Y" = Just True - | s == "n" || s == "N" = Just False - | otherwise = Nothing + recogniseYesNo s + | (toLower <$> s) == "y" = Right True + | (toLower <$> s) == "n" || s == "N" = Right False + | otherwise = Left $ "Cannot parse input: " ++ s + showYesNo True = "y" showYesNo False = "n" -- | Create a prompt with optional default value that returns a value -- of some Text instance. -prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t -prompt = promptDefault' simpleParsec prettyShow - --- | Create a prompt with an optional default value. -promptDefault' :: (String -> Maybe t) -- ^ parser - -> (t -> String) -- ^ pretty-printer - -> String -- ^ prompt message - -> Maybe t -- ^ optional default value - -> IO t -promptDefault' parser ppr pr def = do - putStr $ mkDefPrompt pr (ppr `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return d - _ -> case parser inp of - Just t -> return t - Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" - promptDefault' parser ppr pr def +prompt :: (Interactive m, Parsec t, Pretty t) => String -> Maybe t -> m t +prompt = promptDefault eitherParsec prettyShow -- | Create a prompt from a prompt string and a String representation -- of an optional default value. mkDefPrompt :: String -> Maybe String -> String -mkDefPrompt pr def = pr ++ "?" ++ defStr def - where defStr Nothing = " " - defStr (Just s) = " [default: " ++ s ++ "] " - --- | Create a prompt from a list of items, where no selected items is --- valid and will be represented as a return value of 'Nothing'. -promptListOptional :: (Pretty t, Eq t) - => String -- ^ prompt - -> [t] -- ^ choices - -> IO (Maybe (Either String t)) -promptListOptional pr choices = promptListOptional' pr choices prettyShow - -promptListOptional' :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> (t -> String) -- ^ show an item - -> IO (Maybe (Either String t)) -promptListOptional' pr choices displayItem = - fmap rearrange - $ promptList pr (Nothing : map Just choices) (Just Nothing) - (maybe "(none)" displayItem) True +mkDefPrompt msg def = msg ++ "?" ++ format def where - rearrange = either (Just . Left) (fmap Right) - --- | Create a prompt from a list of items. -promptList :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> Maybe t -- ^ optional default value - -> (t -> String) -- ^ show an item - -> Bool -- ^ whether to allow an 'other' option - -> IO (Either String t) -promptList pr choices def displayItem other = do - putStrLn $ pr ++ ":" - let options1 = map (\c -> (Just c == def, displayItem c)) choices - options2 = zip ([1..]::[Int]) - (options1 ++ [(False, "Other (specify)") | other]) - traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 - promptList' displayItem (length options2) choices def other - where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest - | otherwise = " " ++ star i ++ rest - where rest = show n ++ ") " - star True = "*" - star False = " " - -promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) -promptList' displayItem numChoices choices def other = do - putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return $ Right d - _ -> case readMaybe inp of - Nothing -> invalidChoice inp - Just n -> getChoice n - where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." - promptList' displayItem numChoices choices def other - getChoice n | n < 1 || n > numChoices = invalidChoice (show n) - | n < numChoices || - (n == numChoices && not other) - = return . Right $ choices !! (n-1) - | otherwise = Left `fmap` promptStr "Please specify" Nothing + format Nothing = " " + format (Just s) = " [default: " ++ s ++ "] " + +-- | Create a prompt from a list of strings +promptList + :: Interactive m + => String + -- ^ prompt + -> [String] + -- ^ choices + -> Maybe String + -- ^ optional default value + -> Maybe (String -> String) + -- ^ modify the default value to present in-prompt + -> Bool + -- ^ whether to allow an 'other' option + -> m String +promptList msg choices def modDef hasOther = do + putStrLn $ msg ++ ":" + + -- Output nicely formatted list of options + for_ prettyChoices $ \(i,c) -> do + let star = if Just c == def + then "*" + else " " + + let output = concat $ if i < 10 + then [" ", star, " ", show i, ") ", c] + else [" ", star, show i, ") ", c] + + putStrLn output + + go + where + prettyChoices = + let cs = if hasOther + then choices ++ ["Other (specify)"] + else choices + in zip [1::Int .. numChoices + 1] cs + + numChoices = length choices + + invalidChoice input = do + let msg' = if null input + then "Empty input is not a valid choice." + else concat + [ input + , " is not a valid choice. Please choose a number from 1 to " + , show (numChoices +1) + , "." + ] + + putStrLn msg' + breakOrContinue ("promptList: " ++ input) go + + go = do + putStr + $ mkDefPrompt "Your choice" + $ maybe def (<$> def) modDef + + input <- getLine + case def of + Just d | null input -> return d + _ -> case readMaybe input of + Nothing -> invalidChoice input + Just n + | n > 0, n <= numChoices -> return $ choices !! (n-1) + | n == numChoices + 1, hasOther -> + promptStr "Please specify" Nothing + | otherwise -> invalidChoice (show n) + +-- | Create a prompt with an optional default value. +promptDefault + :: Interactive m + => (String -> Either String t) + -- ^ parser + -> (t -> String) + -- ^ pretty-printer + -> String + -- ^ prompt message + -> Maybe t + -- ^ optional default value + -> m t +promptDefault parse pprint msg def = do + putStr $ mkDefPrompt msg (pprint <$> def) + input <- getLine + case def of + Just d | null input -> return d + _ -> case parse input of + Right t -> return t + Left err -> do + putStrLn $ "Couldn't parse " ++ input ++ ", please try again!" + breakOrContinue + ("promptDefault: " ++ err ++ " on input: " ++ input) + (promptDefault parse pprint msg def) + +-- | Prompt utility for breaking out of an interactive loop +-- in the pure case +-- +breakOrContinue :: Interactive m => String -> m a -> m a +breakOrContinue msg act = break >>= \case + True -> throwPrompt $ BreakException msg + False -> act diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs new file mode 100644 index 00000000000..d93134e56e1 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Init/Simple.hs @@ -0,0 +1,138 @@ +module Distribution.Client.Init.Simple +( -- * Project creation + createProject + -- * Gen targets +, genSimplePkgDesc +, genSimpleLibTarget +, genSimpleExeTarget +, genSimpleTestTarget +) where + + +import Distribution.Client.Init.Types +import Distribution.Verbosity +import Distribution.Simple.PackageIndex +import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..)) +import qualified Data.List.NonEmpty as NEL +import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep) +import Distribution.Client.Init.Defaults +import Distribution.Simple.Flag (fromFlagOrDefault, flagElim) +import Distribution.Client.Init.FlagExtractors + + +createProject + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject v _pkgIx _srcDb initFlags = do + pkgType <- packageTypePrompt initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- getPackageDir initFlags + pkgDesc <- genSimplePkgDesc initFlags + + let pkgName = _pkgName pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + + case pkgType of + Library -> do + libTarget <- genSimpleLibTarget initFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget initFlags + return $ ProjectSettings + (mkOpts False) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genSimpleExeTarget initFlags + return $ ProjectSettings + (mkOpts False) pkgDesc + Nothing (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genSimpleLibTarget initFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget initFlags + exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget initFlags + return $ ProjectSettings + (mkOpts False) pkgDesc + (Just libTarget) (Just exeTarget) testTarget + where + -- Add package name as dependency of test suite + -- + addLibDepToTest _ Nothing = Nothing + addLibDepToTest n (Just t) = Just $ t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } + + -- Add package name as dependency of executable + -- + addLibDepToExe n exe = exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } + +genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription +genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName + where + defaultExtraSrc = defaultChangelog NEL.:| [] + + extractExtraSrc [] = defaultExtraSrc + extractExtraSrc as = NEL.fromList as + + mkPkgDesc pkgName = PkgDescription + (fromFlagOrDefault defaultCabalVersion (cabalVersion flags)) + pkgName + (fromFlagOrDefault defaultVersion (version flags)) + (fromFlagOrDefault defaultLicense (license flags)) + (fromFlagOrDefault "" (author flags)) + (fromFlagOrDefault "" (email flags)) + (fromFlagOrDefault "" (homepage flags)) + (fromFlagOrDefault "" (synopsis flags)) + (fromFlagOrDefault "" (category flags)) + (flagElim defaultExtraSrc extractExtraSrc (extraSrc flags)) + +genSimpleLibTarget :: Interactive m => InitFlags -> m LibTarget +genSimpleLibTarget flags = return $ LibTarget + { _libSourceDirs = fromFlagOrDefault [defaultSourceDir] $ sourceDirs flags + , _libLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _libExposedModules = flagElim (myLibModule NEL.:| []) extractMods $ + exposedModules flags + , _libOtherModules = fromFlagOrDefault [] $ otherModules flags + , _libOtherExts = fromFlagOrDefault [] $ otherExts flags + , _libDependencies = fromFlagOrDefault [] $ dependencies flags + , _libBuildTools= fromFlagOrDefault [] $ buildTools flags + } + + where + extractMods [] = myLibModule NEL.:| [] + extractMods as = NEL.fromList as + +genSimpleExeTarget :: Interactive m => InitFlags -> m ExeTarget +genSimpleExeTarget flags = return $ ExeTarget + { _exeMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags + , _exeApplicationDirs = fromFlagOrDefault [defaultApplicationDir] $ + applicationDirs flags + , _exeLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _exeOtherModules = fromFlagOrDefault [] $ otherModules flags + , _exeOtherExts = fromFlagOrDefault [] $ otherExts flags + , _exeDependencies = fromFlagOrDefault [] $ dependencies flags + , _exeBuildTools = fromFlagOrDefault [] $ buildTools flags + } + +genSimpleTestTarget :: Interactive m => InitFlags -> m (Maybe TestTarget) +genSimpleTestTarget flags = go <$> initializeTestSuitePrompt flags + where + go initialized + | not initialized = Nothing + | otherwise = Just $ TestTarget + { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags + , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags + , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _testOtherModules = fromFlagOrDefault [] $ otherModules flags + , _testOtherExts = fromFlagOrDefault [] $ otherExts flags + , _testDependencies = fromFlagOrDefault [] $ dependencies flags + , _testBuildTools = fromFlagOrDefault [] $ buildTools flags + } diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index e705b7fb359..c80a0f80683 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/cabal-install/src/Distribution/Client/Init/Types.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : Distribution.Client.Init.Types -- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 @@ -12,89 +13,107 @@ -- -- Some types used by the 'cabal init' command. -- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Types where +module Distribution.Client.Init.Types +( -- * Data + InitFlags(..) + -- ** Targets and descriptions +, PkgDescription(..) +, LibTarget(..) +, ExeTarget(..) +, TestTarget(..) + -- ** package types +, PackageType(..) + -- ** Main file +, HsFilePath(..) +, HsFileType(..) +, fromHsFilePath +, toHsFilePath +, toLiterateHs +, toStandardHs +, mkLiterate +, isHsFilePath + -- * Typeclasses +, Interactive(..) +, BreakException(..) +, PurePrompt(..) +, evalPrompt + -- * Aliases +, IsLiterate +, IsSimple + -- * File creator opts +, WriteOpts(..) +, ProjectSettings(..) + -- * Formatters +, FieldAnnotation(..) +) where + -import Distribution.Client.Compat.Prelude -import Prelude () +import qualified Distribution.Client.Compat.Prelude as P +import Distribution.Client.Compat.Prelude as P hiding (getLine, putStr, putStrLn) +import Prelude (read) -import Distribution.Simple.Setup (Flag(..), toFlag ) +import Control.Monad.Catch +import Data.List.NonEmpty (fromList) + +import Distribution.Simple.Setup (Flag(..)) import Distribution.Types.Dependency as P +import Distribution.Verbosity (silent) import Distribution.Version -import Distribution.Verbosity import qualified Distribution.Package as P import Distribution.SPDX.License (License) import Distribution.ModuleName import Distribution.CabalSpecVersion +import Distribution.Client.Utils as P import Language.Haskell.Extension ( Language(..), Extension ) -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map as Map +import qualified System.Directory as P +import qualified System.Process as P +import qualified Distribution.Compat.Environment as P +import System.FilePath --- | InitFlags is really just a simple type to represent certain --- portions of a .cabal file. Rather than have a flag for EVERY --- possible field, we just have one for each field that the user is --- likely to want and/or that we are likely to be able to --- intelligently guess. -data InitFlags = - InitFlags { interactive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - , simpleProject :: Flag Bool - - , packageName :: Flag P.PackageName - , version :: Flag Version - , cabalVersion :: Flag CabalSpecVersion - , license :: Flag License - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - - , synopsis :: Flag String - , category :: Flag (Either String Category) - , extraSrc :: Maybe [String] - - , packageType :: Flag PackageType - , mainIs :: Flag FilePath - , language :: Flag Language - - , exposedModules :: Maybe [ModuleName] - , otherModules :: Maybe [ModuleName] - , otherExts :: Maybe [Extension] - - , dependencies :: Maybe [P.Dependency] - , applicationDirs :: Maybe [String] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] - - , initializeTestSuite :: Flag Bool - , testDirs :: Maybe [String] - - , initHcPath :: Flag FilePath - - , initVerbosity :: Flag Verbosity - , overwrite :: Flag Bool - } - deriving (Eq, Show, Generic) - - -- the Monoid instance for Flag has later values override earlier - -- ones, which is why we want Maybe [foo] for collecting foo values, - -- not Flag [foo]. - -data BuildType = LibBuild | ExecBuild - deriving Eq - --- The type of package to initialize. -data PackageType = Library | Executable | LibraryAndExecutable - deriving (Show, Read, Eq) -displayPackageType :: PackageType -> String -displayPackageType LibraryAndExecutable = "Library and Executable" -displayPackageType pkgtype = show pkgtype +-- -------------------------------------------------------------------- -- +-- Flags + +-- | InitFlags is a subset of flags available in the +-- @.cabal@ file that represent options that are relevant to the +-- init command process. +-- +data InitFlags = + InitFlags + { interactive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + , simpleProject :: Flag Bool + , packageName :: Flag P.PackageName + , version :: Flag Version + , cabalVersion :: Flag CabalSpecVersion + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + , synopsis :: Flag String + , category :: Flag String + , extraSrc :: Flag [String] + , packageType :: Flag PackageType + , mainIs :: Flag FilePath + , language :: Flag Language + , exposedModules :: Flag [ModuleName] + , otherModules :: Flag [ModuleName] + , otherExts :: Flag [Extension] + , dependencies :: Flag [P.Dependency] + , applicationDirs :: Flag [String] + , sourceDirs :: Flag [String] + , buildTools :: Flag [String] + , initializeTestSuite :: Flag Bool + , testDirs :: Flag [String] + , initHcPath :: Flag FilePath + , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool + } deriving (Eq, Show, Generic) instance Monoid InitFlags where mempty = gmempty @@ -103,40 +122,310 @@ instance Monoid InitFlags where instance Semigroup InitFlags where (<>) = gmappend -defaultInitFlags :: InitFlags -defaultInitFlags = mempty - { initVerbosity = toFlag normal - } - --- | Some common package categories (non-exhaustive list). -data Category - = Codec - | Concurrency - | Control - | Data - | Database - | Development - | Distribution - | Game - | Graphics - | Language - | Math - | Network - | Sound - | System - | Testing - | Text - | Web - deriving (Read, Show, Eq, Ord, Bounded, Enum) - -instance Pretty Category where - pretty = Disp.text . show - -instance Parsec Category where - parsec = do - name <- P.munch1 isAlpha - case Map.lookup name names of - Just cat -> pure cat - _ -> P.unexpected $ "Category: " ++ name +-- -------------------------------------------------------------------- -- +-- Targets + +-- | 'PkgDescription' represents the relevant options set by the +-- user when building a package description during the init command +-- process. +-- +data PkgDescription = PkgDescription + { _pkgCabalVersion :: CabalSpecVersion + , _pkgName :: P.PackageName + , _pkgVersion :: Version + , _pkgLicense :: License + , _pkgAuthor :: String + , _pkgEmail :: String + , _pkgHomePage :: String + , _pkgSynopsis :: String + , _pkgCategory :: String + , _pkgExtraSrcFiles :: NonEmpty String + } deriving (Show, Eq) + +-- | 'LibTarget' represents the relevant options set by the +-- user when building a library package during the init command +-- process. +-- +data LibTarget = LibTarget + { _libSourceDirs :: [String] + , _libLanguage :: Language + , _libExposedModules :: NonEmpty ModuleName + , _libOtherModules :: [ModuleName] + , _libOtherExts :: [Extension] + , _libDependencies :: [P.Dependency] + , _libBuildTools :: [String] + } deriving (Show, Eq) + +-- | 'ExeTarget' represents the relevant options set by the +-- user when building an executable package. +-- +data ExeTarget = ExeTarget + { _exeMainIs :: HsFilePath + , _exeApplicationDirs :: [String] + , _exeLanguage :: Language + , _exeOtherModules :: [ModuleName] + , _exeOtherExts :: [Extension] + , _exeDependencies :: [P.Dependency] + , _exeBuildTools :: [String] + } deriving (Show, Eq) + +-- | 'TestTarget' represents the relevant options set by the +-- user when building a library package. +-- +data TestTarget = TestTarget + { _testMainIs :: HsFilePath + , _testDirs :: [String] + , _testLanguage :: Language + , _testOtherModules :: [ModuleName] + , _testOtherExts :: [Extension] + , _testDependencies :: [P.Dependency] + , _testBuildTools :: [String] + } deriving (Show, Eq) + +-- -------------------------------------------------------------------- -- +-- File creator options + +data WriteOpts = WriteOpts + { _optOverwrite :: Bool + , _optMinimal :: Bool + , _optNoComments :: Bool + , _optVerbosity :: Verbosity + , _optPkgDir :: FilePath + , _optPkgType :: PackageType + , _optPkgName :: P.PackageName + } deriving (Eq, Show) + +data ProjectSettings = ProjectSettings + { _pkgOpts :: WriteOpts + , _pkgDesc :: PkgDescription + , _pkgLibTarget :: Maybe LibTarget + , _pkgExeTarget :: Maybe ExeTarget + , _pkgTestTarget :: Maybe TestTarget + } deriving (Eq, Show) + +-- -------------------------------------------------------------------- -- +-- Other types + +-- | Enum to denote whether the user wants to build a library target, +-- executable target, or library and executable targets. +-- +data PackageType = Library | Executable | LibraryAndExecutable + deriving (Eq, Show, Generic) + +data HsFileType + = Literate + | Standard + | InvalidHsPath + deriving (Eq, Show) + +data HsFilePath = HsFilePath + { _hsFilePath :: FilePath + , _hsFileType :: HsFileType + } deriving Eq + +instance Show HsFilePath where + show (HsFilePath fp ty) = case ty of + Literate -> fp + Standard -> fp + InvalidHsPath -> "Invalid haskell source file: " ++ fp + +fromHsFilePath :: HsFilePath -> Maybe FilePath +fromHsFilePath (HsFilePath fp ty) = case ty of + Literate -> Just fp + Standard -> Just fp + InvalidHsPath -> Nothing + +isHsFilePath :: FilePath -> Bool +isHsFilePath fp = case _hsFileType $ toHsFilePath fp of + InvalidHsPath -> False + _ -> True + +toHsFilePath :: FilePath -> HsFilePath +toHsFilePath fp + | takeExtension fp == ".lhs" = HsFilePath fp Literate + | takeExtension fp == ".hs" = HsFilePath fp Standard + | otherwise = HsFilePath fp InvalidHsPath + +toLiterateHs :: HsFilePath -> HsFilePath +toLiterateHs (HsFilePath fp Standard) = HsFilePath + (dropExtension fp ++ ".lhs") + Literate +toLiterateHs a = a + +toStandardHs :: HsFilePath -> HsFilePath +toStandardHs (HsFilePath fp Literate) = HsFilePath + (dropExtension fp ++ ".hs") + Standard +toStandardHs a = a + +mkLiterate :: HsFilePath -> [String] -> [String] +mkLiterate (HsFilePath _ Literate) hs = + (\line -> if null line then line else "> " ++ line) <$> hs +mkLiterate _ hs = hs + +-- -------------------------------------------------------------------- -- +-- Interactive prompt monad + +newtype PurePrompt a = PurePrompt + { _runPrompt + :: NonEmpty String + -> Either BreakException (a, NonEmpty String) + } deriving (Functor) + +evalPrompt :: PurePrompt a -> NonEmpty String -> a +evalPrompt act s = case _runPrompt act s of + Left e -> error $ show e + Right (a,_) -> a + +instance Applicative PurePrompt where + pure a = PurePrompt $ \s -> Right (a, s) + PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of + Left e -> Left e + Right (f, s') -> case aa s' of + Left e -> Left e + Right (a, s'') -> Right (f a, s'') + +instance Monad PurePrompt where + return = pure + PurePrompt a >>= k = PurePrompt $ \s -> case a s of + Left e -> Left e + Right (a', s') -> _runPrompt (k a') s' + +class Monad m => Interactive m where + -- input functions + getLine :: m String + readFile :: FilePath -> m String + getCurrentDirectory :: m FilePath + getHomeDirectory :: m FilePath + getDirectoryContents :: FilePath -> m [FilePath] + listDirectory :: FilePath -> m [FilePath] + doesDirectoryExist :: FilePath -> m Bool + doesFileExist :: FilePath -> m Bool + tryCanonicalizePath :: FilePath -> m FilePath + readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String) + getEnvironment :: m [(String, String)] + listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath] + listFilesRecursive :: FilePath -> m [FilePath] + + -- output functions + putStr :: String -> m () + putStrLn :: String -> m () + createDirectory :: FilePath -> m () + writeFile :: FilePath -> String -> m () + copyFile :: FilePath -> FilePath -> m () + renameDirectory :: FilePath -> FilePath -> m () + message :: Verbosity -> String -> m () + + -- misc functions + break :: m Bool + throwPrompt :: BreakException -> m a + +instance Interactive IO where + getLine = P.getLine + readFile = P.readFile + getCurrentDirectory = P.getCurrentDirectory + getHomeDirectory = P.getHomeDirectory + getDirectoryContents = P.getDirectoryContents + listDirectory = P.listDirectory + doesDirectoryExist = P.doesDirectoryExist + doesFileExist = P.doesFileExist + tryCanonicalizePath = P.tryCanonicalizePath + readProcessWithExitCode = P.readProcessWithExitCode + getEnvironment = P.getEnvironment + listFilesInside = P.listFilesInside + listFilesRecursive = P.listFilesRecursive + + putStr = P.putStr + putStrLn = P.putStrLn + createDirectory = P.createDirectory + writeFile = P.writeFile + copyFile = P.copyFile + renameDirectory = P.renameDirectory + message q = unless (q == silent) . putStrLn + + break = return False + throwPrompt = throwM + +instance Interactive PurePrompt where + getLine = pop + readFile !_ = pop + getCurrentDirectory = popAbsolute + getHomeDirectory = popAbsolute + -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]" + getDirectoryContents !_ = popList + listDirectory !_ = popList + doesDirectoryExist !_ = popBool + doesFileExist !_ = popBool + tryCanonicalizePath !_ = popAbsolute + readProcessWithExitCode !_ !_ !_ = do + input <- pop + return (ExitSuccess, input, "") + getEnvironment = fmap (map read) popList + listFilesInside pred' !_ = do + input <- map splitDirectories <$> popList + map joinPath <$> filterM (fmap and . traverse pred') input + listFilesRecursive !_ = popList + + putStr !_ = return () + putStrLn !_ = return () + createDirectory !_ = return () + writeFile !_ !_ = return () + copyFile !_ !_ = return () + renameDirectory !_ !_ = return () + message !_ !_ = return () + + break = return True + throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException + ("Error: " ++ e ++ "\nStacktrace: " ++ show s) + +pop :: PurePrompt String +pop = PurePrompt $ \ (p:|ps) -> Right (p,fromList ps) + +popAbsolute :: PurePrompt String +popAbsolute = do + input <- pop + return $ "/home/test/" ++ input + +popBool :: PurePrompt Bool +popBool = pop >>= \case + "True" -> pure True + "False" -> pure False + s -> throwPrompt $ BreakException $ "popBool: " ++ s + +popList :: PurePrompt [String] +popList = pop >>= \a -> case safeRead a of + Nothing -> throwPrompt $ BreakException ("popList: " ++ show a) + Just as -> return as where - names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ] + safeRead s + | [(x, "")] <- reads s = Just x + | otherwise = Nothing + +-- | A pure exception thrown exclusively by the pure prompter +-- to cancel infinite loops in the prompting process. +-- +-- For example, in order to break on parse errors, or user-driven +-- continuations that do not make sense to test. +-- +newtype BreakException = BreakException String deriving (Eq, Show) + +instance Exception BreakException + +-- | Convenience alias for the literate haskell flag +-- +type IsLiterate = Bool + +-- | Convenience alias for generating simple projects +-- +type IsSimple = Bool + +-- -------------------------------------------------------------------- -- +-- Field annotation for pretty formatters + +-- | Annotations for cabal file PrettyField. +data FieldAnnotation = FieldAnnotation + { annCommentedOut :: Bool + -- ^ True iif the field and its contents should be commented out. + , annCommentLines :: [String] + -- ^ Comment lines to place before the field or section. + } diff --git a/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal-install/src/Distribution/Client/Init/Utils.hs index a3cfe06fe4e..0ac8f2f8cf8 100644 --- a/cabal-install/src/Distribution/Client/Init/Utils.hs +++ b/cabal-install/src/Distribution/Client/Init/Utils.hs @@ -1,38 +1,265 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Utils --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.Init.Utils +( SourceFileEntry(..) +, retrieveSourceFiles +, retrieveModuleName +, retrieveModuleImports +, retrieveModuleExtensions +, retrieveBuildTools +, retrieveDependencies +, isMain +, isHaskell +, isSourceFile +, versionParser +, trim +, currentDirPkgName +, filePathToPkgName +, mkPackageNameDep +) where + + +import qualified Prelude +import Distribution.Client.Compat.Prelude hiding (empty, readFile, Parsec, many) +import Distribution.Utils.Generic (isInfixOf) + +import Control.Monad (forM) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Language.Haskell.Extension (Extension(..)) +import System.FilePath + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.ModuleName (ModuleName) +import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed) +import qualified Distribution.Package as P +import qualified Distribution.Types.PackageName as PN +import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex) +import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault) +import Distribution.Verbosity +import Distribution.Version +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Types +import Text.Parsec +import Distribution.Types.PackageName +import Distribution.Types.Dependency (Dependency, mkDependency) +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Types.LibraryName + + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + , imports :: [ModuleName] + , extensions :: [Extension] + } deriving Show + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: String -> String +knownSuffixHandlers ".gc" = "greencard" +knownSuffixHandlers ".chs" = "chs" +knownSuffixHandlers ".hsc" = "hsc2hs" +knownSuffixHandlers ".x" = "alex" +knownSuffixHandlers ".y" = "happy" +knownSuffixHandlers ".ly" = "happy" +knownSuffixHandlers ".cpphs" = "cpp" +knownSuffixHandlers _ = "" + + +-- | Check if a given file has main file characteristics +isMain :: String -> Bool +isMain f = (isInfixOf "Main" f || isInfixOf "main" f) + && isSuffixOf ".hs" f || isSuffixOf ".lhs" f + +-- | Check if a given file has a Haskell extension +isHaskell :: String -> Bool +isHaskell f = isSuffixOf ".hs" f || isSuffixOf ".lhs" f + +isBuildTool :: String -> Bool +isBuildTool f = not . null . knownSuffixHandlers $ takeExtension f + +retrieveBuildTools :: Interactive m => FilePath -> m [String] +retrieveBuildTools fp = do + files <- map takeExtension <$> listFilesRecursive fp + + return [knownSuffixHandlers f | f <- files, isBuildTool f] + +retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry] +retrieveSourceFiles fp = do + files <- filter isHaskell <$> listFilesRecursive fp + + forM files $ \f -> do + let fileExtension = takeExtension f + relativeSourcePath <- makeRelative f <$> getCurrentDirectory + moduleName <- retrieveModuleName f + imports <- retrieveModuleImports f + extensions <- retrieveModuleExtensions f + + return $ SourceFileEntry {..} + +-- | Given a module, retrieve its name +retrieveModuleName :: Interactive m => FilePath -> m ModuleName +retrieveModuleName m = do + fromString . trim . grabModuleName <$> readFile m + + where + stop c = (c /= '\\') && (c /= ' ') + + grabModuleName [] = [] + grabModuleName ('m':'o':'d':'u':'l':'e':' ':xs) = takeWhile' stop xs + grabModuleName (_:xs) = grabModuleName xs + +-- | Given a module, retrieve all of its imports +retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName] +retrieveModuleImports m = do + map (fromString . trim) . grabModuleImports <$> readFile m + + where + stop c = (c /= '\\') && (c /= ' ') && (c /= '(') + + grabModuleImports [] = [] + grabModuleImports ('i':'m':'p':'o':'r':'t':' ':xs) = case trim xs of -- in case someone uses a weird formatting + ('q':'u':'a':'l':'i':'f':'i':'e':'d':' ':ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys) + _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs) + grabModuleImports (_:xs) = grabModuleImports xs + +-- | Given a module, retrieve all of its language pragmas +retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension] +retrieveModuleExtensions m = do + catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m + + where + stop c = (c /= '\\') && (c /= ' ') && (c /= ',') + + grabModuleExtensions [] = [] + grabModuleExtensions ('L':'A':'N':'G':'U':'A':'G':'E':' ':xs) = takeWhile' stop xs : grabModuleExtensions (dropWhile' stop xs) + grabModuleExtensions (',':xs) = takeWhile' stop xs : grabModuleExtensions (dropWhile' stop xs) + grabModuleExtensions (_:xs) = grabModuleExtensions xs + +takeWhile' :: (Char -> Bool) -> String -> String +takeWhile' p = takeWhile p . trim + +dropWhile' :: (Char -> Bool) -> String -> String +dropWhile' p = dropWhile p . trim + +trim :: String -> String +trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + where + removeLeadingSpace = dropWhile isSpace + +-- | Check whether a potential source file is located in one of the +-- source directories. +isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool +isSourceFile Nothing sf = isSourceFile (Just ["."]) sf +isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs + +retrieveDependencies :: Interactive m => InitFlags -> [ModuleName] -> InstalledPackageIndex -> m [P.Dependency] +retrieveDependencies flags mods' pkgIx = do + let mods = mods' + + modMap :: M.Map ModuleName [InstalledPackageInfo] + modMap = M.map (filter exposed) $ moduleNameIndex pkgIx + + modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] + modDeps = map (\mn -> (mn, M.lookup mn modMap)) mods + -- modDeps = map (id &&& flip M.lookup modMap) mods + + message (fromFlagOrDefault silent $ initVerbosity flags) "\nGuessing dependencies..." + nub . catMaybes <$> traverse (chooseDep flags) modDeps + +-- Given a module and a list of installed packages providing it, +-- choose a dependency (i.e. package + version range) to use for that +-- module. +chooseDep + :: Interactive m + => InitFlags + -> (ModuleName, Maybe [InstalledPackageInfo]) + -> m (Maybe P.Dependency) +chooseDep flags (m, mipi) = case mipi of + -- We found some packages: group them by name. + Just ps@(_:_) -> + case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of + -- if there's only one group, i.e. multiple versions of a single package, + -- we make it into a dependency, choosing the latest-ish version. + + -- Given a list of available versions of the same package, pick a dependency. + [grp] -> fmap Just $ case grp of + + -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* + (pid:|[]) -> + return $ P.Dependency + (P.pkgName pid) + (pvpize desugar . P.pkgVersion $ pid) + P.mainLibSet --TODO sublibraries + + -- Otherwise, choose the latest version and issue a warning. + pids -> do + message v ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") + return $ P.Dependency + (P.pkgName . NE.head $ pids) + (pvpize desugar . maximum . fmap P.pkgVersion $ pids) + P.mainLibSet --TODO take into account sublibraries + + -- if multiple packages are found, we refuse to choose between + -- different packages and make the user do it + grps -> do + message v ("\nWarning: multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) + message v "You will need to pick one and manually add it to the build-depends field." + return Nothing + + _ -> do + message v ("\nWarning: no package found providing " ++ prettyShow m ++ ".") + return Nothing + + where + v = fromFlagOrDefault normal (initVerbosity flags) + + -- desugar if cabal version lower than 2.0 + desugar = case cabalVersion flags of + Flag x -> x < CabalSpecV2_0 + NoFlag -> defaultCabalVersion < CabalSpecV2_0 + +-- | Given a version, return an API-compatible (according to PVP) version range. -- --- Shared utilities used by multiple cabal init modules. +-- If the boolean argument denotes whether to use a desugared +-- representation (if 'True') or the new-style @^>=@-form (if +-- 'False'). -- ------------------------------------------------------------------------------ +-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the +-- same as @0.4.*@). +pvpize :: Bool -> Version -> VersionRange +pvpize False v = majorBoundVersion v +pvpize True v = orLaterVersion v' + `intersectVersionRanges` + earlierVersion (incVersion 1 v') + where + v' = alterVersion (take 2) v -module Distribution.Client.Init.Utils ( - eligibleForTestSuite - , message - ) where + -- Increment the nth version component (counting from 0). + incVersion :: Int -> Version -> Version + incVersion n = alterVersion (incVersion' n) + where + incVersion' 0 [] = [1] + incVersion' 0 (v'':_) = [v'' + 1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v'':vs) = v'' : incVersion' (m-1) vs -import Distribution.Solver.Compat.Prelude -import Prelude () +versionParser :: Parsec String () String +versionParser = do + skipMany (noneOf "1234567890") + many $ choice + [ oneOf "1234567890" + , oneOf "." + ] -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..) ) - --- | Returns true if this package is eligible for test suite initialization. -eligibleForTestSuite :: InitFlags -> Bool -eligibleForTestSuite flags = - Flag True == initializeTestSuite flags - && Flag Executable /= packageType flags - --- | Possibly generate a message to stdout, taking into account the --- --quiet flag. -message :: InitFlags -> String -> IO () -message (InitFlags{quiet = Flag True}) _ = return () -message _ s = putStrLn s +filePathToPkgName :: FilePath -> P.PackageName +filePathToPkgName = PN.mkPackageName . Prelude.last . splitDirectories + +currentDirPkgName :: Interactive m => m P.PackageName +currentDirPkgName = filePathToPkgName <$> getCurrentDirectory + +mkPackageNameDep :: PackageName -> Dependency +mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 445bf48e42d..b7cd6793880 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -84,7 +84,7 @@ import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Dependency import Distribution.Client.Dependency.Types import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Init (incVersion) +import Distribution.Client.Utils (incVersion) import Distribution.Client.Targets (userToPackageConstraint) import Distribution.Client.DistDirLayout import Distribution.Client.SetupWrapper @@ -1758,7 +1758,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB -- package needs to be rebuilt. (It needs to be done here, -- because the ElaboratedConfiguredPackage is where we test -- whether or not there have been changes.) - TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] + TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ] where tests, benchmarks :: Maybe Bool diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 59a04be4738..32c875c09a2 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -71,7 +71,7 @@ import Distribution.Client.IndexUtils.ActiveRepos import Distribution.Client.IndexUtils.IndexState ( TotalIndexState, headTotalIndexState ) import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..), PackageType(..), defaultInitFlags ) +import qualified Distribution.Client.Init.Defaults as IT import Distribution.Client.Targets ( UserConstraint, readUserConstraint ) import Distribution.Utils.NubList @@ -2215,14 +2215,13 @@ initOptions _ = , option ['c'] ["category"] "Project category." IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) + (reqArgFlag "CATEGORY") , option ['x'] ["extra-source-file"] "Extra source file to be distributed with tarball." IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) - (reqArg' "FILE" (Just . (:[])) - (fromMaybe [])) + (reqArg' "FILE" (Flag . (:[])) + (fromFlagOrDefault [])) , option [] ["lib", "is-library"] "Build a library." @@ -2250,8 +2249,8 @@ initOptions _ = , option [] ["test-dir"] "Directory containing tests." IT.testDirs (\v flags -> flags { IT.testDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) + (reqArg' "DIR" (Flag . (:[])) + (fromFlagOrDefault [])) , option [] ["simple"] "Create a simple project with sensible defaults." @@ -2278,41 +2277,41 @@ initOptions _ = IT.exposedModules (\v flags -> flags { IT.exposedModules = v }) (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) , option [] ["extension"] "Use a LANGUAGE extension (in the other-extensions field)." IT.otherExts (\v flags -> flags { IT.otherExts = v }) (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) , option ['d'] ["dependency"] "Package dependency." IT.dependencies (\v flags -> flags { IT.dependencies = v }) (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) , option [] ["application-dir"] "Directory containing package application executable." IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) + (reqArg' "DIR" (Flag . (:[])) + (fromFlagOrDefault [])) , option [] ["source-dir", "sourcedir"] "Directory containing package library source." IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) + (reqArg' "DIR" (Flag. (:[])) + (fromFlagOrDefault [])) , option [] ["build-tool"] "Required external build tool." IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) + (reqArg' "TOOL" (Flag . (:[])) + (fromFlagOrDefault [])) -- NB: this is a bit of a transitional hack and will likely be -- removed again if `cabal init` is migrated to the v2-* command diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index c52eee302ed..9803a55d46c 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -1,27 +1,33 @@ {-# LANGUAGE ForeignFunctionInterface, CPP #-} -module Distribution.Client.Utils ( MergeResult(..) - , mergeBy, duplicates, duplicatesBy - , readMaybe - , inDir, withEnv, withEnvOverrides - , logDirChange, withExtraPathEnv - , determineNumJobs, numberOfProcessors - , removeExistingFile - , withTempFileName - , makeAbsoluteToCwd - , makeRelativeToCwd, makeRelativeToDir - , makeRelativeCanonical - , filePathToByteString - , byteStringToFilePath, tryCanonicalizePath - , canonicalizePathNoThrow - , moreRecentFile, existsAndIsMoreRecentThan - , tryFindAddSourcePackageDesc - , tryFindPackageDesc - , relaxEncodingErrors - , ProgressPhase (..) - , progressMessage - , cabalInstallVersion) - where +module Distribution.Client.Utils + ( MergeResult(..) + , mergeBy, duplicates, duplicatesBy + , readMaybe + , inDir, withEnv, withEnvOverrides + , logDirChange, withExtraPathEnv + , determineNumJobs, numberOfProcessors + , removeExistingFile + , withTempFileName + , makeAbsoluteToCwd + , makeRelativeToCwd, makeRelativeToDir + , makeRelativeCanonical + , filePathToByteString + , byteStringToFilePath, tryCanonicalizePath + , canonicalizePathNoThrow + , moreRecentFile, existsAndIsMoreRecentThan + , tryFindAddSourcePackageDesc + , tryFindPackageDesc + , relaxEncodingErrors + , ProgressPhase (..) + , progressMessage + , cabalInstallVersion + , pvpize + , incVersion + , getCurrentYear + , listFilesRecursive + , listFilesInside + ) where import Prelude () import Distribution.Client.Compat.Prelude @@ -44,7 +50,7 @@ import qualified Control.Exception as Exception ( finally, bracket ) import System.Directory ( canonicalizePath, doesFileExist, getCurrentDirectory - , removeFile, setCurrentDirectory ) + , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist ) import System.IO ( Handle, hClose, openTempFile , hGetEncoding, hSetEncoding @@ -55,14 +61,16 @@ import GHC.IO.Encoding ( recover, TextEncoding(TextEncoding) ) import GHC.IO.Encoding.Failure ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) - +import Data.Time.Clock.POSIX (getCurrentTime) +import Data.Time.LocalTime (getCurrentTimeZone, localDay) +import Data.Time (utcToLocalTime) +import Data.Time.Calendar (toGregorian) #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import qualified System.Directory as Dir import qualified System.IO.Error as IOError #endif - -- | Generic merging utility. For sorted input lists this is a full outer join. -- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] @@ -359,5 +367,86 @@ progressMessage verbosity phase subject = do ProgressInstalling -> "Installing " ProgressCompleted -> "Completed " +-- TODO: write a test around this. Don't abuse Paths_cabal_install. +-- cabalInstallVersion :: Version cabalInstallVersion = mkVersion [3,5] + +-- | Given a version, return an API-compatible (according to PVP) version range. +-- +-- If the boolean argument denotes whether to use a desugared +-- representation (if 'True') or the new-style @^>=@-form (if +-- 'False'). +-- +-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the +-- same as @0.4.*@). +pvpize :: Bool -> Version -> VersionRange +pvpize False v = majorBoundVersion v +pvpize True v = orLaterVersion v' + `intersectVersionRanges` + earlierVersion (incVersion 1 v') + where v' = alterVersion (take 2) v + +-- | Increment the nth version component (counting from 0). +incVersion :: Int -> Version -> Version +incVersion n = alterVersion (incVersion' n) + where + incVersion' 0 [] = [1] + incVersion' 0 (v:_) = [v+1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v:vs) = v : incVersion' (m-1) vs + +-- | Returns the current calendar year. +getCurrentYear :: IO Integer +getCurrentYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do + (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir + rest <- concatMapM (listFilesInside test) dirs + pure $ files ++ rest + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listFilesRecursive :: FilePath -> IO [FilePath] +listFilesRecursive = listFilesInside (const $ pure True) + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listContents :: FilePath -> IO [FilePath] +listContents dir = do + xs <- getDirectoryContents dir + pure $ sort [dir x | x <- xs, not $ all (== '.') x] + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM b t f = do b' <- b; if b' then t else f + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +{-# INLINE concatMapM #-} +concatMapM op = foldr f (pure []) + where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; pure $ x' ++ xs' + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +notM :: Functor m => m Bool -> m Bool +notM = fmap not diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index 5783d9fce54..1c08f86adda 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -24,7 +24,8 @@ import qualified UnitTests.Distribution.Client.Get main :: IO () -main = +main = do + initTests <- UnitTests.Distribution.Client.Init.tests defaultMain $ testGroup "Unit Tests" [ testGroup "UnitTests.Distribution.Solver.Modular.Builder" UnitTests.Distribution.Solver.Modular.Builder.tests @@ -40,7 +41,7 @@ main = , testGroup "Distribution.Client.GZipUtils" UnitTests.Distribution.Client.GZipUtils.tests , testGroup "Distribution.Client.Init" - UnitTests.Distribution.Client.Init.tests + initTests , testGroup "Distribution.Client.Store" UnitTests.Distribution.Client.Store.tests , testGroup "Distribution.Client.Tar" diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs index 9a2f042482b..30e08474c47 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs @@ -1,220 +1,49 @@ module UnitTests.Distribution.Client.Init - ( tests - ) where - -import Distribution.Client.Init.FileCreators - ( generateCabalFile ) +( tests +) where import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Golden (goldenVsString) - -import System.FilePath - ( () ) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS8 - -import Distribution.Client.Init.Command - ( getLibOrExec, getAppDir, getSrcDir ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), defaultInitFlags ) -import Distribution.Simple.Setup - ( Flag(..) ) - -import Distribution.CabalSpecVersion - ( CabalSpecVersion(CabalSpecV2_4) ) -import Distribution.Types.Dependency - ( Dependency, mkDependency, mainLibSet ) -import Distribution.Types.PackageName - ( mkPackageName ) -import Distribution.Types.VersionRange - ( majorBoundVersion ) -import Distribution.Types.Version - ( mkVersion ) -import qualified Distribution.ModuleName as ModuleName - ( fromString ) -import qualified Distribution.SPDX as SPDX -import Language.Haskell.Extension ( Language(..) ) - -tests :: [TestTree] -tests = [ testGroup "cabal init goldens" - [ checkCabalFileGolden exeFlags "exe-only-golden.cabal" - , checkCabalFileGolden libAndExeFlags "lib-and-exe-golden.cabal" - , checkCabalFileGolden libExeAndTestFlags "lib-exe-and-test-golden.cabal" - , checkCabalFileGolden libExeAndTestWithCommentsFlags "lib-exe-and-test-with-comments-golden.cabal" - ] - , testGroup "Check init flag outputs against init script builds" - [ checkInitFlags "Check library-only build flags" libFlags Library - , checkInitFlags "Check lib+exe build flags" libAndExeFlags LibraryAndExecutable - , checkInitFlags "Check exe-only build flags" exeFlags Executable - ] - ] - -checkCabalFileGolden :: InitFlags -> FilePath -> TestTree -checkCabalFileGolden flags goldenFileName = - goldenVsString goldenFileName goldenFilePath generatedCabalFile - where - goldenFilePath :: FilePath - goldenFilePath = "tests" "fixtures" "init" goldenFileName - - generatedCabalFile :: IO BS.ByteString - generatedCabalFile = pure . BS8.pack $ generateCabalFile goldenFileName flags - -checkInitFlags :: String -> InitFlags -> PackageType -> TestTree -checkInitFlags label flags pkgType = testCase label $ do - flags' <- getLibOrExec rawFlags - >>= getAppDir - >>= getSrcDir - - flags @=? flags' - where - rawFlags - | pkgType == Executable = baseFlags - { packageType = Flag pkgType - , exposedModules = Nothing - } - | otherwise = baseFlags { packageType = Flag pkgType } - - --- ================================================== --- Base flags to set common InitFlags values. - -baseFlags :: InitFlags -baseFlags = defaultInitFlags { - -- Values common to all (or most) test flags. - packageName = Flag (mkPackageName "foo") - , noComments = Flag False - , minimal = Flag True - , version = Flag (mkVersion [3,2,1]) - , synopsis = Flag "The foo package" - , homepage = Flag "https://github.com/foo/foo" - , license = Flag SPDX.NONE - , author = Flag "me" - , email = Flag "me@me.me" - , category = Flag (Left "SomeCat") - , cabalVersion = Flag CabalSpecV2_4 - , extraSrc = Just ["CHANGELOG.md"] - , interactive = Flag False - , otherModules = Nothing - , otherExts = Nothing - , language = Flag Haskell2010 - , buildTools = Nothing - , dependencies = Just testDependencies - , quiet = Flag True - , packageDir = NoFlag - , simpleProject = Flag False - , initHcPath = NoFlag - , overwrite = NoFlag - -- Commonly overridden values in test InitFlags. - -- It is fine to provide the same value in an overridden InitFlags - -- to make it clear what that particular test case is differentiating - -- from others. - , packageType = Flag Executable - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - , sourceDirs = Nothing - , exposedModules = Just [ModuleName.fromString "MyLib"] - , initializeTestSuite = Flag False - , testDirs = Nothing - } +import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive +import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive +import qualified UnitTests.Distribution.Client.Init.Golden as Golden +import qualified UnitTests.Distribution.Client.Init.Simple as Simple +import UnitTests.Distribution.Client.Init.Utils --- ================================================== --- Simple library flags - -libFlags :: InitFlags -libFlags = baseFlags - { packageType = Flag Library - , mainIs = NoFlag - , sourceDirs = Just ["src"] - , applicationDirs = Just [] - } - --- ================================================== --- Simple exe. - -exeFlags :: InitFlags -exeFlags = baseFlags { - -- Create an executable only, with main living in app/Main.hs. - packageType = Flag Executable - , mainIs = Flag "Main.hs" - , sourceDirs = Just [] - , applicationDirs = Just ["app"] - , exposedModules = Nothing - } - - --- ================================================== --- Simple lib and exe (as created by `cabal init --libandexe`). --- --- Specifically, having 'exposedModules = Just ["MyLib"]' is a special --- case which results in the executable depending on the library from --- the same package, i.e. 'build-depends = foo' with no version --- constraints. - -libAndExeFlags :: InitFlags -libAndExeFlags = baseFlags { - -- Create a library and executable - packageType = Flag LibraryAndExecutable - - -- Main living in app/Main.hs. - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - - -- Library sources live in src/ and expose the module MyLib. - , sourceDirs = Just ["src"] - } - - --- ================================================== --- Lib, exe, and test suite - -libExeAndTestFlags :: InitFlags -libExeAndTestFlags = baseFlags { - -- Create a library and executable - packageType = Flag LibraryAndExecutable - - -- Main living in app/Main.hs. - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] +import Distribution.Client.Config +import Distribution.Client.IndexUtils +import Distribution.Client.Init.Types +import Distribution.Client.Sandbox +import Distribution.Client.Setup +import Distribution.Verbosity - -- Library sources live in src/ and expose the modules A and B. - , sourceDirs = Just ["src"] - , exposedModules = Just (map ModuleName.fromString ["A", "B"]) - -- Create a test suite living in tests/ - , initializeTestSuite = Flag True - , testDirs = Just ["tests"] - } +tests :: IO [TestTree] +tests = do + confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags --- ================================================== --- Lib, exe, and test suite with comments. + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` emptyFlags + globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags -libExeAndTestWithCommentsFlags :: InitFlags -libExeAndTestWithCommentsFlags = libExeAndTestFlags { - minimal = Flag False - , noComments = Flag False - , quiet = Flag False - } + (comp, _, progdb) <- configCompilerAux' confFlags' + withRepoContext v globalFlags' $ \repoCtx -> do + let pkgDb = configPackageDB' confFlags' + pkgIx <- getInstalledPackages v comp pkgDb progdb + srcDb <- getSourcePackages v repoCtx --- ================================================== --- Test dependency. + return + [ Interactive.tests v initFlags' comp pkgIx srcDb + , NonInteractive.tests v initFlags' comp pkgIx srcDb + , Golden.tests v initFlags' comp pkgIx srcDb + , Simple.tests v initFlags' comp pkgIx srcDb + ] + where + v :: Verbosity + v = normal -testDependencies :: [Dependency] -testDependencies = - [ mkDependency - (mkPackageName "base") - (majorBoundVersion (mkVersion [4,13,0,0])) - mainLibSet - , mkDependency - (mkPackageName "containers") - (majorBoundVersion (mkVersion [5,7,0,0])) - mainLibSet - , mkDependency - (mkPackageName "unordered-containers") - (majorBoundVersion (mkVersion [2,7,0,0])) - mainLibSet - ] + compFlags :: ConfigFlags + compFlags = mempty { configHcPath = initHcPath emptyFlags } diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs new file mode 100644 index 00000000000..34052296ef7 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +module UnitTests.Distribution.Client.Init.Golden +( tests +) where + + +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit + +import qualified Data.ByteString.Lazy.Char8 as BS8 +import Data.List.NonEmpty (fromList) +import Data.List.NonEmpty as NEL (NonEmpty) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif + +import Distribution.Client.Init.Types +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Verbosity +import Distribution.Simple.Compiler +import Distribution.Client.Types.SourcePackageDb +import Distribution.Client.Init.Interactive.Command +import Distribution.Client.Init.Format +import Distribution.Fields.Pretty +import Distribution.Types.PackageName (PackageName) +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Flag +import Distribution.CabalSpecVersion + +import System.FilePath + +import UnitTests.Distribution.Client.Init.Utils + +-- -------------------------------------------------------------------- -- +-- golden test suite + +-- | Golden executable tests. +-- +-- We test target generation against a golden file in @tests/fixtures/init/@ for +-- executables, libraries, and test targets with the following: +-- +-- * Empty flags, non-simple target gen, no special options +-- * Empty flags, simple target gen, no special options +-- * Empty flags, non-simple target gen, with generated comments (no minimal setting) +-- * Empty flags, non-simple target gen, with minimal setting (no generated comments) +-- * Empty flags, non-simple target gen, minimal and generated comments set. +-- +-- Additionally, we test whole @.cabal@ file generation for every combination +-- of library, lib + tests, exe, exe + tests, exe + lib, exe + lib + tests +-- and so on against the same options. +-- +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v initFlags _comp pkgIx srcDb = testGroup "golden" + [ goldenLibTests v pkgIx pkgDir pkgName + , goldenExeTests v pkgIx pkgDir pkgName + , goldenTestTests v pkgIx pkgDir pkgName + , goldenPkgDescTests v srcDb pkgDir pkgName + , goldenCabalTests v pkgIx srcDb + ] + where + pkgDir = evalPrompt (getPackageDir initFlags) + $ fromList ["."] + pkgName = evalPrompt (packageNamePrompt srcDb initFlags) + $ fromList ["test-package", "y"] + +-- goldenCabalTests +-- :: Verbosity +-- -> InstalledPackageIndex +-- -> FilePath +-- -> PackageName +-- -> SourcePackageDb +-- -> TestTree +-- goldenCabalTests v pkgIx pkgDir pkgName srcDb = testGroup ".cabal golden tests" +-- [ goldenVsString "Create lib .cabal project" (goldenCabal "lib-cabal.golden") $ +-- runGoldenCabal emptyFlags { packageType = Flag Library } +-- , goldenVsString "Create lib+test .cabal project" (goldenCabal "lib-test-cabal.golden") $ +-- runGoldenCabal emptyFlags +-- { packageType = Flag Library +-- , initializeTestSuite = Flag True +-- } +-- , goldenVsString "Create lib .cabal project" (goldenCabal "exe-cabal.golden") $ +-- runGoldenCabal emptyFlags { packageType = Flag Executable } +-- ] +-- where +-- runGoldenCabal flags = +-- case _runPrompt (createProject v pkgIx srcDb flags) of +-- Right (t, _) -> return . BS8.pack $ showFields' +-- annCommentLines postProcessFieldLines +-- 4 [mkCabalStanza opts t] +-- Left e -> assertFailure $ show e + +goldenPkgDescTests + :: Verbosity + -> SourcePackageDb + -> FilePath + -> PackageName + -> TestTree +goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golden tests" + [ goldenVsString "Empty flags, non-simple, no comments" + (goldenPkgDesc "pkg.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runPkgDesc opts emptyFlags pkgArgs + + , goldenVsString "Empty flags, non-simple, with comments" + (goldenPkgDesc "pkg-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runPkgDesc opts emptyFlags pkgArgs + + , goldenVsString "Dummy flags, with comments" + (goldenPkgDesc "pkg-with-flags.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runPkgDesc opts dummyFlags pkgArgs + + , goldenVsString "Dummy flags, old cabal version, with comments" + (goldenPkgDesc "pkg-old-cabal-with-flags.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV2_0}) pkgArgs + ] + where + runPkgDesc opts flags args = do + case _runPrompt (genPkgDescription flags srcDb) args of + Left e -> assertFailure $ show e + Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg + +goldenExeTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenExeTests v pkgIx pkgDir pkgName = testGroup "exe golden tests" + [ goldenVsString "Empty flags, not simple, no options" + (goldenExe "exe.golden") $ + let opts = WriteOpts False False True v pkgDir Executable pkgName + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenExe "exe-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Executable pkgName + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenExe "exe-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Executable pkgName + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenExe "exe-simple-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Executable pkgName + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenExe "exe-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Executable pkgName + in runGoldenExe opts exeArgs (emptyFlags {buildTools = Flag ["happy"]}) + ] + where + runGoldenExe opts args flags = + case _runPrompt (genExeTarget flags pkgIx) args of + Right (t, _) -> mkStanza [mkExeStanza opts $ t {_exeDependencies = mangleBaseDep t _exeDependencies}] + Left e -> assertFailure $ show e + +goldenLibTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenLibTests v pkgIx pkgDir pkgName = testGroup "lib golden tests" + [ goldenVsString "Empty flags, not simple, no options" + (goldenLib "lib.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, simple, no options" (goldenLib "lib-simple.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenLib "lib-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenLib "lib-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Library pkgName + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenLib "lib-simple-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Library pkgName + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenLib "lib-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runGoldenLib opts libArgs (emptyFlags {buildTools = Flag ["happy"]}) + ] + where + runGoldenLib opts args flags = + case _runPrompt (genLibTarget flags pkgIx) args of + Right (t, _) -> mkStanza [mkLibStanza opts $ t {_libDependencies = mangleBaseDep t _libDependencies}] + Left e -> assertFailure $ show e + +goldenTestTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenTestTests v pkgIx pkgDir pkgName = testGroup "test golden tests" + [ goldenVsString "Empty flags, not simple, no options" + (goldenTest "test.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenTest "test-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenTest "test-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Library pkgName + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenTest "test-simple-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Library pkgName + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenTest "test-simple-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Library pkgName + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenTest "test-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName + in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]}) + ] + where + runGoldenTest opts args flags = + case _runPrompt (genTestTarget flags pkgIx) args of + Left e -> assertFailure $ show e + Right (Nothing, _) -> assertFailure + "goldenTestTests: Tests not enabled." + Right (Just t, _) -> mkStanza [mkTestStanza opts $ t {_testDependencies = mangleBaseDep t _testDependencies}] + +-- | Full cabal file golden tests +goldenCabalTests + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +goldenCabalTests v pkgIx srcDb = testGroup ".cabal file golden tests" + [ goldenVsString "Library and executable, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-and-exe-with-comments.golden") $ + runGoldenTest (fullProjArgs "Y") emptyFlags + + , goldenVsString "Library and executable, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-and-exe-no-comments.golden") $ + runGoldenTest (fullProjArgs "N") emptyFlags + + , goldenVsString "Library, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-with-comments.golden") $ + runGoldenTest (libProjArgs "Y") emptyFlags + + , goldenVsString "Library, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-no-comments.golden") $ + runGoldenTest (libProjArgs "N") emptyFlags + ] + where + runGoldenTest args flags = + case _runPrompt (createProject v pkgIx srcDb flags) args of + Left e -> assertFailure $ show e + + (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do + let pkgFields = mkPkgDescription opts pkgDesc + libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} + exeStanza = mkExeStanza opts $ exeTarget {_exeDependencies = mangleBaseDep exeTarget _exeDependencies} + testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + + mkStanza $ pkgFields ++ [libStanza, exeStanza, testStanza] + + (Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do + let pkgFields = mkPkgDescription opts pkgDesc + libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} + testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + + mkStanza $ pkgFields ++ [libStanza, testStanza] + + (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $ + show l ++ "\n" ++ show e ++ "\n" ++ show t + + +-- -------------------------------------------------------------------- -- +-- utils + +mkStanza :: [PrettyField FieldAnnotation] -> IO BS8.ByteString +mkStanza fields = return . BS8.pack $ showFields' + annCommentLines postProcessFieldLines + 4 fields + +golden :: FilePath +golden = "tests" "fixtures" "init" "golden" + +goldenExe :: FilePath -> FilePath +goldenExe file = golden "exe" file + +goldenTest :: FilePath -> FilePath +goldenTest file = golden "test" file + +goldenLib :: FilePath -> FilePath +goldenLib file = golden "lib" file + +goldenCabal :: FilePath -> FilePath +goldenCabal file = golden "cabal" file + +goldenPkgDesc :: FilePath -> FilePath +goldenPkgDesc file = golden "pkg-desc" file + +libArgs :: NonEmpty String +libArgs = fromList ["1", "2"] + +exeArgs :: NonEmpty String +exeArgs = fromList ["1", "2", "1"] + +testArgs :: NonEmpty String +testArgs = fromList ["y", "1", "test", "1"] + +pkgArgs :: NonEmpty String +pkgArgs = fromList + [ "4" + , "foo-package" + , "y" + , "0.1.0.0" + , "2" + , "foo-kmett" + , "foo-kmett@kmett.kmett" + , "home" + , "synopsis" + , "4" + ] + +libProjArgs :: String -> NonEmpty String +libProjArgs comments = fromList ["1", "foo-package"] + <> pkgArgs + <> libArgs + <> testArgs + <> fromList [comments] + +fullProjArgs :: String -> NonEmpty String +fullProjArgs comments = fromList ["3", "foo-package"] + <> pkgArgs + <> libArgs + <> exeArgs + <> testArgs + <> fromList [comments] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs new file mode 100644 index 00000000000..4b85e741f07 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -0,0 +1,832 @@ +module UnitTests.Distribution.Client.Init.Interactive +( tests +) where + + +import Prelude as P +import Test.Tasty +import Test.Tasty.HUnit + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Interactive.Command +import Distribution.Client.Init.Types + +import qualified Distribution.SPDX as SPDX + +import Data.List.NonEmpty hiding (zip) +import Distribution.Client.Types +import Distribution.Simple.Compiler +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Types.PackageName +import Distribution.Types.Version +import Distribution.Verbosity + +import Language.Haskell.Extension + +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Setup +import Distribution.CabalSpecVersion + + +-- -------------------------------------------------------------------- -- +-- Init Test main + +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests _v initFlags _comp pkgIx srcDb = + testGroup "Distribution.Client.Init.Interactive.Command.hs" + [ createProjectTest pkgIx srcDb + , fileCreatorTests pkgIx srcDb pkgName + , interactiveTests srcDb + ] + where + pkgName = evalPrompt (packageNamePrompt srcDb initFlags) $ + fromList ["test-package", "y"] + + -- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"] + +createProjectTest + :: InstalledPackageIndex + -> SourcePackageDb + -> TestTree +createProjectTest pkgIx srcDb = testGroup "createProject tests" + [ testGroup "with flags" + [ testCase "Check the non-interactive workflow" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + + case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["3", "quxTest/Main.hs"]) of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + + , testGroup "with tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = fromList + -- package type + [ "3" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "Foobar" + -- email + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- test target + -- main file + , "1" + -- test dir + , "test" + -- language + , "1" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb (emptyFlags {initializeTestSuite = Flag True})) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow" $ do + let inputs = fromList + -- package type + [ "1" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "Foobar" + -- email + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- test target + -- main file + , "1" + -- test dir + , "test" + -- language + , "1" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb (emptyFlags {initializeTestSuite = Flag True})) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "without tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = fromList + -- package type + [ "3" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "Foobar" + -- email + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- test suite + , "n" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow" $ do + let inputs = fromList + -- package type + [ "1" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "Foobar" + -- email + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- test suite + , "n" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive executable workflow" $ do + let inputs = fromList + -- package type + [ "2" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "Foobar" + -- email + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" :| [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] + ] + +fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> PackageName -> TestTree +fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators" + [ testGroup "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first cabal version in the list + , "my-test-package" -- package name + , "y" -- "yes to prompt internal to package name" + , "0.2.0.1" -- package version + , "2" -- pick the second license in the list + , "Foobar" -- author name + , "foobar@qux.com" -- maintainer email + , "qux.com" -- package homepage + , "Qux's package" -- package synopsis + , "3" -- pick the third category in the list + ] + runGenTest inputs $ genPkgDescription emptyFlags srcDb + ] + , testGroup "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first source directory in the list + , "2" -- pick the second language in the list + ] + + runGenTest inputs $ genLibTarget emptyFlags pkgIx + ] + , testGroup "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first main file option in the list + , "2" -- pick the second application directory in the list + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genExeTarget emptyFlags pkgIx + ] + , testGroup "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first main file option in the list + , "test" -- package test dir + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genTestTarget + (emptyFlags {initializeTestSuite = Flag True}) pkgIx + ] + ] + where + runGenTest inputs go = case _runPrompt go inputs of + Left e -> assertFailure $ show e + Right{} -> return () + +interactiveTests :: SourcePackageDb -> TestTree +interactiveTests srcDb = testGroup "Check top level getter functions" + [ testGroup "Simple prompt tests" + [ testGroup "Check packageNamePrompt output" + [ testSimplePrompt "New package name 1" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "test-package" + ] + , testSimplePrompt "New package name 2" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "" + ] + , testSimplePrompt "Existing package name 1" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "cabal-install" + , "y" + , "test-package" + ] + , testSimplePrompt "Existing package name 2" + (packageNamePrompt srcDb) (mkPackageName "cabal-install") + [ "test-package" + , "cabal-install" + , "n" + ] + ] + , testGroup "Check mainFilePrompt output" + [ testSimplePrompt "New valid main file" + mainFilePrompt defaultMainIs + [ "1" + ] + , testSimplePrompt "New valid other main file" + mainFilePrompt (HsFilePath "Main.hs" Standard) + [ "3" + , "Main.hs" + ] + , testSimplePrompt "Invalid other main file" + mainFilePrompt (HsFilePath "Main.lhs" Literate) + [ "3" + , "Yoink.jl" + , "2" + ] + ] + , testGroup "Check versionPrompt output" + [ testSimplePrompt "Proper PVP" + versionPrompt (mkVersion [0,3,1,0]) + [ "0.3.1.0" + ] + , testSimplePrompt "No PVP" + versionPrompt (mkVersion [0,3,1,0]) + [ "yee-haw" + , "0.3.1.0" + ] + ] + , testGroup "Check synopsisPrompt output" + [ testSimplePrompt "1" synopsisPrompt + "We are Qux, and this is our package" ["We are Qux, and this is our package"] + , testSimplePrompt "2" synopsisPrompt + "Resistance is futile, you will be assimilated" ["Resistance is futile, you will be assimilated"] + ] + , testSimplePrompt "Check authorPrompt output" authorPrompt + "Foobar" ["Foobar"] + , testSimplePrompt "Check emailPrompt output" emailPrompt + "foobar@qux.com" ["foobar@qux.com"] + , testSimplePrompt "Check homepagePrompt output" homepagePrompt + "qux.com" ["qux.com"] + , testSimplePrompt "Check testDirsPrompt output" testDirsPrompt + ["quxTest"] ["quxTest"] + -- this tests 4) other, and can be used to model more inputs in case of failure + , testSimplePrompt "Check srcDirsPrompt output" srcDirsPrompt + ["app"] ["4", "app"] + ] + , testGroup "Numbered prompt tests" + [ testGroup "Check categoryPrompt output" + [ testNumberedPrompt "Category indices" categoryPrompt + defaultCategories + , testSimplePrompt "Other category" + categoryPrompt "Unlisted" + [ show $ P.length defaultCategories + 1 + , "Unlisted" + ] + , testSimplePrompt "No category" + categoryPrompt "" + [ "" + ] + ] + , testGroup "Check licensePrompt output" $ let other = show (1 + P.length defaultLicenseIds) in + [ testNumberedPrompt "License indices" licensePrompt $ + fmap (\l -> SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds + , testSimplePrompt "Other license 1" + licensePrompt (mkLicense SPDX.CC_BY_NC_ND_4_0) + [ other + , "CC-BY-NC-ND-4.0" + ] + , testSimplePrompt "Other license 2" + licensePrompt (mkLicense SPDX.D_FSL_1_0) + [ other + , "D-FSL-1.0" + ] + , testSimplePrompt "Other license 3" + licensePrompt (mkLicense SPDX.NPOSL_3_0) + [ other + , "NPOSL-3.0" + ] + , testSimplePrompt "Invalid license" + licensePrompt SPDX.NONE + [ other + , "yay" + , other + , "NONE" + ] + , testPromptBreak "Invalid index" + licensePrompt + [ "42" + ] + ] + , testGroup "Check languagePrompt output" + [ testNumberedPrompt "Language indices" (`languagePrompt` "test") + [Haskell2010, Haskell98] + , testSimplePrompt "Other language" + (`languagePrompt` "test") (UnknownLanguage "Haskell2022") + [ "3" + , "Haskell2022" + ] + , testSimplePrompt "Invalid language" + (`languagePrompt` "test") Haskell2010 + [ "3" + , "Lang_TS!" + , "1" + ] + ] + , testGroup "Check srcDirsPrompt output" + [ testNumberedPrompt "Soruce dirs indices" srcDirsPrompt + [[defaultSourceDir], ["lib"], ["src-lib"]] + , testSimplePrompt "Other source dir" + srcDirsPrompt ["src"] + [ "4" + , "src" + ] + ] + , testGroup "Check appDirsPrompt output" + [ testNumberedPrompt "App dirs indices" appDirsPrompt + [[defaultApplicationDir], ["exe"], ["src-exe"]] + , testSimplePrompt "Other app dir" + appDirsPrompt ["app"] + [ "4" + , "app" + ] + ] + , testNumberedPrompt "Check packageTypePrompt output" packageTypePrompt + [Library, Executable, LibraryAndExecutable] + , testNumberedPrompt "Check cabalVersionPrompt output" cabalVersionPrompt + defaultCabalVersions + ] + , testGroup "Bool prompt tests" + [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y" + , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y" + , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n" + , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N" + ] + ] + + + +-- -------------------------------------------------------------------- -- +-- Prompt test utils + + +testSimplePrompt + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> a + -> [String] + -> TestTree +testSimplePrompt label f target = + testPrompt label f (assertFailure . show) (\(a,_) -> target @=? a) + +testPromptBreak + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> [String] + -> TestTree +testPromptBreak label f = + testPrompt label f go (assertFailure . show) + where + go BreakException{} = + return () + +testPrompt + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> (BreakException -> Assertion) + -> ((a, NonEmpty String) -> Assertion) + -> [String] + -> TestTree +testPrompt label f g h input = testCase label $ + case (_runPrompt $ f emptyFlags) (fromList input) of + Left x -> g x -- :: BreakException + Right x -> h x -- :: (a, other inputs) + +testNumberedPrompt :: (Eq a, Show a) => String -> (InitFlags -> PurePrompt a) -> [a] -> TestTree +testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexed1 + where + indexed1 = zip [1 :: Int ..] + mkLabel a n = "testing index " + ++ show n + ++ ") with: " + ++ show a + + go (n, a) = + testSimplePrompt (mkLabel a n) act a [show n] + goBreak = + [ testPromptBreak "testing index -1" act ["-1"] + , testPromptBreak "testing index 1000" act ["1000"] + ] + +testBoolPrompt + :: String + -> (InitFlags -> PurePrompt Bool) + -> Bool + -> String + -> TestTree +testBoolPrompt label act target b = + testSimplePrompt label act target [b] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs new file mode 100644 index 00000000000..69e38d31609 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -0,0 +1,1158 @@ +module UnitTests.Distribution.Client.Init.NonInteractive + ( tests + ) where + +import Test.Tasty +import Test.Tasty.HUnit + +import UnitTests.Distribution.Client.Init.Utils + +import qualified Data.List.NonEmpty as NEL +import qualified Distribution.SPDX as SPDX + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.NonInteractive.Command +import Distribution.Client.Init.Types +import Distribution.Client.Types +import Distribution.Simple +import Distribution.Simple.PackageIndex +import Distribution.Verbosity +import Distribution.CabalSpecVersion +import Distribution.ModuleName (fromString) +import Distribution.Simple.Flag + +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests _v _initFlags _comp pkgIx srcDb = + testGroup "cabal init non-interactive" + [ testGroup "driver function test" + [ driverFunctionTest pkgIx srcDb + ] + , testGroup "target creator tests" + [ fileCreatorTests pkgIx srcDb + ] + , testGroup "non-interactive tests" + [ nonInteractiveTests pkgIx srcDb + ] + ] + +driverFunctionTest + :: InstalledPackageIndex + -> SourcePackageDb + -> TestTree +driverFunctionTest pkgIx srcDb = testGroup "createProject" + [ testGroup "with flags" + [ testCase "Check the non-interactive workflow 1" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = NEL.fromList + [ "[\"quxTest/Main.hs\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?= [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?= [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive workflow 2" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = Flag [] + , exposedModules = Flag [] + , otherModules = NoFlag + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = NEL.fromList + -- extra sources + [ "[\"CHANGELOG.md\"]" + -- lib other modules + , "False" + -- exe other modules + , "False" + -- test main file + , "[\"quxTest/Main.hs\"]" + -- test other modules + , "False" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?= [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?= [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "with tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 8.8.4" + -- exposed modules + , "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"src/Foo.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "[]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"app/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- test target + -- main file + , "[\"test-package/test/\"]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"test/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb (emptyFlags {initializeTestSuite = Flag True})) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "(none)" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= ["happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= ["happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= ["happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive library workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\", \"test/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "Foobar" + -- author email + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 8.8.4" + -- exposed modules + , "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"src/Foo.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- test target + -- main file + , "[\"test-package/test/\"]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"test/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb (emptyFlags {initializeTestSuite = Flag True})) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "(none)" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= ["happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= ["happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "without tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 8.8.4" + -- exposed modules + , "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"src/Foo.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "[]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"app/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "(none)" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= ["happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= ["happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive library workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 8.8.4" + -- exposed modules + , "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"src/Foo.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "(none)" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= ["happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive executable workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "[]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"app/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= SPDX.NONE + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "(none)" + _pkgExtraSrcFiles desc @?= "CHANGELOG.md" NEL.:| [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= ["happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] + ] + +fileCreatorTests + :: InstalledPackageIndex + -> SourcePackageDb + -> TestTree +fileCreatorTests pkgIx srcDb = testGroup "generators" + [ testGroup "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = NEL.fromList + -- cabal version + [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + ] + + case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = NEL.fromList + -- source dirs + [ "src" + , "True" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- exposed modules + , "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"src/Foo.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genLibTarget emptyFlags pkgIx) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = NEL.fromList + -- application dirs + [ "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "[]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"app/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genExeTarget emptyFlags pkgIx) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = NEL.fromList + -- main file + [ "[]" + -- language + , "The Glorious Glasgow Haskell Compilation System, version 7.10.3" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "[\"test/Main.hs\"]" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case (_runPrompt $ genTestTarget (emptyFlags {initializeTestSuite = Flag True}) pkgIx) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + ] + +nonInteractiveTests + :: InstalledPackageIndex + -> SourcePackageDb + -> TestTree +nonInteractiveTests _pkgIx srcDb = testGroup "Check top level getter functions" + [ testGroup "Simple heuristics tests" + [ testGroup "Check packageNameHeuristics output" + [ testSimple "New package name" (packageNameHeuristics srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + ] + , testSimple "Existing package name" (packageNameHeuristics srcDb) + (mkPackageName "cabal-install") + [ "test-package" + , "cabal-install" + ] + ] + , testSimple "Check authorHeuristics output" authorHeuristics "Foobar" + [ "" + , "Foobar" + ] + , testSimple "Check emailHeuristics output" emailHeuristics "foobar@qux.com" + [ "" + , "foobar@qux.com" + ] + , testSimple "Check srcDirsHeuristics output" srcDirsHeuristics ["src"] + [ "src" + , "True" + ] + , testSimple "Check appDirsHeuristics output" appDirsHeuristics ["app"] + [ "test-package" + , "[\"test-package/app/\"]" + ] + , testGroup "Check packageTypeHeuristics output" + [ testSimple "Library" packageTypeHeuristics Library + [ "test-package" + , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" + ] + , testSimple "Executable" packageTypeHeuristics Executable + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + ] + , testSimple "Library and Executable" packageTypeHeuristics LibraryAndExecutable + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + ] + ] + , testGroup "Check cabalVersionHeuristics output" + [ testSimple "Broken command" cabalVersionHeuristics defaultCabalVersion + [""] + , testSimple "Proper answer" cabalVersionHeuristics CabalSpecV2_4 + ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"] + ] + , testGroup "Check languageHeuristics output" + [ testSimple "No compiler at all" languageHeuristics Haskell2010 + [""] + , testSimple "Higher version compiler" languageHeuristics Haskell2010 + ["The Glorious Glasgow Haskell Compilation System, version 7.10.3"] + , testSimple "Lower version compiler" languageHeuristics Haskell98 + ["The Glorious Glasgow Haskell Compilation System, version 6.4.2"] + ] + , testGroup "Check extraSourceFilesHeuristics output" + [ testSimple "No extra sources" extraSourceFilesHeuristics + (defaultChangelog NEL.:| []) + [ "test-package" + , "[]" + ] + , testSimple "Extra source files present" extraSourceFilesHeuristics + ("README.md" NEL.:| []) + [ "test-package" + , "[\"README.md\"]" + ] + ] + , testGroup "Check mainFileHeuristics output" + [ testSimple "No main file defined" mainFileHeuristics + (toHsFilePath "Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "[]" + ] + , testSimple "Main file already defined" mainFileHeuristics + (toHsFilePath "app/Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "[\"app/Main.hs\"]" + ] + , testSimple "Main lhs file already defined" mainFileHeuristics + (toHsFilePath "app/Main.lhs") + [ "test-package" + , "[\"test-package/app/\"]" + , "[\"app/Main.lhs\"]" + ] + ] + , testGroup "Check exposedModulesHeuristics output" + [ testSimple "Default exposed modules" exposedModulesHeuristics + (myLibModule NEL.:| []) + [ "src" + , "True" + , "[]" + , "test-package" + , "True" + , "[]" + ] + , testSimple "Contains exposed modules" exposedModulesHeuristics + (NEL.fromList $ map fromString ["Foo", "Bar"]) + [ "src" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + ] + , testGroup "Check libOtherModulesHeuristics output" + [ testSimple "Library directory exists" libOtherModulesHeuristics + (map fromString ["Baz.Internal"]) + [ "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + ] + , testSimple "Library directory doesn't exist" libOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testGroup "Check exeOtherModulesHeuristics output" + [ testSimple "Executable directory exists" exeOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple "Executable directory doesn't exist" exeOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testGroup "Check testOtherModulesHeuristics output" + [ testSimple "Test directory exists" testOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple "Test directory doesn't exist" testOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testSimple "Check buildToolsHeuristics output" (`buildToolsHeuristics` "") ["happy"] + ["[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"] + , testSimple "Check otherExtsHeuristics output" (`otherExtsHeuristics` "") + (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]) + [ "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + ] + + , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0,1,0,0]) [""] + , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""] + , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""] + , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""] + , testSimple "Check categoryHeuristics output" categoryHeuristics "(none)" [""] + , testSimple "Check minimalHeuristics output" minimalHeuristics False [""] + , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""] + , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""] + , testSimple "Check licenseHeuristics output" licenseHeuristics SPDX.NONE [""] + ] + , testGroup "Bool heuristics tests" + [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False "" + ] + ] + +testSimple + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> a + -> [String] + -> TestTree +testSimple label f target = + testGo label f (assertFailure . show) (\(a, _) -> target @=? a) + +testBool + :: String + -> (InitFlags -> PurePrompt Bool) + -> Bool + -> String + -> TestTree +testBool label f target input = + testSimple label f target [input] + +testGo + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> (BreakException -> Assertion) + -> ((a, NEL.NonEmpty String) -> Assertion) + -> [String] + -> TestTree +testGo label f g h inputs = testCase label $ + case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of + Left x -> g x + Right x -> h x diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs new file mode 100644 index 00000000000..059fc334c89 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -0,0 +1,151 @@ +module UnitTests.Distribution.Client.Init.Simple +( tests +) where + + +import Prelude as P +import Test.Tasty +import Test.Tasty.HUnit + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Simple +import Distribution.Client.Init.Types + + +import Data.List.NonEmpty hiding (zip) +import Distribution.Client.Types +import Distribution.Simple.Compiler +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Types.PackageName +import Distribution.Verbosity + + +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Simple.Setup +import qualified Data.List.NonEmpty as NEL +import Distribution.Types.Dependency +import Distribution.Client.Init.Utils (mkPackageNameDep) + +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v _initFlags _comp pkgIx srcDb = testGroup "Distribution.Client.Init.Simple.hs" + [ simpleCreateProjectTests v pkgIx srcDb pkgName + ] + where + pkgName = mkPackageName "simple-test" + +simpleCreateProjectTests + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> PackageName + -> TestTree +simpleCreateProjectTests v pkgIx srcDb pkgName = + testGroup "Simple createProject tests" + [ testCase "Simple lib createProject - no tests" $ do + let inputs = fromList + [ "1" -- package type: Library + , "simple-test" -- package dir (ignored, piped to current dir due to prompt monad) + , "n" -- no tests + ] + + flags = emptyFlags { packageType = Flag Library } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName) + (simplePkgDesc pkgName) (Just simpleLibTarget) + Nothing Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple lib createProject - with tests" $ do + let inputs = fromList ["1", "simple-test", "y", "1"] + flags = emptyFlags { packageType = Flag Library } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName) + (simplePkgDesc pkgName) (Just simpleLibTarget) + Nothing (Just $ simpleTestTarget (Just pkgName)) + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple exe createProject" $ do + let inputs = fromList ["2", "simple-test"] + flags = emptyFlags { packageType = Flag Executable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" Executable pkgName) + (simplePkgDesc pkgName) Nothing + (Just $ simpleExeTarget Nothing) Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple lib+exe createProject - no tests" $ do + let inputs = fromList ["2", "simple-test", "n"] + flags = emptyFlags { packageType = Flag LibraryAndExecutable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName) + (simplePkgDesc pkgName) (Just simpleLibTarget) + (Just $ simpleExeTarget (Just pkgName)) Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e + Right (settings', _) -> settings @=? settings' + , testCase "Simple lib+exe createProject - with tests" $ do + let inputs = fromList ["2", "simple-test", "y", "1"] + flags = emptyFlags { packageType = Flag LibraryAndExecutable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName) + (simplePkgDesc pkgName) (Just simpleLibTarget) + (Just $ simpleExeTarget (Just pkgName)) + (Just $ simpleTestTarget (Just pkgName)) + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e + Right (settings', _) -> settings @=? settings' + ] + +-- -------------------------------------------------------------------- -- +-- Utils + +mkPkgDep :: Maybe PackageName -> [Dependency] +mkPkgDep Nothing = [] +mkPkgDep (Just pn) = [mkPackageNameDep pn] + +simplePkgDesc :: PackageName -> PkgDescription +simplePkgDesc pkgName = PkgDescription + defaultCabalVersion + pkgName + defaultVersion + defaultLicense + "" "" "" "" "" + (defaultChangelog NEL.:| []) + +simpleLibTarget :: LibTarget +simpleLibTarget = LibTarget + [defaultSourceDir] + defaultLanguage + (myLibModule NEL.:| []) + [] [] [] [] + +simpleExeTarget :: Maybe PackageName -> ExeTarget +simpleExeTarget pn = ExeTarget + defaultMainIs + [defaultApplicationDir] + defaultLanguage + [] [] (mkPkgDep pn) [] + +simpleTestTarget :: Maybe PackageName -> TestTarget +simpleTestTarget pn = TestTarget + defaultMainIs + [defaultTestDir] + defaultLanguage + [] [] (mkPkgDep pn) [] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs new file mode 100644 index 00000000000..199f6f6eb67 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs @@ -0,0 +1,82 @@ +module UnitTests.Distribution.Client.Init.Utils +( dummyFlags +, emptyFlags +, mkLicense +, mangleBaseDep +, (@?!) +, (@!?) +) where + + +import Distribution.Client.Init.Types + +import qualified Distribution.SPDX as SPDX + +import Distribution.CabalSpecVersion +import Distribution.Simple.Setup +import Distribution.Types.PackageName +import Distribution.Types.Version +import Language.Haskell.Extension +import Test.Tasty.HUnit +import Distribution.Types.Dependency +import Distribution.Types.VersionRange + + +-- -------------------------------------------------------------------- -- +-- Test flags + +dummyFlags :: InitFlags +dummyFlags = emptyFlags + { noComments = Flag True + , packageName = Flag (mkPackageName "QuxPackage") + , version = Flag (mkVersion [4,2,6]) + , cabalVersion = Flag CabalSpecV2_2 + , license = Flag $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing + , author = Flag "Foobar" + , email = Flag "foobar@qux.com" + , homepage = Flag "qux.com" + , synopsis = Flag "We are Qux, and this is our package" + , category = Flag "Control" + , language = Flag Haskell98 + , initializeTestSuite = Flag True + , sourceDirs = Flag ["quxSrc"] + , testDirs = Flag ["quxTest"] + , applicationDirs = Flag ["quxApp"] + } + +emptyFlags :: InitFlags +emptyFlags = mempty + +-- -------------------------------------------------------------------- -- +-- Test utils + +mkLicense :: SPDX.LicenseId -> SPDX.License +mkLicense lid = SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing) + +mangleBaseDep :: a -> (a -> [Dependency]) -> [Dependency] +mangleBaseDep target f = + [ if unPackageName x == "base" + then Dependency x anyVersion z + else dep + | dep@(Dependency x _ z) <- f target + ] + +infix 1 @?!, @!? + +-- | Just like @'@?='@, except it checks for difference rather than equality. +(@?!) + :: (Eq a, Show a, HasCallStack) + => a + -> a + -> Assertion +actual @?! unexpected = assertBool + ("unexpected: " ++ show unexpected) + (actual /= unexpected) + +-- | Just like @'@=?'@, except it checks for difference rather than equality. +(@!?) + :: (Eq a, Show a, HasCallStack) + => a + -> a + -> Assertion +(@!?) = flip (@?!) diff --git a/cabal-install/tests/fixtures/init/exe-only-golden.cabal b/cabal-install/tests/fixtures/init/exe-only-golden.cabal deleted file mode 100644 index 8887173111b..00000000000 --- a/cabal-install/tests/fixtures/init/exe-only-golden.cabal +++ /dev/null @@ -1,20 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: app - default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden new file mode 100644 index 00000000000..8c75394d2c8 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden @@ -0,0 +1,61 @@ +cabal-version: 2.4 +name: y +version: 0.1.0.0 +synopsis: synopsis + +-- A longer description of the package. +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 + +executable y + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + base, + y + + hs-source-dirs: exe + default-language: Haskell2010 + +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + y + diff --git a/cabal-install/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden similarity index 65% rename from cabal-install/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal rename to cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden index adfaea7733b..f0b2b216bda 100644 --- a/cabal-install/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal +++ b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden @@ -1,54 +1,53 @@ cabal-version: 2.4 --- Initial package description 'lib-exe-and-test-with-comments-golden.cabal' generated by +-- Initial package description 'y' generated by -- 'cabal init'. For further documentation, see: -- http://haskell.org/cabal/users-guide/ -- -- The name of the package. -name: foo +name: y -- The package version. -- See the Haskell package versioning policy (PVP) for standards -- guiding when and how versions should be incremented. -- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 3.2.1 +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 -- A short (one-line) description of the package. -synopsis: The foo package +synopsis: synopsis -- A longer description of the package. -- description: -- URL for the project homepage or repository. -homepage: https://github.com/foo/foo - --- A URL where users can report bugs. --- bug-reports: +homepage: home -- The license under which the package is released. -license: NONE +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE -- The package author(s). -author: me +author: foo-kmett -- An email address to which users can send suggestions, bug reports, and patches. -maintainer: me@me.me +maintainer: foo-kmett@kmett.kmett -- A copyright notice. -- copyright: -category: SomeCat +category: Data +build-type: Simple -- Extra files to be distributed with the package, such as examples or a README. extra-source-files: CHANGELOG.md library -- Modules exported by the library. - exposed-modules: - A - B + exposed-modules: MyLib -- Modules included in this library but not exported. -- other-modules: @@ -57,18 +56,15 @@ library -- other-extensions: -- Other library packages from which modules are imported. - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 + build-depends: base -- Directories containing source files. hs-source-dirs: src -- Base language which the package is written in. - default-language: Haskell2010 + default-language: Haskell98 -executable foo +executable y -- .hs or .lhs file containing the Main module. main-is: Main.hs @@ -80,31 +76,36 @@ executable foo -- Other library packages from which modules are imported. build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 + base, + y -- Directories containing source files. - hs-source-dirs: app + hs-source-dirs: exe -- Base language which the package is written in. default-language: Haskell2010 -test-suite foo-test +test-suite y-test -- Base language which the package is written in. default-language: Haskell2010 + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + -- The interface type and version of the test suite. type: exitcode-stdio-1.0 -- Directories containing source files. - hs-source-dirs: tests + hs-source-dirs: test -- The entrypoint to the test suite. - main-is: MyLibTest.hs + main-is: Main.hs -- Test dependencies. build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 + base, + y + diff --git a/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden new file mode 100644 index 00000000000..336bd3fb210 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 +name: y +version: 0.1.0.0 +synopsis: synopsis + +-- A longer description of the package. +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 + +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + y + diff --git a/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden new file mode 100644 index 00000000000..14b06a911c5 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden @@ -0,0 +1,90 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md + +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 + +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base, + y + diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden b/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden new file mode 100644 index 00000000000..cbf34dde765 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden @@ -0,0 +1,21 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: exe + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden b/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden new file mode 100644 index 00000000000..88d69ab18db --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden @@ -0,0 +1,5 @@ +executable y + main-is: Main.hs + build-depends: base + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden b/cabal-install/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden new file mode 100644 index 00000000000..19fdb84a1a6 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden @@ -0,0 +1,12 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe-simple.golden b/cabal-install/tests/fixtures/init/golden/exe/exe-simple.golden new file mode 100644 index 00000000000..e6dfaa77ebe --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe-simple.golden @@ -0,0 +1,13 @@ +executable y + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + -- build-depends: + hs-source-dirs: app + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden b/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden new file mode 100644 index 00000000000..deb7bb063da --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden @@ -0,0 +1,18 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/exe/exe.golden b/cabal-install/tests/fixtures/init/golden/exe/exe.golden new file mode 100644 index 00000000000..3f4d9c54fe6 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/exe/exe.golden @@ -0,0 +1,11 @@ +executable y + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden b/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden new file mode 100644 index 00000000000..436ed85d096 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden @@ -0,0 +1,21 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden b/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden new file mode 100644 index 00000000000..99e5d7fffb8 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden @@ -0,0 +1,5 @@ +library + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden b/cabal-install/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden new file mode 100644 index 00000000000..5583deefa19 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden @@ -0,0 +1,12 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib-simple.golden b/cabal-install/tests/fixtures/init/golden/lib/lib-simple.golden new file mode 100644 index 00000000000..8dd9dbcecbd --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib-simple.golden @@ -0,0 +1,11 @@ +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden b/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden new file mode 100644 index 00000000000..d64fb60b613 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden @@ -0,0 +1,18 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/lib/lib.golden b/cabal-install/tests/fixtures/init/golden/lib/lib.golden new file mode 100644 index 00000000000..8dd9dbcecbd --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/lib/lib.golden @@ -0,0 +1,11 @@ +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden new file mode 100644 index 00000000000..776f6abd320 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden @@ -0,0 +1,45 @@ +cabal-version: 2.0 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-simple.golden b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-simple.golden new file mode 100644 index 00000000000..b44bf495121 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-simple.golden @@ -0,0 +1,21 @@ +cabal-version: 3.0 +name: 4 +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: +license: NONE + +-- The package author(s). +-- author: + +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: + +-- A copyright notice. +-- copyright: +build-type: Simple +extra-source-files: CHANGELOG.md diff --git a/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden new file mode 100644 index 00000000000..47924235c7f --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden new file mode 100644 index 00000000000..52613c0f0d7 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden @@ -0,0 +1,46 @@ +cabal-version: 2.2 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden new file mode 100644 index 00000000000..47924235c7f --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden b/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden new file mode 100644 index 00000000000..5171d02708a --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden @@ -0,0 +1,24 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy diff --git a/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden b/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden new file mode 100644 index 00000000000..b092956a6d2 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden @@ -0,0 +1,6 @@ +test-suite y-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal-install/tests/fixtures/init/golden/test/test-simple-with-comments.golden b/cabal-install/tests/fixtures/init/golden/test/test-simple-with-comments.golden new file mode 100644 index 00000000000..6388f8583de --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test-simple-with-comments.golden @@ -0,0 +1,15 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base diff --git a/cabal-install/tests/fixtures/init/golden/test/test-simple.golden b/cabal-install/tests/fixtures/init/golden/test/test-simple.golden new file mode 100644 index 00000000000..44095ab9a95 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test-simple.golden @@ -0,0 +1,14 @@ +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + -- Test dependencies. + -- build-depends: diff --git a/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden b/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden new file mode 100644 index 00000000000..2381ebd092e --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden @@ -0,0 +1,21 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base diff --git a/cabal-install/tests/fixtures/init/golden/test/test.golden b/cabal-install/tests/fixtures/init/golden/test/test.golden new file mode 100644 index 00000000000..7a36e096fb2 --- /dev/null +++ b/cabal-install/tests/fixtures/init/golden/test/test.golden @@ -0,0 +1,12 @@ +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal-install/tests/fixtures/init/lib-and-exe-golden.cabal b/cabal-install/tests/fixtures/init/lib-and-exe-golden.cabal deleted file mode 100644 index d90c89bed19..00000000000 --- a/cabal-install/tests/fixtures/init/lib-and-exe-golden.cabal +++ /dev/null @@ -1,31 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -library - exposed-modules: MyLib - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: src - default-language: Haskell2010 - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0, - foo - - hs-source-dirs: app - default-language: Haskell2010 diff --git a/cabal-install/tests/fixtures/init/lib-exe-and-test-golden.cabal b/cabal-install/tests/fixtures/init/lib-exe-and-test-golden.cabal deleted file mode 100644 index 924237c2dea..00000000000 --- a/cabal-install/tests/fixtures/init/lib-exe-and-test-golden.cabal +++ /dev/null @@ -1,43 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -library - exposed-modules: - A - B - - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: src - default-language: Haskell2010 - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: app - default-language: Haskell2010 - -test-suite foo-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: MyLibTest.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 diff --git a/cabal.project b/cabal.project index e07642f2a2c..fd4b237b37f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,7 +1,8 @@ packages: Cabal/ cabal-testsuite/ -packages: cabal-install-solver/ packages: cabal-install/ +packages: cabal-install-solver/ packages: solver-benchmarks/ + tests: True packages: Cabal-QuickCheck/ diff --git a/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden b/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden new file mode 100644 index 00000000000..32e4d1ca857 --- /dev/null +++ b/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden @@ -0,0 +1,61 @@ +cabal-version: 2.4 +name: y +version: 0.1.0.0 +synopsis: synopsis + +-- A longer description of the package. +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell98 + +executable y + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + base ^>=4.14.1.0, + y + + hs-source-dirs: exe + default-language: Haskell2010 + +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base ^>=4.14.1.0, + y + diff --git a/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden b/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden new file mode 100644 index 00000000000..7dcde8264b2 --- /dev/null +++ b/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden @@ -0,0 +1,111 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md + +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 + +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + base ^>=4.14.1.0, + y + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base ^>=4.14.1.0, + y + diff --git a/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden b/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden new file mode 100644 index 00000000000..6cceb218542 --- /dev/null +++ b/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 +name: y +version: 0.1.0.0 +synopsis: synopsis + +-- A longer description of the package. +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell98 + +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base ^>=4.14.1.0, + y + diff --git a/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden b/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden new file mode 100644 index 00000000000..0ec5e6be0eb --- /dev/null +++ b/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden @@ -0,0 +1,90 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md + +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 + +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base ^>=4.14.1.0, + y + diff --git a/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden b/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden new file mode 100644 index 00000000000..b2e99868127 --- /dev/null +++ b/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden @@ -0,0 +1,21 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: exe + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden b/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden new file mode 100644 index 00000000000..35810f1662a --- /dev/null +++ b/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden @@ -0,0 +1,5 @@ +executable y + main-is: Main.hs + build-depends: base ^>=4.14.1.0 + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden b/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden new file mode 100644 index 00000000000..a791a4a0eed --- /dev/null +++ b/tests/fixtures/init/golden/exe/exe-simple-with-comments.golden @@ -0,0 +1,12 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/tests/fixtures/init/golden/exe/exe-with-comments.golden b/tests/fixtures/init/golden/exe/exe-with-comments.golden new file mode 100644 index 00000000000..d7a0a16e9b8 --- /dev/null +++ b/tests/fixtures/init/golden/exe/exe-with-comments.golden @@ -0,0 +1,18 @@ +executable y + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/tests/fixtures/init/golden/exe/exe.golden b/tests/fixtures/init/golden/exe/exe.golden new file mode 100644 index 00000000000..c61210c04ea --- /dev/null +++ b/tests/fixtures/init/golden/exe/exe.golden @@ -0,0 +1,11 @@ +executable y + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden b/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden new file mode 100644 index 00000000000..8d41c633f60 --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden @@ -0,0 +1,21 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: src + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden b/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden new file mode 100644 index 00000000000..64c71f80310 --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden @@ -0,0 +1,5 @@ +library + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden b/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden new file mode 100644 index 00000000000..f6daa328415 --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib-simple-with-comments.golden @@ -0,0 +1,12 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/lib/lib-simple.golden b/tests/fixtures/init/golden/lib/lib-simple.golden new file mode 100644 index 00000000000..61271518061 --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib-simple.golden @@ -0,0 +1,11 @@ +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/lib/lib-with-comments.golden b/tests/fixtures/init/golden/lib/lib-with-comments.golden new file mode 100644 index 00000000000..84ba9445f2a --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib-with-comments.golden @@ -0,0 +1,18 @@ +library + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.14.1.0 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/lib/lib.golden b/tests/fixtures/init/golden/lib/lib.golden new file mode 100644 index 00000000000..61271518061 --- /dev/null +++ b/tests/fixtures/init/golden/lib/lib.golden @@ -0,0 +1,11 @@ +library + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell98 diff --git a/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden b/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden new file mode 100644 index 00000000000..776f6abd320 --- /dev/null +++ b/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden @@ -0,0 +1,45 @@ +cabal-version: 2.0 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden b/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden new file mode 100644 index 00000000000..47924235c7f --- /dev/null +++ b/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden b/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden new file mode 100644 index 00000000000..52613c0f0d7 --- /dev/null +++ b/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden @@ -0,0 +1,46 @@ +cabal-version: 2.2 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/tests/fixtures/init/golden/pkg-desc/pkg.golden b/tests/fixtures/init/golden/pkg-desc/pkg.golden new file mode 100644 index 00000000000..47924235c7f --- /dev/null +++ b/tests/fixtures/init/golden/pkg-desc/pkg.golden @@ -0,0 +1,46 @@ +cabal-version: 2.4 + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: CHANGELOG.md diff --git a/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden b/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden new file mode 100644 index 00000000000..1377709f290 --- /dev/null +++ b/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden @@ -0,0 +1,24 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base ^>=4.14.1.0 + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tools: happy diff --git a/tests/fixtures/init/golden/test/test-minimal-no-comments.golden b/tests/fixtures/init/golden/test/test-minimal-no-comments.golden new file mode 100644 index 00000000000..b7560beb966 --- /dev/null +++ b/tests/fixtures/init/golden/test/test-minimal-no-comments.golden @@ -0,0 +1,6 @@ +test-suite y-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base ^>=4.14.1.0 diff --git a/tests/fixtures/init/golden/test/test-simple-with-comments.golden b/tests/fixtures/init/golden/test/test-simple-with-comments.golden new file mode 100644 index 00000000000..0ebefd519b6 --- /dev/null +++ b/tests/fixtures/init/golden/test/test-simple-with-comments.golden @@ -0,0 +1,15 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base ^>=4.14.1.0 diff --git a/tests/fixtures/init/golden/test/test-with-comments.golden b/tests/fixtures/init/golden/test/test-with-comments.golden new file mode 100644 index 00000000000..df91ae84267 --- /dev/null +++ b/tests/fixtures/init/golden/test/test-with-comments.golden @@ -0,0 +1,21 @@ +test-suite y-test + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base ^>=4.14.1.0 diff --git a/tests/fixtures/init/golden/test/test.golden b/tests/fixtures/init/golden/test/test.golden new file mode 100644 index 00000000000..6bafb438873 --- /dev/null +++ b/tests/fixtures/init/golden/test/test.golden @@ -0,0 +1,12 @@ +test-suite y-test + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base ^>=4.14.1.0