1----------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.Client.Init.Command 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.Command ( 17 18 -- * Commands 19 initCabal 20 , incVersion 21 22 ) where 23 24import Prelude () 25import Distribution.Client.Compat.Prelude hiding (empty) 26 27import System.IO 28 ( hSetBuffering, stdout, BufferMode(..) ) 29import System.Directory 30 ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents ) 31import System.FilePath 32 ( (</>), takeBaseName, equalFilePath ) 33 34import qualified Data.List.NonEmpty as NE 35import qualified Data.Map as M 36import Control.Monad 37 ( (>=>) ) 38import Control.Arrow 39 ( (&&&), (***) ) 40 41import Distribution.CabalSpecVersion 42 ( CabalSpecVersion (..), showCabalSpecVersion ) 43import Distribution.Version 44 ( Version, mkVersion, alterVersion, majorBoundVersion 45 , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) 46import Distribution.ModuleName 47 ( ModuleName ) -- And for the Text instance 48import Distribution.InstalledPackageInfo 49 ( InstalledPackageInfo, exposed ) 50import qualified Distribution.Package as P 51import qualified Distribution.SPDX as SPDX 52import Language.Haskell.Extension ( Language(..) ) 53 54import Distribution.Client.Init.Defaults 55 ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir ) 56import Distribution.Client.Init.FileCreators 57 ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs 58 , createTestSuiteIfEligible, writeCabalFile ) 59import Distribution.Client.Init.Prompt 60 ( prompt, promptYesNo, promptStr, promptList, maybePrompt 61 , promptListOptional ) 62import Distribution.Client.Init.Utils 63 ( eligibleForTestSuite, message ) 64import Distribution.Client.Init.Types 65 ( InitFlags(..), PackageType(..), Category(..) 66 , displayPackageType ) 67import Distribution.Client.Init.Heuristics 68 ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, 69 SourceFileEntry(..), 70 scanForModules, neededBuildPrograms ) 71 72import Distribution.Simple.Flag 73 ( maybeToFlag ) 74import Distribution.Simple.Setup 75 ( Flag(..), flagToMaybe ) 76import Distribution.Simple.Configure 77 ( getInstalledPackages ) 78import Distribution.Simple.Compiler 79 ( PackageDBStack, Compiler ) 80import Distribution.Simple.Program 81 ( ProgramDb ) 82import Distribution.Simple.PackageIndex 83 ( InstalledPackageIndex, moduleNameIndex ) 84 85import Distribution.Solver.Types.PackageIndex 86 ( elemByPackageName ) 87 88import Distribution.Client.IndexUtils 89 ( getSourcePackages ) 90import Distribution.Client.Types 91 ( SourcePackageDb(..) ) 92import Distribution.Client.Setup 93 ( RepoContext(..) ) 94 95initCabal :: Verbosity 96 -> PackageDBStack 97 -> RepoContext 98 -> Compiler 99 -> ProgramDb 100 -> InitFlags 101 -> IO () 102initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do 103 104 installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb 105 sourcePkgDb <- getSourcePackages verbosity repoCtxt 106 107 hSetBuffering stdout NoBuffering 108 109 initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags 110 111 case license initFlags' of 112 Flag SPDX.NONE -> return () 113 _ -> writeLicense initFlags' 114 writeChangeLog initFlags' 115 createDirectories (sourceDirs initFlags') 116 createLibHs initFlags' 117 createDirectories (applicationDirs initFlags') 118 createMainHs initFlags' 119 createTestSuiteIfEligible initFlags' 120 success <- writeCabalFile initFlags' 121 122 when success $ generateWarnings initFlags' 123 124--------------------------------------------------------------------------- 125-- Flag acquisition ----------------------------------------------------- 126--------------------------------------------------------------------------- 127 128-- | Fill in more details in InitFlags by guessing, discovering, or prompting 129-- the user. 130extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags 131extendFlags pkgIx sourcePkgDb = 132 getSimpleProject 133 >=> getLibOrExec 134 >=> getCabalVersion 135 >=> getPackageName sourcePkgDb 136 >=> getVersion 137 >=> getLicense 138 >=> getAuthorInfo 139 >=> getHomepage 140 >=> getSynopsis 141 >=> getCategory 142 >=> getExtraSourceFiles 143 >=> getAppDir 144 >=> getSrcDir 145 >=> getGenTests 146 >=> getTestDir 147 >=> getLanguage 148 >=> getGenComments 149 >=> getModulesBuildToolsAndDeps pkgIx 150 151-- | Combine two actions which may return a value, preferring the first. That 152-- is, run the second action only if the first doesn't return a value. 153infixr 1 ?>> 154(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) 155f ?>> g = do 156 ma <- f 157 if isJust ma 158 then return ma 159 else g 160 161-- | Ask if a simple project with sensible defaults should be created. 162getSimpleProject :: InitFlags -> IO InitFlags 163getSimpleProject flags = do 164 simpleProj <- return (flagToMaybe $ simpleProject flags) 165 ?>> maybePrompt flags 166 (promptYesNo 167 "Should I generate a simple project with sensible defaults" 168 (Just True)) 169 return $ case maybeToFlag simpleProj of 170 Flag True -> 171 flags { interactive = Flag False 172 , simpleProject = Flag True 173 , packageType = Flag LibraryAndExecutable 174 , cabalVersion = Flag defaultCabalVersion 175 } 176 simpleProjFlag@_ -> 177 flags { simpleProject = simpleProjFlag } 178 179 180-- | Get the version of the cabal spec to use. 181-- 182-- The spec version can be specified by the InitFlags cabalVersion field. If 183-- none is specified then the user is prompted to pick from a list of 184-- supported versions (see code below). 185getCabalVersion :: InitFlags -> IO InitFlags 186getCabalVersion flags = do 187 cabVer <- return (flagToMaybe $ cabalVersion flags) 188 ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` 189 promptList "Please choose version of the Cabal specification to use" 190 [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0] 191 (Just defaultCabalVersion) displayCabalVersion False) 192 ?>> return (Just defaultCabalVersion) 193 194 return $ flags { cabalVersion = maybeToFlag cabVer } 195 196 where 197 displayCabalVersion :: CabalSpecVersion -> String 198 displayCabalVersion v = case v of 199 CabalSpecV1_10 -> "1.10 (legacy)" 200 CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" 201 CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" 202 CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" 203 CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" 204 _ -> showCabalSpecVersion v 205 206 207 208-- | Get the package name: use the package directory (supplied, or the current 209-- directory by default) as a guess. It looks at the SourcePackageDb to avoid 210-- using an existing package name. 211getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags 212getPackageName sourcePkgDb flags = do 213 guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) 214 ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) 215 216 let guess' | isPkgRegistered guess = Nothing 217 | otherwise = guess 218 219 pkgName' <- return (flagToMaybe $ packageName flags) 220 ?>> maybePrompt flags (prompt "Package name" guess') 221 ?>> return guess' 222 223 chooseAgain <- if isPkgRegistered pkgName' 224 then promptYesNo promptOtherNameMsg (Just True) 225 else return False 226 227 if chooseAgain 228 then getPackageName sourcePkgDb flags 229 else return $ flags { packageName = maybeToFlag pkgName' } 230 231 where 232 isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg 233 isPkgRegistered Nothing = False 234 235 promptOtherNameMsg = "This package name is already used by another " ++ 236 "package on hackage. Do you want to choose a " ++ 237 "different name" 238 239-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user 240-- if possible. 241getVersion :: InitFlags -> IO InitFlags 242getVersion flags = do 243 let v = Just $ mkVersion [0,1,0,0] 244 v' <- return (flagToMaybe $ version flags) 245 ?>> maybePrompt flags (prompt "Package version" v) 246 ?>> return v 247 return $ flags { version = maybeToFlag v' } 248 249-- | Choose a license for the package. 250-- 251-- The license can come from Initflags (license field), if it is not present 252-- then prompt the user from a predefined list of licenses. 253getLicense :: InitFlags -> IO InitFlags 254getLicense flags = do 255 elic <- return (fmap Right $ flagToMaybe $ license flags) 256 ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True) 257 258 case elic of 259 Nothing -> return flags { license = NoFlag } 260 Just (Right lic) -> return flags { license = Flag lic } 261 Just (Left str) -> case eitherParsec str of 262 Right lic -> return flags { license = Flag lic } 263 -- on error, loop 264 Left err -> do 265 putStrLn "The license must be a valid SPDX expression." 266 putStrLn err 267 getLicense flags 268 where 269 -- perfectly we'll have this and writeLicense (in FileCreators) 270 -- in a single file 271 listedLicenses = 272 SPDX.NONE : 273 map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) 274 [ SPDX.BSD_2_Clause 275 , SPDX.BSD_3_Clause 276 , SPDX.Apache_2_0 277 , SPDX.MIT 278 , SPDX.MPL_2_0 279 , SPDX.ISC 280 281 , SPDX.GPL_2_0_only 282 , SPDX.GPL_3_0_only 283 , SPDX.LGPL_2_1_only 284 , SPDX.LGPL_3_0_only 285 , SPDX.AGPL_3_0_only 286 287 , SPDX.GPL_2_0_or_later 288 , SPDX.GPL_3_0_or_later 289 , SPDX.LGPL_2_1_or_later 290 , SPDX.LGPL_3_0_or_later 291 , SPDX.AGPL_3_0_or_later 292 ] 293 294-- | The author's name and email. Prompt, or try to guess from an existing 295-- darcs repo. 296getAuthorInfo :: InitFlags -> IO InitFlags 297getAuthorInfo flags = do 298 (authorName, authorEmail) <- 299 (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail 300 authorName' <- return (flagToMaybe $ author flags) 301 ?>> maybePrompt flags (promptStr "Author name" authorName) 302 ?>> return authorName 303 304 authorEmail' <- return (flagToMaybe $ email flags) 305 ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) 306 ?>> return authorEmail 307 308 return $ flags { author = maybeToFlag authorName' 309 , email = maybeToFlag authorEmail' 310 } 311 312-- | Prompt for a homepage URL for the package. 313getHomepage :: InitFlags -> IO InitFlags 314getHomepage flags = do 315 hp <- queryHomepage 316 hp' <- return (flagToMaybe $ homepage flags) 317 ?>> maybePrompt flags (promptStr "Project homepage URL" hp) 318 ?>> return hp 319 320 return $ flags { homepage = maybeToFlag hp' } 321 322-- | Right now this does nothing, but it could be changed to do some 323-- intelligent guessing. 324queryHomepage :: IO (Maybe String) 325queryHomepage = return Nothing -- get default remote darcs repo? 326 327-- | Prompt for a project synopsis. 328getSynopsis :: InitFlags -> IO InitFlags 329getSynopsis flags = do 330 syn <- return (flagToMaybe $ synopsis flags) 331 ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) 332 333 return $ flags { synopsis = maybeToFlag syn } 334 335-- | Prompt for a package category. 336-- Note that it should be possible to do some smarter guessing here too, i.e. 337-- look at the name of the top level source directory. 338getCategory :: InitFlags -> IO InitFlags 339getCategory flags = do 340 cat <- return (flagToMaybe $ category flags) 341 ?>> fmap join (maybePrompt flags 342 (promptListOptional "Project category" [Codec ..])) 343 return $ flags { category = maybeToFlag cat } 344 345-- | Try to guess extra source files (don't prompt the user). 346getExtraSourceFiles :: InitFlags -> IO InitFlags 347getExtraSourceFiles flags = do 348 extraSrcFiles <- return (extraSrc flags) 349 ?>> Just `fmap` guessExtraSourceFiles flags 350 351 return $ flags { extraSrc = extraSrcFiles } 352 353defaultChangeLog :: FilePath 354defaultChangeLog = "CHANGELOG.md" 355 356-- | Try to guess things to include in the extra-source-files field. 357-- For now, we just look for things in the root directory named 358-- 'readme', 'changes', or 'changelog', with any sort of 359-- capitalization and any extension. 360guessExtraSourceFiles :: InitFlags -> IO [FilePath] 361guessExtraSourceFiles flags = do 362 dir <- 363 maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 364 files <- getDirectoryContents dir 365 let extraFiles = filter isExtra files 366 if any isLikeChangeLog extraFiles 367 then return extraFiles 368 else return (defaultChangeLog : extraFiles) 369 370 where 371 isExtra = likeFileNameBase ("README" : changeLogLikeBases) 372 isLikeChangeLog = likeFileNameBase changeLogLikeBases 373 likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName 374 changeLogLikeBases = ["CHANGES", "CHANGELOG"] 375 376-- | Ask whether the project builds a library or executable. 377getLibOrExec :: InitFlags -> IO InitFlags 378getLibOrExec flags = do 379 pkgType <- return (flagToMaybe $ packageType flags) 380 ?>> maybePrompt flags (either (const Executable) id `fmap` 381 promptList "What does the package build" 382 [Executable, Library, LibraryAndExecutable] 383 Nothing displayPackageType False) 384 ?>> return (Just Executable) 385 386 -- If this package contains an executable, get the main file name. 387 mainFile <- if pkgType == Just Library then return Nothing else 388 getMainFile flags 389 390 return $ flags { packageType = maybeToFlag pkgType 391 , mainIs = maybeToFlag mainFile 392 } 393 394 395-- | Try to guess the main file of the executable, and prompt the user to choose 396-- one of them. Top-level modules including the word 'Main' in the file name 397-- will be candidates, and shorter filenames will be preferred. 398getMainFile :: InitFlags -> IO (Maybe FilePath) 399getMainFile flags = 400 return (flagToMaybe $ mainIs flags) 401 ?>> do 402 candidates <- guessMainFileCandidates flags 403 let showCandidate = either (++" (does not yet exist, but will be created)") id 404 defaultFile = listToMaybe candidates 405 maybePrompt flags (either id (either id id) `fmap` 406 promptList "What is the main module of the executable" 407 candidates 408 defaultFile showCandidate True) 409 ?>> return (fmap (either id id) defaultFile) 410 411-- | Ask if a test suite should be generated for the library. 412getGenTests :: InitFlags -> IO InitFlags 413getGenTests flags = do 414 genTests <- return (flagToMaybe $ initializeTestSuite flags) 415 -- Only generate a test suite if the package contains a library. 416 ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing 417 ?>> maybePrompt flags 418 (promptYesNo 419 "Should I generate a test suite for the library" 420 (Just True)) 421 return $ flags { initializeTestSuite = maybeToFlag genTests } 422 423-- | Ask for the test suite root directory. 424getTestDir :: InitFlags -> IO InitFlags 425getTestDir flags = do 426 dirs <- return (testDirs flags) 427 -- Only need testDirs when test suite generation is enabled. 428 ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing 429 ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt 430 flags 431 (promptList "Test directory" ["test"] (Just "test") id True)) 432 433 return $ flags { testDirs = dirs } 434 435-- | Ask for the Haskell base language of the package. 436getLanguage :: InitFlags -> IO InitFlags 437getLanguage flags = do 438 lang <- return (flagToMaybe $ language flags) 439 ?>> maybePrompt flags 440 (either UnknownLanguage id `fmap` 441 promptList "What base language is the package written in" 442 [Haskell2010, Haskell98] 443 (Just Haskell2010) prettyShow True) 444 ?>> return (Just Haskell2010) 445 446 if invalidLanguage lang 447 then putStrLn invalidOtherLanguageMsg >> getLanguage flags 448 else return $ flags { language = maybeToFlag lang } 449 450 where 451 invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t 452 invalidLanguage _ = False 453 454 invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ 455 "Please enter a different language." 456 457-- | Ask whether to generate explanatory comments. 458getGenComments :: InitFlags -> IO InitFlags 459getGenComments flags = do 460 genComments <- return (not <$> flagToMaybe (noComments flags)) 461 ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) 462 ?>> return (Just False) 463 return $ flags { noComments = maybeToFlag (fmap not genComments) } 464 where 465 promptMsg = "Add informative comments to each field in the cabal file (y/n)" 466 467-- | Ask for the application root directory. 468getAppDir :: InitFlags -> IO InitFlags 469getAppDir flags = do 470 appDirs <- 471 return (applicationDirs flags) 472 ?>> noAppDirIfLibraryOnly 473 ?>> guessAppDir flags 474 ?>> promptUserForApplicationDir 475 ?>> setDefault 476 return $ flags { applicationDirs = appDirs } 477 478 where 479 -- If the packageType==Library, then there is no application dir. 480 noAppDirIfLibraryOnly :: IO (Maybe [String]) 481 noAppDirIfLibraryOnly = 482 if (packageType flags) == Flag Library 483 then return (Just []) 484 else return Nothing 485 486 -- Set the default application directory. 487 setDefault :: IO (Maybe [String]) 488 setDefault = pure (Just [defaultApplicationDir]) 489 490 -- Prompt the user for the application directory (defaulting to "app"). 491 -- Returns 'Nothing' if in non-interactive mode, otherwise will always 492 -- return a 'Just' value ('Just []' if no separate application directory). 493 promptUserForApplicationDir :: IO (Maybe [String]) 494 promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt 495 flags 496 (promptList 497 ("Application " ++ mainFile ++ "directory") 498 [[defaultApplicationDir], ["src-exe"], []] 499 (Just [defaultApplicationDir]) 500 showOption True) 501 502 showOption :: [String] -> String 503 showOption [] = "(none)" 504 showOption (x:_) = x 505 506 -- The name 507 mainFile :: String 508 mainFile = case mainIs flags of 509 Flag mainPath -> "(" ++ mainPath ++ ") " 510 _ -> "" 511 512-- | Try to guess app directory. Could try harder; for the 513-- moment just looks to see whether there is a directory called 'app'. 514guessAppDir :: InitFlags -> IO (Maybe [String]) 515guessAppDir flags = do 516 dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 517 appIsDir <- doesDirectoryExist (dir </> "app") 518 return $ if appIsDir 519 then Just ["app"] 520 else Nothing 521 522-- | Ask for the source (library) root directory. 523getSrcDir :: InitFlags -> IO InitFlags 524getSrcDir flags = do 525 srcDirs <- 526 return (sourceDirs flags) 527 ?>> noSourceDirIfExecutableOnly 528 ?>> guessSourceDir flags 529 ?>> promptUserForSourceDir 530 ?>> setDefault 531 532 return $ flags { sourceDirs = srcDirs } 533 534 where 535 -- If the packageType==Executable, then there is no source dir. 536 noSourceDirIfExecutableOnly :: IO (Maybe [String]) 537 noSourceDirIfExecutableOnly = 538 if (packageType flags) == Flag Executable 539 then return (Just []) 540 else return Nothing 541 542 -- Set the default source directory. 543 setDefault :: IO (Maybe [String]) 544 setDefault = pure (Just [defaultSourceDir]) 545 546 -- Prompt the user for the source directory (defaulting to "app"). 547 -- Returns 'Nothing' if in non-interactive mode, otherwise will always 548 -- return a 'Just' value ('Just []' if no separate application directory). 549 promptUserForSourceDir :: IO (Maybe [String]) 550 promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt 551 flags 552 (promptList 553 ("Library source directory") 554 [[defaultSourceDir], ["lib"], ["src-lib"], []] 555 (Just [defaultSourceDir]) 556 showOption True) 557 558 showOption :: [String] -> String 559 showOption [] = "(none)" 560 showOption (x:_) = x 561 562 563-- | Try to guess source directory. Could try harder; for the 564-- moment just looks to see whether there is a directory called 'src'. 565guessSourceDir :: InitFlags -> IO (Maybe [String]) 566guessSourceDir flags = do 567 dir <- 568 maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 569 srcIsDir <- doesDirectoryExist (dir </> "src") 570 return $ if srcIsDir 571 then Just ["src"] 572 else Nothing 573 574-- | Check whether a potential source file is located in one of the 575-- source directories. 576isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool 577isSourceFile Nothing sf = isSourceFile (Just ["."]) sf 578isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs 579 580-- | Get the list of exposed modules and extra tools needed to build them. 581getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags 582getModulesBuildToolsAndDeps pkgIx flags = do 583 dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags 584 585 sourceFiles0 <- scanForModules dir 586 587 let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 588 589 Just mods <- return (exposedModules flags) 590 ?>> (return . Just . map moduleName $ sourceFiles) 591 592 tools <- return (buildTools flags) 593 ?>> (return . Just . neededBuildPrograms $ sourceFiles) 594 595 deps <- return (dependencies flags) 596 ?>> Just <$> importsToDeps flags 597 (fromString "Prelude" : -- to ensure we get base as a dep 598 ( nub -- only need to consider each imported package once 599 . filter (`notElem` mods) -- don't consider modules from 600 -- this package itself 601 . concatMap imports 602 $ sourceFiles 603 ) 604 ) 605 pkgIx 606 607 exts <- return (otherExts flags) 608 ?>> (return . Just . nub . concatMap extensions $ sourceFiles) 609 610 -- If we're initializing a library and there were no modules discovered 611 -- then create an empty 'MyLib' module. 612 -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because 613 -- then the executable needs to set 'other-modules: MyLib' or else the build 614 -- fails. 615 let (finalModsList, otherMods) = case (packageType flags, mods) of 616 617 -- For an executable leave things as they are. 618 (Flag Executable, _) -> (mods, otherModules flags) 619 620 -- If a non-empty module list exists don't change anything. 621 (_, (_:_)) -> (mods, otherModules flags) 622 623 -- Library only: 'MyLib' in 'other-modules' only. 624 (Flag Library, _) -> ([myLibModule], Nothing) 625 626 -- For a 'LibraryAndExecutable' we need to have special handling. 627 -- If we don't have a module list (Nothing or empty), then create a Lib. 628 (_, []) -> 629 if sourceDirs flags == applicationDirs flags 630 then ([myLibModule], Just [myLibModule]) 631 else ([myLibModule], Nothing) 632 633 return $ flags { exposedModules = Just finalModsList 634 , otherModules = otherMods 635 , buildTools = tools 636 , dependencies = deps 637 , otherExts = exts 638 } 639 640-- | Given a list of imported modules, retrieve the list of dependencies that 641-- provide those modules. 642importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] 643importsToDeps flags mods pkgIx = do 644 645 let modMap :: M.Map ModuleName [InstalledPackageInfo] 646 modMap = M.map (filter exposed) $ moduleNameIndex pkgIx 647 648 modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] 649 modDeps = map (id &&& flip M.lookup modMap) mods 650 651 message flags "\nGuessing dependencies..." 652 nub . catMaybes <$> traverse (chooseDep flags) modDeps 653 654-- Given a module and a list of installed packages providing it, 655-- choose a dependency (i.e. package + version range) to use for that 656-- module. 657chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) 658 -> IO (Maybe P.Dependency) 659 660chooseDep flags (m, Nothing) 661 = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") 662 >> return Nothing 663 664chooseDep flags (m, Just []) 665 = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") 666 >> return Nothing 667 668 -- We found some packages: group them by name. 669chooseDep flags (m, Just ps) 670 = case pkgGroups of 671 -- if there's only one group, i.e. multiple versions of a single package, 672 -- we make it into a dependency, choosing the latest-ish version (see toDep). 673 [grp] -> Just <$> toDep grp 674 -- otherwise, we refuse to choose between different packages and make the user 675 -- do it. 676 grps -> do message flags ("\nWarning: multiple packages found providing " 677 ++ prettyShow m 678 ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) 679 message flags "You will need to pick one and manually add it to the Build-depends: field." 680 return Nothing 681 where 682 pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) 683 684 desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags) 685 686 -- Given a list of available versions of the same package, pick a dependency. 687 toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency 688 689 -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* 690 toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries 691 692 -- Otherwise, choose the latest version and issue a warning. 693 toDep pids = do 694 message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") 695 return $ P.Dependency (P.pkgName . NE.head $ pids) 696 (pvpize desugar . maximum . fmap P.pkgVersion $ pids) 697 P.mainLibSet --TODO take into account sublibraries 698 699-- | Given a version, return an API-compatible (according to PVP) version range. 700-- 701-- If the boolean argument denotes whether to use a desugared 702-- representation (if 'True') or the new-style @^>=@-form (if 703-- 'False'). 704-- 705-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the 706-- same as @0.4.*@). 707pvpize :: Bool -> Version -> VersionRange 708pvpize False v = majorBoundVersion v 709pvpize True v = orLaterVersion v' 710 `intersectVersionRanges` 711 earlierVersion (incVersion 1 v') 712 where v' = alterVersion (take 2) v 713 714-- | Increment the nth version component (counting from 0). 715incVersion :: Int -> Version -> Version 716incVersion n = alterVersion (incVersion' n) 717 where 718 incVersion' 0 [] = [1] 719 incVersion' 0 (v:_) = [v+1] 720 incVersion' m [] = replicate m 0 ++ [1] 721 incVersion' m (v:vs) = v : incVersion' (m-1) vs 722 723-- | Generate warnings for missing fields etc. 724generateWarnings :: InitFlags -> IO () 725generateWarnings flags = do 726 message flags "" 727 when (synopsis flags `elem` [NoFlag, Flag ""]) 728 (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") 729 730 message flags "You may want to edit the .cabal file and add a Description field." 731