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