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