----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init -- 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 ( -- * Commands initCabal , incVersion ) where import Prelude () import Distribution.Client.Compat.Prelude hiding (empty) import Distribution.Deprecated.ReadP (readP_to_E) import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath ( (), (<.>), takeBaseName, takeExtension, equalFilePath ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List ( (\\) ) import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Map as M import qualified Data.Set as Set import Control.Monad ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow ( (&&&), (***) ) import Text.PrettyPrint hiding (mode, cat) import Distribution.Version ( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity ( Verbosity ) import Distribution.ModuleName ( ModuleName ) -- And for the Text instance import qualified Distribution.ModuleName as ModuleName ( fromString, toFilePath ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P import Distribution.Types.LibraryName ( LibraryName(..) ) import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types ( InitFlags(..), BuildType(..), PackageType(..), Category(..) , displayPackageType ) import Distribution.Client.Init.Licenses ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, SourceFileEntry(..), scanForModules, neededBuildPrograms ) import Distribution.License ( License(..), knownLicenses, licenseToSPDX ) import qualified Distribution.SPDX as SPDX import Distribution.ReadE ( runReadE ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe ) import Distribution.Simple.Utils ( dropWhileEndLE ) import Distribution.Simple.Configure ( getInstalledPackages ) import Distribution.Simple.Compiler ( PackageDBStack, Compiler ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Deprecated.Text ( display, Text(..) ) import Distribution.Pretty ( prettyShow ) import Distribution.Parsec ( eitherParsec ) 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 installedPkgIndex sourcePkgDb initFlags case license initFlags' of Flag PublicDomain -> return () _ -> writeLicense initFlags' writeSetupFile initFlags' writeChangeLog initFlags' createDirectories (sourceDirs initFlags') createLibHs initFlags' createDirectories (applicationDirs initFlags') createMainHs initFlags' -- If a test suite was requested and this is not an executable-only -- package, then create the "test" directory. when (eligibleForTestSuite initFlags') $ do createDirectories (testDirs initFlags') createTestHs initFlags' success <- writeCabalFile initFlags' when success $ generateWarnings initFlags' --------------------------------------------------------------------------- -- Flag acquisition ----------------------------------------------------- --------------------------------------------------------------------------- -- | Fill in more details by guessing, discovering, or prompting the -- user. extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags extendFlags pkgIx sourcePkgDb = getSimpleProject >=> getLibOrExec >=> getCabalVersion >=> getPackageName sourcePkgDb >=> 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 -- | Witness the isomorphism between Maybe and Flag. maybeToFlag :: Maybe a -> Flag a maybeToFlag = maybe NoFlag Flag defaultCabalVersion :: Version defaultCabalVersion = mkVersion [1,10] displayCabalVersion :: Version -> String displayCabalVersion v = case versionNumbers v of [1,10] -> "1.10 (legacy)" [2,0] -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" [2,2] -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" [2,4] -> "2.4 (+ support for '**' globbing)" _ -> display v -- | 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 (mkVersion [2,4]) } simpleProjFlag@_ -> flags { simpleProject = simpleProjFlag } -- | Ask which version of the cabal spec to use. 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" [mkVersion [1,10], mkVersion [2,0], mkVersion [2,2], mkVersion [2,4]] (Just defaultCabalVersion) displayCabalVersion False) ?>> return (Just defaultCabalVersion) return $ flags { cabalVersion = maybeToFlag cabVer } -- | 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 :: SourcePackageDb -> InitFlags -> IO InitFlags getPackageName sourcePkgDb flags = do guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) let guess' | isPkgRegistered guess = Nothing | otherwise = guess pkgName' <- return (flagToMaybe $ packageName flags) ?>> maybePrompt flags (prompt "Package name" guess') ?>> return guess' chooseAgain <- if isPkgRegistered pkgName' then promptYesNo promptOtherNameMsg (Just True) else return False if chooseAgain then getPackageName sourcePkgDb flags else return $ flags { packageName = maybeToFlag pkgName' } where isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg isPkgRegistered Nothing = False promptOtherNameMsg = "This package name is already used by another " ++ "package on hackage. 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. getLicense :: InitFlags -> IO InitFlags getLicense flags = do lic <- return (flagToMaybe $ license flags) ?>> fmap (fmap (either UnknownLicense id)) (maybePrompt flags (promptList "Please choose a license" listedLicenses (Just BSD3) displayLicense True)) case checkLicenseInvalid lic of Just msg -> putStrLn msg >> getLicense flags Nothing -> return $ flags { license = maybeToFlag lic } where displayLicense l | needSpdx = prettyShow (licenseToSPDX l) | otherwise = display l checkLicenseInvalid (Just (UnknownLicense t)) | needSpdx = case eitherParsec t :: Either String SPDX.License of Right _ -> Nothing Left _ -> Just "\nThe license must be a valid SPDX expression." | otherwise = if any (not . isAlphaNum) t then Just promptInvalidOtherLicenseMsg else Nothing checkLicenseInvalid _ = Nothing promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++ "If your license name has many words, " ++ "the convention is to use camel case (e.g. PublicDomain). " ++ "Please choose a different license." listedLicenses = knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing , Apache Nothing, OtherLicense] needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags) -- | 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. 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 root directory. getTestDir :: InitFlags -> IO InitFlags getTestDir flags = do dirs <- return (testDirs flags) -- Only need testDirs when test suite generation is enabled. ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt flags (promptList "Test directory" ["test"] (Just "test") id True)) return $ flags { testDirs = dirs } -- | Ask for the base language of the package. getLanguage :: InitFlags -> IO InitFlags getLanguage flags = do lang <- return (flagToMaybe $ language flags) ?>> maybePrompt flags (either UnknownLanguage id `fmap` promptList "What base language is the package written in" [Haskell2010, Haskell98] (Just Haskell2010) display 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 <- return (applicationDirs flags) -- No application dir if this is a 'Library'. ?>> if (packageType flags) == Flag Library then return (Just []) else return Nothing ?>> fmap (:[]) `fmap` guessAppDir flags ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt flags (promptListOptional' ("Application " ++ mainFile ++ "directory") ["src-exe", "app"] id)) return $ flags { applicationDirs = appDirs } where 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 <- return (sourceDirs flags) -- source dir if this is an 'Executable'. ?>> if (packageType flags) == Flag Executable then return (Just []) else return Nothing ?>> fmap (:[]) `fmap` guessSourceDir flags ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt flags (promptListOptional' "Library source directory" ["src", "lib", "src-lib"] id)) return $ flags { sourceDirs = srcDirs } -- | 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 } 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 <$> mapM (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 " ++ display m ++ ".") >> return Nothing chooseDep flags (m, Just []) = message flags ("\nWarning: no package found providing " ++ display 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 " ++ display m ++ ": " ++ intercalate ", " (fmap (display . 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 (< mkVersion [2]) $ 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) (Set.singleton LMainLibName) --TODO sublibraries -- Otherwise, choose the latest version and issue a warning. toDep pids = do message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") return $ P.Dependency (P.pkgName . NE.head $ pids) (pvpize desugar . maximum . fmap P.pkgVersion $ pids) (Set.singleton LMainLibName) --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 -- | Returns true if this package is eligible for test suite initialization. eligibleForTestSuite :: InitFlags -> Bool eligibleForTestSuite flags = Flag True == initializeTestSuite flags && Flag Executable /= packageType flags --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- --------------------------------------------------------------------------- -- | 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 -- | Create a yes/no prompt with optional default value. -- promptYesNo :: String -> Maybe Bool -> IO Bool promptYesNo = promptDefault' recogniseYesNo showYesNo where recogniseYesNo s | s == "y" || s == "Y" = Just True | s == "n" || s == "N" = Just False | otherwise = Nothing showYesNo True = "y" showYesNo False = "n" -- | Create a prompt with optional default value that returns a value -- of some Text instance. prompt :: Text t => String -> Maybe t -> IO t prompt = promptDefault' (either (const Nothing) Just . runReadE (readP_to_E id parse)) display -- | 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 pretty pr def = do putStr $ mkDefPrompt pr (pretty `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 pretty pr def -- | 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 ++ "] " promptListOptional :: (Text t, Eq t) => String -- ^ prompt -> [t] -- ^ choices -> IO (Maybe (Either String t)) promptListOptional pr choices = promptListOptional' pr choices display 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 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]) mapM_ (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 --------------------------------------------------------------------------- -- File generation ------------------------------------------------------ --------------------------------------------------------------------------- writeLicense :: InitFlags -> IO () writeLicense flags = do message flags "\nGenerating LICENSE..." year <- show <$> getYear let authors = fromMaybe "???" . flagToMaybe . author $ flags let licenseFile = case license flags of Flag BSD2 -> Just $ bsd2 authors year Flag BSD3 -> Just $ bsd3 authors year Flag (GPL (Just v)) | v == mkVersion [2] -> Just gplv2 Flag (GPL (Just v)) | v == mkVersion [3] -> Just gplv3 Flag (LGPL (Just v)) | v == mkVersion [2,1] -> Just lgpl21 Flag (LGPL (Just v)) | v == mkVersion [3] -> Just lgpl3 Flag (AGPL (Just v)) | v == mkVersion [3] -> Just agplv3 Flag (Apache (Just v)) | v == mkVersion [2,0] -> Just apache20 Flag MIT -> Just $ mit authors year Flag (MPL v) | v == mkVersion [2,0] -> Just mpl20 Flag ISC -> Just $ isc authors year _ -> 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." getYear :: IO Integer getYear = do u <- getCurrentTime z <- getCurrentTimeZone let l = utcToLocalTime z u (y, _, _) = toGregorian $ localDay l return y writeSetupFile :: InitFlags -> IO () writeSetupFile flags = do message flags "Generating Setup.hs..." writeFileSafe flags "Setup.hs" setupFile where setupFile = unlines [ "import Distribution.Simple" , "main = defaultMain" ] writeChangeLog :: InitFlags -> IO () writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do message flags ("Generating "++ defaultChangeLog ++"...") writeFileSafe flags defaultChangeLog changeLog where changeLog = unlines [ "# Revision history for " ++ pname , "" , "## " ++ pver ++ " -- YYYY-mm-dd" , "" , "* First version. Released on an unsuspecting world." ] pname = maybe "" display $ flagToMaybe $ packageName flags pver = maybe "" display $ flagToMaybe $ version flags 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 = display 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 -> forM_ 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 myLibModule :: ModuleName myLibModule = ModuleName.fromString "MyLib" -- | 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) -- | Check that 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 "" = "" prependPrefix line | isLiterate = "> " ++ line | otherwise = line isLiterate = case mainIs flags of Flag mainPath -> takeExtension mainPath == ".lhs" _ -> False testFile :: String testFile = "MyLibTest.hs" -- | Create MyLibTest.hs, but only if we are init'ing a library and -- the initializeTestSuite flag has been set. createTestHs :: InitFlags -> IO () createTestHs flags = when (eligibleForTestSuite flags) $ case testDirs flags of Just (testPath:_) -> writeTestHs flags (testPath testFile) _ -> writeMainHs flags testFile --- | Write a test file. writeTestHs :: InitFlags -> FilePath -> IO () writeTestHs flags testPath = do dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) let testFullPath = dir testPath exists <- doesFileExist testFullPath unless exists $ do message flags $ "Generating " ++ testPath ++ "..." writeFileSafe flags testFullPath testHs -- | Default MyLibTest.hs file. testHs :: String testHs = unlines [ "module Main (main) where" , "" , "main :: IO ()" , "main = putStrLn \"Test suite not yet implemented.\"" ] -- | Move an existing file, if there is one, and the overwrite flag is -- not set. moveExistingFile :: InitFlags -> FilePath -> IO () 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 findNewName :: FilePath -> IO FilePath findNewName oldName = findNewName' 0 where findNewName' :: Integer -> IO FilePath findNewName' 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. NOTE: this -- is rather ad-hoc! What we would REALLY like is to have a -- standard low-level AST type representing .cabal files, which -- preserves things like comments, and to write an *inverse* -- parser/pretty-printer pair between .cabal files and this AST. -- Then instead of this ad-hoc code we could just map an InitFlags -- structure onto a low-level AST structure and use the existing -- pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c = trimTrailingWS $ (++ "\n") . renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ -- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD (if specVer < mkVersion [1,12] then field "cabal-version" (Flag $ orLaterVersion specVer) -- legacy else field "cabal-version" (Flag $ specVer)) Nothing -- NB: the first line must be the 'cabal-version' declaration False $$ (if minimal c /= Flag True then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated " ++ "by 'cabal init'. For further documentation, see " ++ "http://haskell.org/cabal/users-guide/") $$ text "" else empty) $$ vcat [ field "name" (packageName c) (Just "The name of the package.") True , field "version" (version c) (Just $ "The package version. See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://pvp.haskell.org\n" ++ "PVP summary: +-+------- breaking API changes\n" ++ " | | +----- non-breaking API additions\n" ++ " | | | +--- code changes with no API change") True , fieldS "synopsis" (synopsis c) (Just "A short (one-line) description of the package.") True , fieldS "description" NoFlag (Just "A longer description of the package.") True , fieldS "homepage" (homepage c) (Just "URL for the project homepage or repository.") False , fieldS "bug-reports" NoFlag (Just "A URL where users can report bugs.") True , fieldS "license" licenseStr (Just "The license under which the package is released.") True , case (license c) of Flag PublicDomain -> empty _ -> fieldS "license-file" (Flag "LICENSE") (Just "The file containing the license text.") True , fieldS "author" (author c) (Just "The package author(s).") True , fieldS "maintainer" (email c) (Just "An email address to which users can send suggestions, bug reports, and patches.") True , case (license c) of Flag PublicDomain -> empty _ -> fieldS "copyright" NoFlag (Just "A copyright notice.") True , fieldS "category" (either id display `fmap` category c) Nothing True , fieldS "build-type" (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple") Nothing False , fieldS "extra-source-files" (listFieldS (extraSrc c)) (Just "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 _ -> empty , if eligibleForTestSuite c then testSuiteStanza else empty ] where specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) licenseStr | specVer < mkVersion [2,2] = prettyShow `fmap` license c | otherwise = go `fmap` license c where go (UnknownLicense s) = s go l = prettyShow (licenseToSPDX l) generateBuildInfo :: BuildType -> InitFlags -> Doc generateBuildInfo buildType c' = vcat [ fieldS "other-modules" (listField otherMods) (Just $ case buildType of LibBuild -> "Modules included in this library but not exported." ExecBuild -> "Modules included in this executable, other than Main.") True , fieldS "other-extensions" (listField (otherExts c')) (Just "LANGUAGE extensions used by modules in this package.") True , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c')) (Just "Other library packages from which modules are imported.") True , fieldS "hs-source-dirs" (listFieldS (case buildType of LibBuild -> sourceDirs c' ExecBuild -> applicationDirs c')) (Just "Directories containing source files.") True , fieldS "build-tools" (listFieldS (buildTools c')) (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") False , field "default-language" (language c') (Just "Base language which the package is written in.") True ] -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). where myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild then case packageName c' of Flag pkgName -> ", " ++ P.unPackageName pkgName _ -> "" else "" -- Only include 'MyLib' in 'other-modules' of the executable. otherModsFromFlag = otherModules c' otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] then Nothing else otherModsFromFlag listField :: Text s => Maybe [s] -> Flag String listField = listFieldS . fmap (map display) listFieldS :: Maybe [String] -> Flag String listFieldS = Flag . maybe "" (intercalate ", ") field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc field s f = fieldS s (fmap display f) fieldS :: String -- ^ Name of the field -> Flag String -- ^ Field contents -> Maybe String -- ^ Comment to explain the field -> Bool -- ^ Should the field be included (commented out) even if blank? -> Doc fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty fieldS s f com _ = case (isJust com, noComments c, minimal c) of (_, _, Flag True) -> id (_, Flag True, _) -> id (True, _, _) -> (showComment com $$) . ($$ text "") (False, _, _) -> ($$ text "") $ comment f <<>> text s <<>> colon <<>> text (replicate (20 - length s) ' ') <<>> text (fromMaybe "" . flagToMaybe $ f) comment NoFlag = text "-- " comment (Flag "") = text "-- " comment _ = text "" showComment :: Maybe String -> Doc showComment (Just t) = vcat . map (text . ("-- "++)) . lines . renderStyle style { lineLength = 76, ribbonsPerLine = 1.05 } . vcat . map (fcat . map text . breakLine) . lines $ t showComment Nothing = text "" breakLine [] = [] breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' breakLine' [] = [] breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' trimTrailingWS :: String -> String trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines executableStanza :: Doc executableStanza = text "\nexecutable" <+> text (maybe "" display . flagToMaybe $ packageName c) $$ nest 2 (vcat [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True , generateBuildInfo ExecBuild c ]) libraryStanza :: Doc libraryStanza = text "\nlibrary" $$ nest 2 (vcat [ fieldS "exposed-modules" (listField (exposedModules c)) (Just "Modules exported by the library.") True , generateBuildInfo LibBuild c ]) testSuiteStanza :: Doc testSuiteStanza = text "\ntest-suite" <+> text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$ nest 2 (vcat [ field "default-language" (language c) (Just "Base language which the package is written in.") True , fieldS "type" (Flag "exitcode-stdio-1.0") (Just "The interface type and version of the test suite.") True , fieldS "hs-source-dirs" (listFieldS (testDirs c)) (Just "The directory where the test specifications are found.") True , fieldS "main-is" (Flag testFile) (Just "The entrypoint to the test suite.") True , fieldS "build-depends" (listField (dependencies c)) (Just "Test dependencies.") True ]) -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO () 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." -- | 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