1----------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.Client.Init 4-- Copyright : (c) Brent Yorgey 2009 5-- License : BSD-like 6-- 7-- Maintainer : cabal-devel@haskell.org 8-- Stability : provisional 9-- Portability : portable 10-- 11-- Implementation of the 'cabal init' command, which creates an initial .cabal 12-- file for a project. 13-- 14----------------------------------------------------------------------------- 15 16module Distribution.Client.Init ( 17 18 -- * Commands 19 initCabal 20 , incVersion 21 22 ) where 23 24import Prelude () 25import Distribution.Client.Compat.Prelude hiding (empty) 26 27import Distribution.Deprecated.ReadP (readP_to_E) 28 29import System.IO 30 ( hSetBuffering, stdout, BufferMode(..) ) 31import System.Directory 32 ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile 33 , getDirectoryContents, createDirectoryIfMissing ) 34import System.FilePath 35 ( (</>), (<.>), takeBaseName, takeExtension, equalFilePath ) 36import Data.Time 37 ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) 38 39import Data.List 40 ( (\\) ) 41import qualified Data.List.NonEmpty as NE 42import Data.Function 43 ( on ) 44import qualified Data.Map as M 45import qualified Data.Set as Set 46import Control.Monad 47 ( (>=>), join, forM_, mapM, mapM_ ) 48import Control.Arrow 49 ( (&&&), (***) ) 50 51import Text.PrettyPrint hiding (mode, cat) 52 53import Distribution.Version 54 ( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion 55 , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) 56import Distribution.Verbosity 57 ( Verbosity ) 58import Distribution.ModuleName 59 ( ModuleName ) -- And for the Text instance 60import qualified Distribution.ModuleName as ModuleName 61 ( fromString, toFilePath ) 62import Distribution.InstalledPackageInfo 63 ( InstalledPackageInfo, exposed ) 64import qualified Distribution.Package as P 65import Distribution.Types.LibraryName 66 ( LibraryName(..) ) 67import Language.Haskell.Extension ( Language(..) ) 68 69import Distribution.Client.Init.Types 70 ( InitFlags(..), BuildType(..), PackageType(..), Category(..) 71 , displayPackageType ) 72import Distribution.Client.Init.Licenses 73 ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) 74import Distribution.Client.Init.Heuristics 75 ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, 76 SourceFileEntry(..), 77 scanForModules, neededBuildPrograms ) 78 79import Distribution.License 80 ( License(..), knownLicenses, licenseToSPDX ) 81import qualified Distribution.SPDX as SPDX 82 83import Distribution.ReadE 84 ( runReadE ) 85import Distribution.Simple.Setup 86 ( Flag(..), flagToMaybe ) 87import Distribution.Simple.Utils 88 ( dropWhileEndLE ) 89import Distribution.Simple.Configure 90 ( getInstalledPackages ) 91import Distribution.Simple.Compiler 92 ( PackageDBStack, Compiler ) 93import Distribution.Simple.Program 94 ( ProgramDb ) 95import Distribution.Simple.PackageIndex 96 ( InstalledPackageIndex, moduleNameIndex ) 97import Distribution.Deprecated.Text 98 ( display, Text(..) ) 99import Distribution.Pretty 100 ( prettyShow ) 101import Distribution.Parsec 102 ( eitherParsec ) 103 104import Distribution.Solver.Types.PackageIndex 105 ( elemByPackageName ) 106 107import Distribution.Client.IndexUtils 108 ( getSourcePackages ) 109import Distribution.Client.Types 110 ( SourcePackageDb(..) ) 111import Distribution.Client.Setup 112 ( RepoContext(..) ) 113 114initCabal :: Verbosity 115 -> PackageDBStack 116 -> RepoContext 117 -> Compiler 118 -> ProgramDb 119 -> InitFlags 120 -> IO () 121initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do 122 123 installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb 124 sourcePkgDb <- getSourcePackages verbosity repoCtxt 125 126 hSetBuffering stdout NoBuffering 127 128 initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags 129 130 case license initFlags' of 131 Flag PublicDomain -> return () 132 _ -> writeLicense initFlags' 133 writeSetupFile initFlags' 134 writeChangeLog initFlags' 135 createDirectories (sourceDirs initFlags') 136 createLibHs initFlags' 137 createDirectories (applicationDirs initFlags') 138 createMainHs initFlags' 139 -- If a test suite was requested and this is not an executable-only 140 -- package, then create the "test" directory. 141 when (eligibleForTestSuite initFlags') $ do 142 createDirectories (testDirs initFlags') 143 createTestHs initFlags' 144 success <- writeCabalFile initFlags' 145 146 when success $ generateWarnings initFlags' 147 148--------------------------------------------------------------------------- 149-- Flag acquisition ----------------------------------------------------- 150--------------------------------------------------------------------------- 151 152-- | Fill in more details by guessing, discovering, or prompting the 153-- user. 154extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags 155extendFlags pkgIx sourcePkgDb = 156 getSimpleProject 157 >=> getLibOrExec 158 >=> getCabalVersion 159 >=> getPackageName sourcePkgDb 160 >=> getVersion 161 >=> getLicense 162 >=> getAuthorInfo 163 >=> getHomepage 164 >=> getSynopsis 165 >=> getCategory 166 >=> getExtraSourceFiles 167 >=> getAppDir 168 >=> getSrcDir 169 >=> getGenTests 170 >=> getTestDir 171 >=> getLanguage 172 >=> getGenComments 173 >=> getModulesBuildToolsAndDeps pkgIx 174 175-- | Combine two actions which may return a value, preferring the first. That 176-- is, run the second action only if the first doesn't return a value. 177infixr 1 ?>> 178(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) 179f ?>> g = do 180 ma <- f 181 if isJust ma 182 then return ma 183 else g 184 185-- | Witness the isomorphism between Maybe and Flag. 186maybeToFlag :: Maybe a -> Flag a 187maybeToFlag = maybe NoFlag Flag 188 189defaultCabalVersion :: Version 190defaultCabalVersion = mkVersion [1,10] 191 192displayCabalVersion :: Version -> String 193displayCabalVersion v = case versionNumbers v of 194 [1,10] -> "1.10 (legacy)" 195 [2,0] -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" 196 [2,2] -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" 197 [2,4] -> "2.4 (+ support for '**' globbing)" 198 _ -> display v 199 200-- | Ask if a simple project with sensible defaults should be created. 201getSimpleProject :: InitFlags -> IO InitFlags 202getSimpleProject flags = do 203 simpleProj <- return (flagToMaybe $ simpleProject flags) 204 ?>> maybePrompt flags 205 (promptYesNo 206 "Should I generate a simple project with sensible defaults" 207 (Just True)) 208 return $ case maybeToFlag simpleProj of 209 Flag True -> 210 flags { interactive = Flag False 211 , simpleProject = Flag True 212 , packageType = Flag LibraryAndExecutable 213 , cabalVersion = Flag (mkVersion [2,4]) 214 } 215 simpleProjFlag@_ -> 216 flags { simpleProject = simpleProjFlag } 217 218 219-- | Ask which version of the cabal spec to use. 220getCabalVersion :: InitFlags -> IO InitFlags 221getCabalVersion flags = do 222 cabVer <- return (flagToMaybe $ cabalVersion flags) 223 ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` 224 promptList "Please choose version of the Cabal specification to use" 225 [mkVersion [1,10], mkVersion [2,0], mkVersion [2,2], mkVersion [2,4]] 226 (Just defaultCabalVersion) displayCabalVersion False) 227 ?>> return (Just defaultCabalVersion) 228 229 return $ flags { cabalVersion = maybeToFlag cabVer } 230 231 232-- | Get the package name: use the package directory (supplied, or the current 233-- directory by default) as a guess. It looks at the SourcePackageDb to avoid 234-- using an existing package name. 235getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags 236getPackageName sourcePkgDb flags = do 237 guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) 238 ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) 239 240 let guess' | isPkgRegistered guess = Nothing 241 | otherwise = guess 242 243 pkgName' <- return (flagToMaybe $ packageName flags) 244 ?>> maybePrompt flags (prompt "Package name" guess') 245 ?>> return guess' 246 247 chooseAgain <- if isPkgRegistered pkgName' 248 then promptYesNo promptOtherNameMsg (Just True) 249 else return False 250 251 if chooseAgain 252 then getPackageName sourcePkgDb flags 253 else return $ flags { packageName = maybeToFlag pkgName' } 254 255 where 256 isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg 257 isPkgRegistered Nothing = False 258 259 promptOtherNameMsg = "This package name is already used by another " ++ 260 "package on hackage. Do you want to choose a " ++ 261 "different name" 262 263-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user 264-- if possible. 265getVersion :: InitFlags -> IO InitFlags 266getVersion flags = do 267 let v = Just $ mkVersion [0,1,0,0] 268 v' <- return (flagToMaybe $ version flags) 269 ?>> maybePrompt flags (prompt "Package version" v) 270 ?>> return v 271 return $ flags { version = maybeToFlag v' } 272 273-- | Choose a license. 274getLicense :: InitFlags -> IO InitFlags 275getLicense flags = do 276 lic <- return (flagToMaybe $ license flags) 277 ?>> fmap (fmap (either UnknownLicense id)) 278 (maybePrompt flags 279 (promptList "Please choose a license" listedLicenses 280 (Just BSD3) displayLicense True)) 281 282 case checkLicenseInvalid lic of 283 Just msg -> putStrLn msg >> getLicense flags 284 Nothing -> return $ flags { license = maybeToFlag lic } 285 286 where 287 displayLicense l | needSpdx = prettyShow (licenseToSPDX l) 288 | otherwise = display l 289 290 checkLicenseInvalid (Just (UnknownLicense t)) 291 | needSpdx = case eitherParsec t :: Either String SPDX.License of 292 Right _ -> Nothing 293 Left _ -> Just "\nThe license must be a valid SPDX expression." 294 | otherwise = if any (not . isAlphaNum) t 295 then Just promptInvalidOtherLicenseMsg 296 else Nothing 297 checkLicenseInvalid _ = Nothing 298 299 promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++ 300 "If your license name has many words, " ++ 301 "the convention is to use camel case (e.g. PublicDomain). " ++ 302 "Please choose a different license." 303 304 listedLicenses = 305 knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing 306 , Apache Nothing, OtherLicense] 307 308 needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags) 309 310-- | The author's name and email. Prompt, or try to guess from an existing 311-- darcs repo. 312getAuthorInfo :: InitFlags -> IO InitFlags 313getAuthorInfo flags = do 314 (authorName, authorEmail) <- 315 (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail 316 authorName' <- return (flagToMaybe $ author flags) 317 ?>> maybePrompt flags (promptStr "Author name" authorName) 318 ?>> return authorName 319 320 authorEmail' <- return (flagToMaybe $ email flags) 321 ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) 322 ?>> return authorEmail 323 324 return $ flags { author = maybeToFlag authorName' 325 , email = maybeToFlag authorEmail' 326 } 327 328-- | Prompt for a homepage URL. 329getHomepage :: InitFlags -> IO InitFlags 330getHomepage flags = do 331 hp <- queryHomepage 332 hp' <- return (flagToMaybe $ homepage flags) 333 ?>> maybePrompt flags (promptStr "Project homepage URL" hp) 334 ?>> return hp 335 336 return $ flags { homepage = maybeToFlag hp' } 337 338-- | Right now this does nothing, but it could be changed to do some 339-- intelligent guessing. 340queryHomepage :: IO (Maybe String) 341queryHomepage = return Nothing -- get default remote darcs repo? 342 343-- | Prompt for a project synopsis. 344getSynopsis :: InitFlags -> IO InitFlags 345getSynopsis flags = do 346 syn <- return (flagToMaybe $ synopsis flags) 347 ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) 348 349 return $ flags { synopsis = maybeToFlag syn } 350 351-- | Prompt for a package category. 352-- Note that it should be possible to do some smarter guessing here too, i.e. 353-- look at the name of the top level source directory. 354getCategory :: InitFlags -> IO InitFlags 355getCategory flags = do 356 cat <- return (flagToMaybe $ category flags) 357 ?>> fmap join (maybePrompt flags 358 (promptListOptional "Project category" [Codec ..])) 359 return $ flags { category = maybeToFlag cat } 360 361-- | Try to guess extra source files (don't prompt the user). 362getExtraSourceFiles :: InitFlags -> IO InitFlags 363getExtraSourceFiles flags = do 364 extraSrcFiles <- return (extraSrc flags) 365 ?>> Just `fmap` guessExtraSourceFiles flags 366 367 return $ flags { extraSrc = extraSrcFiles } 368 369defaultChangeLog :: FilePath 370defaultChangeLog = "CHANGELOG.md" 371 372-- | Try to guess things to include in the extra-source-files field. 373-- For now, we just look for things in the root directory named 374-- 'readme', 'changes', or 'changelog', with any sort of 375-- capitalization and any extension. 376guessExtraSourceFiles :: InitFlags -> IO [FilePath] 377guessExtraSourceFiles flags = do 378 dir <- 379 maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 380 files <- getDirectoryContents dir 381 let extraFiles = filter isExtra files 382 if any isLikeChangeLog extraFiles 383 then return extraFiles 384 else return (defaultChangeLog : extraFiles) 385 386 where 387 isExtra = likeFileNameBase ("README" : changeLogLikeBases) 388 isLikeChangeLog = likeFileNameBase changeLogLikeBases 389 likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName 390 changeLogLikeBases = ["CHANGES", "CHANGELOG"] 391 392-- | Ask whether the project builds a library or executable. 393getLibOrExec :: InitFlags -> IO InitFlags 394getLibOrExec flags = do 395 pkgType <- return (flagToMaybe $ packageType flags) 396 ?>> maybePrompt flags (either (const Executable) id `fmap` 397 promptList "What does the package build" 398 [Executable, Library, LibraryAndExecutable] 399 Nothing displayPackageType False) 400 ?>> return (Just Executable) 401 402 -- If this package contains an executable, get the main file name. 403 mainFile <- if pkgType == Just Library then return Nothing else 404 getMainFile flags 405 406 return $ flags { packageType = maybeToFlag pkgType 407 , mainIs = maybeToFlag mainFile 408 } 409 410 411-- | Try to guess the main file of the executable, and prompt the user to choose 412-- one of them. Top-level modules including the word 'Main' in the file name 413-- will be candidates, and shorter filenames will be preferred. 414getMainFile :: InitFlags -> IO (Maybe FilePath) 415getMainFile flags = 416 return (flagToMaybe $ mainIs flags) 417 ?>> do 418 candidates <- guessMainFileCandidates flags 419 let showCandidate = either (++" (does not yet exist, but will be created)") id 420 defaultFile = listToMaybe candidates 421 maybePrompt flags (either id (either id id) `fmap` 422 promptList "What is the main module of the executable" 423 candidates 424 defaultFile showCandidate True) 425 ?>> return (fmap (either id id) defaultFile) 426 427-- | Ask if a test suite should be generated for the library. 428getGenTests :: InitFlags -> IO InitFlags 429getGenTests flags = do 430 genTests <- return (flagToMaybe $ initializeTestSuite flags) 431 -- Only generate a test suite if the package contains a library. 432 ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing 433 ?>> maybePrompt flags 434 (promptYesNo 435 "Should I generate a test suite for the library" 436 (Just True)) 437 return $ flags { initializeTestSuite = maybeToFlag genTests } 438 439-- | Ask for the test root directory. 440getTestDir :: InitFlags -> IO InitFlags 441getTestDir flags = do 442 dirs <- return (testDirs flags) 443 -- Only need testDirs when test suite generation is enabled. 444 ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing 445 ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt 446 flags 447 (promptList "Test directory" ["test"] (Just "test") id True)) 448 449 return $ flags { testDirs = dirs } 450 451-- | Ask for the base language of the package. 452getLanguage :: InitFlags -> IO InitFlags 453getLanguage flags = do 454 lang <- return (flagToMaybe $ language flags) 455 ?>> maybePrompt flags 456 (either UnknownLanguage id `fmap` 457 promptList "What base language is the package written in" 458 [Haskell2010, Haskell98] 459 (Just Haskell2010) display True) 460 ?>> return (Just Haskell2010) 461 462 if invalidLanguage lang 463 then putStrLn invalidOtherLanguageMsg >> getLanguage flags 464 else return $ flags { language = maybeToFlag lang } 465 466 where 467 invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t 468 invalidLanguage _ = False 469 470 invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ 471 "Please enter a different language." 472 473-- | Ask whether to generate explanatory comments. 474getGenComments :: InitFlags -> IO InitFlags 475getGenComments flags = do 476 genComments <- return (not <$> flagToMaybe (noComments flags)) 477 ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) 478 ?>> return (Just False) 479 return $ flags { noComments = maybeToFlag (fmap not genComments) } 480 where 481 promptMsg = "Add informative comments to each field in the cabal file (y/n)" 482 483-- | Ask for the application root directory. 484getAppDir :: InitFlags -> IO InitFlags 485getAppDir flags = do 486 appDirs <- return (applicationDirs flags) 487 -- No application dir if this is a 'Library'. 488 ?>> if (packageType flags) == Flag Library then return (Just []) else return Nothing 489 ?>> fmap (:[]) `fmap` guessAppDir flags 490 ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt 491 flags 492 (promptListOptional' 493 ("Application " ++ mainFile ++ "directory") 494 ["src-exe", "app"] id)) 495 496 return $ flags { applicationDirs = appDirs } 497 498 where 499 mainFile = case mainIs flags of 500 Flag mainPath -> "(" ++ mainPath ++ ") " 501 _ -> "" 502 503-- | Try to guess app directory. Could try harder; for the 504-- moment just looks to see whether there is a directory called 'app'. 505guessAppDir :: InitFlags -> IO (Maybe String) 506guessAppDir flags = do 507 dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 508 appIsDir <- doesDirectoryExist (dir </> "app") 509 return $ if appIsDir 510 then Just "app" 511 else Nothing 512 513-- | Ask for the source (library) root directory. 514getSrcDir :: InitFlags -> IO InitFlags 515getSrcDir flags = do 516 srcDirs <- return (sourceDirs flags) 517 -- source dir if this is an 'Executable'. 518 ?>> if (packageType flags) == Flag Executable then return (Just []) else return Nothing 519 ?>> fmap (:[]) `fmap` guessSourceDir flags 520 ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt 521 flags 522 (promptListOptional' "Library source directory" 523 ["src", "lib", "src-lib"] id)) 524 525 return $ flags { sourceDirs = srcDirs } 526 527-- | Try to guess source directory. Could try harder; for the 528-- moment just looks to see whether there is a directory called 'src'. 529guessSourceDir :: InitFlags -> IO (Maybe String) 530guessSourceDir flags = do 531 dir <- 532 maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 533 srcIsDir <- doesDirectoryExist (dir </> "src") 534 return $ if srcIsDir 535 then Just "src" 536 else Nothing 537 538-- | Check whether a potential source file is located in one of the 539-- source directories. 540isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool 541isSourceFile Nothing sf = isSourceFile (Just ["."]) sf 542isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs 543 544-- | Get the list of exposed modules and extra tools needed to build them. 545getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags 546getModulesBuildToolsAndDeps pkgIx flags = do 547 dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 548 549 sourceFiles0 <- scanForModules dir 550 551 let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 552 553 Just mods <- return (exposedModules flags) 554 ?>> (return . Just . map moduleName $ sourceFiles) 555 556 tools <- return (buildTools flags) 557 ?>> (return . Just . neededBuildPrograms $ sourceFiles) 558 559 deps <- return (dependencies flags) 560 ?>> Just <$> importsToDeps flags 561 (fromString "Prelude" : -- to ensure we get base as a dep 562 ( nub -- only need to consider each imported package once 563 . filter (`notElem` mods) -- don't consider modules from 564 -- this package itself 565 . concatMap imports 566 $ sourceFiles 567 ) 568 ) 569 pkgIx 570 571 exts <- return (otherExts flags) 572 ?>> (return . Just . nub . concatMap extensions $ sourceFiles) 573 574 -- If we're initializing a library and there were no modules discovered 575 -- then create an empty 'MyLib' module. 576 -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because 577 -- then the executable needs to set 'other-modules: MyLib' or else the build 578 -- fails. 579 let (finalModsList, otherMods) = case (packageType flags, mods) of 580 581 -- For an executable leave things as they are. 582 (Flag Executable, _) -> (mods, otherModules flags) 583 584 -- If a non-empty module list exists don't change anything. 585 (_, (_:_)) -> (mods, otherModules flags) 586 587 -- Library only: 'MyLib' in 'other-modules' only. 588 (Flag Library, _) -> ([myLibModule], Nothing) 589 590 -- For a 'LibraryAndExecutable' we need to have special handling. 591 -- If we don't have a module list (Nothing or empty), then create a Lib. 592 (_, []) -> 593 if sourceDirs flags == applicationDirs flags 594 then ([myLibModule], Just [myLibModule]) 595 else ([myLibModule], Nothing) 596 597 return $ flags { exposedModules = Just finalModsList 598 , otherModules = otherMods 599 , buildTools = tools 600 , dependencies = deps 601 , otherExts = exts 602 } 603 604importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] 605importsToDeps flags mods pkgIx = do 606 607 let modMap :: M.Map ModuleName [InstalledPackageInfo] 608 modMap = M.map (filter exposed) $ moduleNameIndex pkgIx 609 610 modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] 611 modDeps = map (id &&& flip M.lookup modMap) mods 612 613 message flags "\nGuessing dependencies..." 614 nub . catMaybes <$> mapM (chooseDep flags) modDeps 615 616-- Given a module and a list of installed packages providing it, 617-- choose a dependency (i.e. package + version range) to use for that 618-- module. 619chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) 620 -> IO (Maybe P.Dependency) 621 622chooseDep flags (m, Nothing) 623 = message flags ("\nWarning: no package found providing " ++ display m ++ ".") 624 >> return Nothing 625 626chooseDep flags (m, Just []) 627 = message flags ("\nWarning: no package found providing " ++ display m ++ ".") 628 >> return Nothing 629 630 -- We found some packages: group them by name. 631chooseDep flags (m, Just ps) 632 = case pkgGroups of 633 -- if there's only one group, i.e. multiple versions of a single package, 634 -- we make it into a dependency, choosing the latest-ish version (see toDep). 635 [grp] -> Just <$> toDep grp 636 -- otherwise, we refuse to choose between different packages and make the user 637 -- do it. 638 grps -> do message flags ("\nWarning: multiple packages found providing " 639 ++ display m 640 ++ ": " ++ intercalate ", " (fmap (display . P.pkgName . NE.head) grps)) 641 message flags "You will need to pick one and manually add it to the Build-depends: field." 642 return Nothing 643 where 644 pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) 645 646 desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags) 647 648 -- Given a list of available versions of the same package, pick a dependency. 649 toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency 650 651 -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* 652 toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries 653 654 -- Otherwise, choose the latest version and issue a warning. 655 toDep pids = do 656 message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") 657 return $ P.Dependency (P.pkgName . NE.head $ pids) 658 (pvpize desugar . maximum . fmap P.pkgVersion $ pids) 659 (Set.singleton LMainLibName) --TODO take into account sublibraries 660 661-- | Given a version, return an API-compatible (according to PVP) version range. 662-- 663-- If the boolean argument denotes whether to use a desugared 664-- representation (if 'True') or the new-style @^>=@-form (if 665-- 'False'). 666-- 667-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the 668-- same as @0.4.*@). 669pvpize :: Bool -> Version -> VersionRange 670pvpize False v = majorBoundVersion v 671pvpize True v = orLaterVersion v' 672 `intersectVersionRanges` 673 earlierVersion (incVersion 1 v') 674 where v' = alterVersion (take 2) v 675 676-- | Increment the nth version component (counting from 0). 677incVersion :: Int -> Version -> Version 678incVersion n = alterVersion (incVersion' n) 679 where 680 incVersion' 0 [] = [1] 681 incVersion' 0 (v:_) = [v+1] 682 incVersion' m [] = replicate m 0 ++ [1] 683 incVersion' m (v:vs) = v : incVersion' (m-1) vs 684 685-- | Returns true if this package is eligible for test suite initialization. 686eligibleForTestSuite :: InitFlags -> Bool 687eligibleForTestSuite flags = 688 Flag True == initializeTestSuite flags 689 && Flag Executable /= packageType flags 690 691--------------------------------------------------------------------------- 692-- Prompting/user interaction ------------------------------------------- 693--------------------------------------------------------------------------- 694 695-- | Run a prompt or not based on the interactive flag of the 696-- InitFlags structure. 697maybePrompt :: InitFlags -> IO t -> IO (Maybe t) 698maybePrompt flags p = 699 case interactive flags of 700 Flag True -> Just `fmap` p 701 _ -> return Nothing 702 703-- | Create a prompt with optional default value that returns a 704-- String. 705promptStr :: String -> Maybe String -> IO String 706promptStr = promptDefault' Just id 707 708-- | Create a yes/no prompt with optional default value. 709-- 710promptYesNo :: String -> Maybe Bool -> IO Bool 711promptYesNo = 712 promptDefault' recogniseYesNo showYesNo 713 where 714 recogniseYesNo s | s == "y" || s == "Y" = Just True 715 | s == "n" || s == "N" = Just False 716 | otherwise = Nothing 717 showYesNo True = "y" 718 showYesNo False = "n" 719 720-- | Create a prompt with optional default value that returns a value 721-- of some Text instance. 722prompt :: Text t => String -> Maybe t -> IO t 723prompt = promptDefault' 724 (either (const Nothing) Just . runReadE (readP_to_E id parse)) 725 display 726 727-- | Create a prompt with an optional default value. 728promptDefault' :: (String -> Maybe t) -- ^ parser 729 -> (t -> String) -- ^ pretty-printer 730 -> String -- ^ prompt message 731 -> Maybe t -- ^ optional default value 732 -> IO t 733promptDefault' parser pretty pr def = do 734 putStr $ mkDefPrompt pr (pretty `fmap` def) 735 inp <- getLine 736 case (inp, def) of 737 ("", Just d) -> return d 738 _ -> case parser inp of 739 Just t -> return t 740 Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" 741 promptDefault' parser pretty pr def 742 743-- | Create a prompt from a prompt string and a String representation 744-- of an optional default value. 745mkDefPrompt :: String -> Maybe String -> String 746mkDefPrompt pr def = pr ++ "?" ++ defStr def 747 where defStr Nothing = " " 748 defStr (Just s) = " [default: " ++ s ++ "] " 749 750promptListOptional :: (Text t, Eq t) 751 => String -- ^ prompt 752 -> [t] -- ^ choices 753 -> IO (Maybe (Either String t)) 754promptListOptional pr choices = promptListOptional' pr choices display 755 756promptListOptional' :: Eq t 757 => String -- ^ prompt 758 -> [t] -- ^ choices 759 -> (t -> String) -- ^ show an item 760 -> IO (Maybe (Either String t)) 761promptListOptional' pr choices displayItem = 762 fmap rearrange 763 $ promptList pr (Nothing : map Just choices) (Just Nothing) 764 (maybe "(none)" displayItem) True 765 where 766 rearrange = either (Just . Left) (fmap Right) 767 768-- | Create a prompt from a list of items. 769promptList :: Eq t 770 => String -- ^ prompt 771 -> [t] -- ^ choices 772 -> Maybe t -- ^ optional default value 773 -> (t -> String) -- ^ show an item 774 -> Bool -- ^ whether to allow an 'other' option 775 -> IO (Either String t) 776promptList pr choices def displayItem other = do 777 putStrLn $ pr ++ ":" 778 let options1 = map (\c -> (Just c == def, displayItem c)) choices 779 options2 = zip ([1..]::[Int]) 780 (options1 ++ [(False, "Other (specify)") | other]) 781 mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 782 promptList' displayItem (length options2) choices def other 783 where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest 784 | otherwise = " " ++ star i ++ rest 785 where rest = show n ++ ") " 786 star True = "*" 787 star False = " " 788 789promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) 790promptList' displayItem numChoices choices def other = do 791 putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) 792 inp <- getLine 793 case (inp, def) of 794 ("", Just d) -> return $ Right d 795 _ -> case readMaybe inp of 796 Nothing -> invalidChoice inp 797 Just n -> getChoice n 798 where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." 799 promptList' displayItem numChoices choices def other 800 getChoice n | n < 1 || n > numChoices = invalidChoice (show n) 801 | n < numChoices || 802 (n == numChoices && not other) 803 = return . Right $ choices !! (n-1) 804 | otherwise = Left `fmap` promptStr "Please specify" Nothing 805 806--------------------------------------------------------------------------- 807-- File generation ------------------------------------------------------ 808--------------------------------------------------------------------------- 809 810writeLicense :: InitFlags -> IO () 811writeLicense flags = do 812 message flags "\nGenerating LICENSE..." 813 year <- show <$> getYear 814 let authors = fromMaybe "???" . flagToMaybe . author $ flags 815 let licenseFile = 816 case license flags of 817 Flag BSD2 818 -> Just $ bsd2 authors year 819 820 Flag BSD3 821 -> Just $ bsd3 authors year 822 823 Flag (GPL (Just v)) | v == mkVersion [2] 824 -> Just gplv2 825 826 Flag (GPL (Just v)) | v == mkVersion [3] 827 -> Just gplv3 828 829 Flag (LGPL (Just v)) | v == mkVersion [2,1] 830 -> Just lgpl21 831 832 Flag (LGPL (Just v)) | v == mkVersion [3] 833 -> Just lgpl3 834 835 Flag (AGPL (Just v)) | v == mkVersion [3] 836 -> Just agplv3 837 838 Flag (Apache (Just v)) | v == mkVersion [2,0] 839 -> Just apache20 840 841 Flag MIT 842 -> Just $ mit authors year 843 844 Flag (MPL v) | v == mkVersion [2,0] 845 -> Just mpl20 846 847 Flag ISC 848 -> Just $ isc authors year 849 850 _ -> Nothing 851 852 case licenseFile of 853 Just licenseText -> writeFileSafe flags "LICENSE" licenseText 854 Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." 855 856getYear :: IO Integer 857getYear = do 858 u <- getCurrentTime 859 z <- getCurrentTimeZone 860 let l = utcToLocalTime z u 861 (y, _, _) = toGregorian $ localDay l 862 return y 863 864writeSetupFile :: InitFlags -> IO () 865writeSetupFile flags = do 866 message flags "Generating Setup.hs..." 867 writeFileSafe flags "Setup.hs" setupFile 868 where 869 setupFile = unlines 870 [ "import Distribution.Simple" 871 , "main = defaultMain" 872 ] 873 874writeChangeLog :: InitFlags -> IO () 875writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do 876 message flags ("Generating "++ defaultChangeLog ++"...") 877 writeFileSafe flags defaultChangeLog changeLog 878 where 879 changeLog = unlines 880 [ "# Revision history for " ++ pname 881 , "" 882 , "## " ++ pver ++ " -- YYYY-mm-dd" 883 , "" 884 , "* First version. Released on an unsuspecting world." 885 ] 886 pname = maybe "" display $ flagToMaybe $ packageName flags 887 pver = maybe "" display $ flagToMaybe $ version flags 888 889 890 891writeCabalFile :: InitFlags -> IO Bool 892writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do 893 message flags "Error: no package name provided." 894 return False 895writeCabalFile flags@(InitFlags{packageName = Flag p}) = do 896 let cabalFileName = display p ++ ".cabal" 897 message flags $ "Generating " ++ cabalFileName ++ "..." 898 writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) 899 return True 900 901-- | Write a file \"safely\", backing up any existing version (unless 902-- the overwrite flag is set). 903writeFileSafe :: InitFlags -> FilePath -> String -> IO () 904writeFileSafe flags fileName content = do 905 moveExistingFile flags fileName 906 writeFile fileName content 907 908-- | Create directories, if they were given, and don't already exist. 909createDirectories :: Maybe [String] -> IO () 910createDirectories mdirs = case mdirs of 911 Just dirs -> forM_ dirs (createDirectoryIfMissing True) 912 Nothing -> return () 913 914-- | Create MyLib.hs file, if its the only module in the liste. 915createLibHs :: InitFlags -> IO () 916createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do 917 let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" 918 case sourceDirs flags of 919 Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath) 920 _ -> writeLibHs flags modFilePath 921 922-- | Write a MyLib.hs file if it doesn't already exist. 923writeLibHs :: InitFlags -> FilePath -> IO () 924writeLibHs flags libPath = do 925 dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) 926 let libFullPath = dir </> libPath 927 exists <- doesFileExist libFullPath 928 unless exists $ do 929 message flags $ "Generating " ++ libPath ++ "..." 930 writeFileSafe flags libFullPath myLibHs 931 932myLibModule :: ModuleName 933myLibModule = ModuleName.fromString "MyLib" 934 935-- | Default MyLib.hs file. Used when no Lib.hs exists. 936myLibHs :: String 937myLibHs = unlines 938 [ "module MyLib (someFunc) where" 939 , "" 940 , "someFunc :: IO ()" 941 , "someFunc = putStrLn \"someFunc\"" 942 ] 943 944-- | Create Main.hs, but only if we are init'ing an executable and 945-- the mainIs flag has been provided. 946createMainHs :: InitFlags -> IO () 947createMainHs flags = 948 if hasMainHs flags then 949 case applicationDirs flags of 950 Just (appPath:_) -> writeMainHs flags (appPath </> mainFile) 951 _ -> writeMainHs flags mainFile 952 else return () 953 where 954 mainFile = case mainIs flags of 955 Flag x -> x 956 NoFlag -> error "createMainHs: no mainIs" 957 958--- | Write a main file if it doesn't already exist. 959writeMainHs :: InitFlags -> FilePath -> IO () 960writeMainHs flags mainPath = do 961 dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) 962 let mainFullPath = dir </> mainPath 963 exists <- doesFileExist mainFullPath 964 unless exists $ do 965 message flags $ "Generating " ++ mainPath ++ "..." 966 writeFileSafe flags mainFullPath (mainHs flags) 967 968-- | Check that a main file exists. 969hasMainHs :: InitFlags -> Bool 970hasMainHs flags = case mainIs flags of 971 Flag _ -> (packageType flags == Flag Executable 972 || packageType flags == Flag LibraryAndExecutable) 973 _ -> False 974 975-- | Default Main.(l)hs file. Used when no Main.(l)hs exists. 976-- 977-- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. 978mainHs :: InitFlags -> String 979mainHs flags = (unlines . map prependPrefix) $ case packageType flags of 980 Flag LibraryAndExecutable -> 981 [ "module Main where" 982 , "" 983 , "import qualified MyLib (someFunc)" 984 , "" 985 , "main :: IO ()" 986 , "main = do" 987 , " putStrLn \"Hello, Haskell!\"" 988 , " MyLib.someFunc" 989 ] 990 _ -> 991 [ "module Main where" 992 , "" 993 , "main :: IO ()" 994 , "main = putStrLn \"Hello, Haskell!\"" 995 ] 996 where 997 prependPrefix "" = "" 998 prependPrefix line 999 | isLiterate = "> " ++ line 1000 | otherwise = line 1001 isLiterate = case mainIs flags of 1002 Flag mainPath -> takeExtension mainPath == ".lhs" 1003 _ -> False 1004 1005testFile :: String 1006testFile = "MyLibTest.hs" 1007 1008-- | Create MyLibTest.hs, but only if we are init'ing a library and 1009-- the initializeTestSuite flag has been set. 1010createTestHs :: InitFlags -> IO () 1011createTestHs flags = 1012 when (eligibleForTestSuite flags) $ 1013 case testDirs flags of 1014 Just (testPath:_) -> writeTestHs flags (testPath </> testFile) 1015 _ -> writeMainHs flags testFile 1016 1017--- | Write a test file. 1018writeTestHs :: InitFlags -> FilePath -> IO () 1019writeTestHs flags testPath = do 1020 dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) 1021 let testFullPath = dir </> testPath 1022 exists <- doesFileExist testFullPath 1023 unless exists $ do 1024 message flags $ "Generating " ++ testPath ++ "..." 1025 writeFileSafe flags testFullPath testHs 1026 1027-- | Default MyLibTest.hs file. 1028testHs :: String 1029testHs = unlines 1030 [ "module Main (main) where" 1031 , "" 1032 , "main :: IO ()" 1033 , "main = putStrLn \"Test suite not yet implemented.\"" 1034 ] 1035 1036 1037-- | Move an existing file, if there is one, and the overwrite flag is 1038-- not set. 1039moveExistingFile :: InitFlags -> FilePath -> IO () 1040moveExistingFile flags fileName = 1041 unless (overwrite flags == Flag True) $ do 1042 e <- doesFileExist fileName 1043 when e $ do 1044 newName <- findNewName fileName 1045 message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName 1046 copyFile fileName newName 1047 1048findNewName :: FilePath -> IO FilePath 1049findNewName oldName = findNewName' 0 1050 where 1051 findNewName' :: Integer -> IO FilePath 1052 findNewName' n = do 1053 let newName = oldName <.> ("save" ++ show n) 1054 e <- doesFileExist newName 1055 if e then findNewName' (n+1) else return newName 1056 1057-- | Generate a .cabal file from an InitFlags structure. NOTE: this 1058-- is rather ad-hoc! What we would REALLY like is to have a 1059-- standard low-level AST type representing .cabal files, which 1060-- preserves things like comments, and to write an *inverse* 1061-- parser/pretty-printer pair between .cabal files and this AST. 1062-- Then instead of this ad-hoc code we could just map an InitFlags 1063-- structure onto a low-level AST structure and use the existing 1064-- pretty-printing code to generate the file. 1065generateCabalFile :: String -> InitFlags -> String 1066generateCabalFile fileName c = trimTrailingWS $ 1067 (++ "\n") . 1068 renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ 1069 -- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD 1070 (if specVer < mkVersion [1,12] 1071 then field "cabal-version" (Flag $ orLaterVersion specVer) -- legacy 1072 else field "cabal-version" (Flag $ specVer)) 1073 Nothing -- NB: the first line must be the 'cabal-version' declaration 1074 False 1075 $$ 1076 (if minimal c /= Flag True 1077 then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated " 1078 ++ "by 'cabal init'. For further documentation, see " 1079 ++ "http://haskell.org/cabal/users-guide/") 1080 $$ text "" 1081 else empty) 1082 $$ 1083 vcat [ field "name" (packageName c) 1084 (Just "The name of the package.") 1085 True 1086 1087 , field "version" (version c) 1088 (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" 1089 ++ "PVP summary: +-+------- breaking API changes\n" 1090 ++ " | | +----- non-breaking API additions\n" 1091 ++ " | | | +--- code changes with no API change") 1092 True 1093 1094 , fieldS "synopsis" (synopsis c) 1095 (Just "A short (one-line) description of the package.") 1096 True 1097 1098 , fieldS "description" NoFlag 1099 (Just "A longer description of the package.") 1100 True 1101 1102 , fieldS "homepage" (homepage c) 1103 (Just "URL for the project homepage or repository.") 1104 False 1105 1106 , fieldS "bug-reports" NoFlag 1107 (Just "A URL where users can report bugs.") 1108 True 1109 1110 , fieldS "license" licenseStr 1111 (Just "The license under which the package is released.") 1112 True 1113 1114 , case (license c) of 1115 Flag PublicDomain -> empty 1116 _ -> fieldS "license-file" (Flag "LICENSE") 1117 (Just "The file containing the license text.") 1118 True 1119 1120 , fieldS "author" (author c) 1121 (Just "The package author(s).") 1122 True 1123 1124 , fieldS "maintainer" (email c) 1125 (Just "An email address to which users can send suggestions, bug reports, and patches.") 1126 True 1127 1128 , case (license c) of 1129 Flag PublicDomain -> empty 1130 _ -> fieldS "copyright" NoFlag 1131 (Just "A copyright notice.") 1132 True 1133 1134 , fieldS "category" (either id display `fmap` category c) 1135 Nothing 1136 True 1137 1138 , fieldS "build-type" (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple") 1139 Nothing 1140 False 1141 1142 , fieldS "extra-source-files" (listFieldS (extraSrc c)) 1143 (Just "Extra files to be distributed with the package, such as examples or a README.") 1144 True 1145 1146 , case packageType c of 1147 Flag Executable -> executableStanza 1148 Flag Library -> libraryStanza 1149 Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza 1150 _ -> empty 1151 1152 , if eligibleForTestSuite c then testSuiteStanza else empty 1153 ] 1154 where 1155 specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) 1156 1157 licenseStr | specVer < mkVersion [2,2] = prettyShow `fmap` license c 1158 | otherwise = go `fmap` license c 1159 where 1160 go (UnknownLicense s) = s 1161 go l = prettyShow (licenseToSPDX l) 1162 1163 generateBuildInfo :: BuildType -> InitFlags -> Doc 1164 generateBuildInfo buildType c' = vcat 1165 [ fieldS "other-modules" (listField otherMods) 1166 (Just $ case buildType of 1167 LibBuild -> "Modules included in this library but not exported." 1168 ExecBuild -> "Modules included in this executable, other than Main.") 1169 True 1170 1171 , fieldS "other-extensions" (listField (otherExts c')) 1172 (Just "LANGUAGE extensions used by modules in this package.") 1173 True 1174 1175 , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c')) 1176 (Just "Other library packages from which modules are imported.") 1177 True 1178 1179 , fieldS "hs-source-dirs" (listFieldS (case buildType of 1180 LibBuild -> sourceDirs c' 1181 ExecBuild -> applicationDirs c')) 1182 (Just "Directories containing source files.") 1183 True 1184 1185 , fieldS "build-tools" (listFieldS (buildTools c')) 1186 (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") 1187 False 1188 1189 , field "default-language" (language c') 1190 (Just "Base language which the package is written in.") 1191 True 1192 ] 1193 -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). 1194 where 1195 myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild 1196 then case packageName c' of 1197 Flag pkgName -> ", " ++ P.unPackageName pkgName 1198 _ -> "" 1199 else "" 1200 1201 -- Only include 'MyLib' in 'other-modules' of the executable. 1202 otherModsFromFlag = otherModules c' 1203 otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] 1204 then Nothing 1205 else otherModsFromFlag 1206 1207 listField :: Text s => Maybe [s] -> Flag String 1208 listField = listFieldS . fmap (map display) 1209 1210 listFieldS :: Maybe [String] -> Flag String 1211 listFieldS = Flag . maybe "" (intercalate ", ") 1212 1213 field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc 1214 field s f = fieldS s (fmap display f) 1215 1216 fieldS :: String -- ^ Name of the field 1217 -> Flag String -- ^ Field contents 1218 -> Maybe String -- ^ Comment to explain the field 1219 -> Bool -- ^ Should the field be included (commented out) even if blank? 1220 -> Doc 1221 fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty 1222 fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty 1223 fieldS s f com _ = case (isJust com, noComments c, minimal c) of 1224 (_, _, Flag True) -> id 1225 (_, Flag True, _) -> id 1226 (True, _, _) -> (showComment com $$) . ($$ text "") 1227 (False, _, _) -> ($$ text "") 1228 $ 1229 comment f <<>> text s <<>> colon 1230 <<>> text (replicate (20 - length s) ' ') 1231 <<>> text (fromMaybe "" . flagToMaybe $ f) 1232 comment NoFlag = text "-- " 1233 comment (Flag "") = text "-- " 1234 comment _ = text "" 1235 1236 showComment :: Maybe String -> Doc 1237 showComment (Just t) = vcat 1238 . map (text . ("-- "++)) . lines 1239 . renderStyle style { 1240 lineLength = 76, 1241 ribbonsPerLine = 1.05 1242 } 1243 . vcat 1244 . map (fcat . map text . breakLine) 1245 . lines 1246 $ t 1247 showComment Nothing = text "" 1248 1249 breakLine [] = [] 1250 breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' 1251 breakLine' [] = [] 1252 breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' 1253 1254 trimTrailingWS :: String -> String 1255 trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines 1256 1257 executableStanza :: Doc 1258 executableStanza = text "\nexecutable" <+> 1259 text (maybe "" display . flagToMaybe $ packageName c) $$ 1260 nest 2 (vcat 1261 [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True 1262 1263 , generateBuildInfo ExecBuild c 1264 ]) 1265 1266 libraryStanza :: Doc 1267 libraryStanza = text "\nlibrary" $$ nest 2 (vcat 1268 [ fieldS "exposed-modules" (listField (exposedModules c)) 1269 (Just "Modules exported by the library.") 1270 True 1271 1272 , generateBuildInfo LibBuild c 1273 ]) 1274 1275 testSuiteStanza :: Doc 1276 testSuiteStanza = text "\ntest-suite" <+> 1277 text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$ 1278 nest 2 (vcat 1279 [ field "default-language" (language c) 1280 (Just "Base language which the package is written in.") 1281 True 1282 1283 , fieldS "type" (Flag "exitcode-stdio-1.0") 1284 (Just "The interface type and version of the test suite.") 1285 True 1286 1287 , fieldS "hs-source-dirs" (listFieldS (testDirs c)) 1288 (Just "The directory where the test specifications are found.") 1289 True 1290 1291 , fieldS "main-is" (Flag testFile) 1292 (Just "The entrypoint to the test suite.") 1293 True 1294 1295 , fieldS "build-depends" (listField (dependencies c)) 1296 (Just "Test dependencies.") 1297 True 1298 ]) 1299 1300-- | Generate warnings for missing fields etc. 1301generateWarnings :: InitFlags -> IO () 1302generateWarnings flags = do 1303 message flags "" 1304 when (synopsis flags `elem` [NoFlag, Flag ""]) 1305 (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") 1306 1307 message flags "You may want to edit the .cabal file and add a Description field." 1308 1309-- | Possibly generate a message to stdout, taking into account the 1310-- --quiet flag. 1311message :: InitFlags -> String -> IO () 1312message (InitFlags{quiet = Flag True}) _ = return () 1313message _ s = putStrLn s 1314