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