Init.hs 35.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Init
-- Copyright   :  (c) Brent Yorgey 2009
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Implementation of the 'cabal init' command, which creates an initial .cabal
-- file for a project.
--
-----------------------------------------------------------------------------

module Distribution.Client.Init (

    -- * Commands
    initCabal
20
21
  , pvpize
  , incVersion
22
23
24

  ) where

25
26
27
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (empty)

28
29
30
import System.IO
  ( hSetBuffering, stdout, BufferMode(..) )
import System.Directory
31
  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile
32
  , getDirectoryContents, createDirectoryIfMissing )
33
import System.FilePath
34
  ( (</>), (<.>), takeBaseName, equalFilePath )
35
36
37
38
import Data.Time
  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )

import Data.List
39
  ( groupBy, (\\) )
40
41
42
import Data.Function
  ( on )
import qualified Data.Map as M
43
import Control.Monad
44
  ( (>=>), join, forM_, mapM, mapM_ )
45
import Control.Arrow
EyalLotem's avatar
EyalLotem committed
46
  ( (&&&), (***) )
47

dterei's avatar
dterei committed
48
import Text.PrettyPrint hiding (mode, cat)
49
50
51
52

import Data.Version
  ( Version(..) )
import Distribution.Version
53
  ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )
54
55
56
import Distribution.Verbosity
  ( Verbosity )
import Distribution.ModuleName
EyalLotem's avatar
EyalLotem committed
57
  ( ModuleName, fromString )  -- And for the Text instance
58
59
60
import Distribution.InstalledPackageInfo
  ( InstalledPackageInfo, sourcePackageId, exposed )
import qualified Distribution.Package as P
61
import Language.Haskell.Extension ( Language(..) )
62
63

import Distribution.Client.Init.Types
64
  ( InitFlags(..), PackageType(..), Category(..) )
65
import Distribution.Client.Init.Licenses
66
  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )
67
import Distribution.Client.Init.Heuristics
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
68
69
  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,
    SourceFileEntry(..),
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
70
    scanForModules, neededBuildPrograms )
71
72
73
74
75
76
77
78

import Distribution.License
  ( License(..), knownLicenses )

import Distribution.ReadE
  ( runReadE, readP_to_E )
import Distribution.Simple.Setup
  ( Flag(..), flagToMaybe )
79
80
81
82
83
import Distribution.Simple.Configure
  ( getInstalledPackages )
import Distribution.Simple.Compiler
  ( PackageDBStack, Compiler )
import Distribution.Simple.Program
84
  ( ProgramDb )
85
import Distribution.Simple.PackageIndex
86
  ( InstalledPackageIndex, moduleNameIndex )
87
88
89
import Distribution.Text
  ( display, Text(..) )

90
import Distribution.Solver.Types.PackageIndex
91
  ( elemByPackageName )
92

93
94
95
import Distribution.Client.IndexUtils
  ( getSourcePackages )
import Distribution.Client.Types
Edsko de Vries's avatar
Edsko de Vries committed
96
97
98
  ( SourcePackageDb(..) )
import Distribution.Client.Setup
  ( RepoContext(..) )
99

100
101
initCabal :: Verbosity
          -> PackageDBStack
Edsko de Vries's avatar
Edsko de Vries committed
102
          -> RepoContext
103
          -> Compiler
104
          -> ProgramDb
105
106
          -> InitFlags
          -> IO ()
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
107
initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do
108

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
109
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
Edsko de Vries's avatar
Edsko de Vries committed
110
  sourcePkgDb <- getSourcePackages verbosity repoCtxt
111

112
113
  hSetBuffering stdout NoBuffering

114
  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags
115

116
117
118
  case license initFlags' of
    Flag PublicDomain -> return ()
    _                 -> writeLicense initFlags'
119
  writeSetupFile initFlags'
120
  writeChangeLog initFlags'
121
  createSourceDirectories initFlags'
122
  createMainHs initFlags'
123
124
125
126
127
128
129
130
131
132
  success <- writeCabalFile initFlags'

  when success $ generateWarnings initFlags'

---------------------------------------------------------------------------
--  Flag acquisition  -----------------------------------------------------
---------------------------------------------------------------------------

-- | Fill in more details by guessing, discovering, or prompting the
--   user.
133
134
135
extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags
extendFlags pkgIx sourcePkgDb =
      getPackageName sourcePkgDb
136
137
138
139
140
141
  >=> getVersion
  >=> getLicense
  >=> getAuthorInfo
  >=> getHomepage
  >=> getSynopsis
  >=> getCategory
142
  >=> getExtraSourceFiles
143
  >=> getLibOrExec
144
  >=> getSrcDir
145
  >=> getLanguage
146
147
  >=> getGenComments
  >=> getModulesBuildToolsAndDeps pkgIx
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

-- | Combine two actions which may return a value, preferring the first. That
--   is, run the second action only if the first doesn't return a value.
infixr 1 ?>>
(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)
f ?>> g = do
  ma <- f
  if isJust ma
    then return ma
    else g

-- | Witness the isomorphism between Maybe and Flag.
maybeToFlag :: Maybe a -> Flag a
maybeToFlag = maybe NoFlag Flag

-- | Get the package name: use the package directory (supplied, or the current
164
165
166
167
--   directory by default) as a guess. It looks at the SourcePackageDb to avoid
--   using an existing package name.
getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags
getPackageName sourcePkgDb flags = do
168
169
170
  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)
              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)

171
172
173
  let guess' | isPkgRegistered guess = Nothing
             | otherwise = guess

174
  pkgName' <-     return (flagToMaybe $ packageName flags)
175
176
177
178
179
180
181
182
183
184
185
186
187
188
              ?>> maybePrompt flags (prompt "Package name" guess')
              ?>> return guess'

  chooseAgain <- if isPkgRegistered pkgName'
                    then promptYesNo promptOtherNameMsg (Just True)
                    else return False

  if chooseAgain
    then getPackageName sourcePkgDb flags
    else return $ flags { packageName = maybeToFlag pkgName' }

  where
    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg
    isPkgRegistered Nothing    = False
189

190
191
192
    promptOtherNameMsg = "This package name is already used by another " ++
                         "package on hackage. Do you want to choose a " ++
                         "different name"
193

194
195
-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user
--  if possible.
196
197
getVersion :: InitFlags -> IO InitFlags
getVersion flags = do
198
  let v = Just $ Version [0,1,0,0] []
199
200
201
202
203
204
205
206
207
  v' <-     return (flagToMaybe $ version flags)
        ?>> maybePrompt flags (prompt "Package version" v)
        ?>> return v
  return $ flags { version = maybeToFlag v' }

-- | Choose a license.
getLicense :: InitFlags -> IO InitFlags
getLicense flags = do
  lic <-     return (flagToMaybe $ license flags)
208
         ?>> fmap (fmap (either UnknownLicense id))
209
                  (maybePrompt flags
210
                    (promptList "Please choose a license" listedLicenses (Just BSD3) display True))
211
  return $ flags { license = maybeToFlag lic }
212
213
  where
    listedLicenses =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
214
215
      knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing
                       , Apache Nothing, OtherLicense]
216
217
218
219
220

-- | The author's name and email. Prompt, or try to guess from an existing
--   darcs repo.
getAuthorInfo :: InitFlags -> IO InitFlags
getAuthorInfo flags = do
EyalLotem's avatar
EyalLotem committed
221
222
  (authorName, authorEmail)  <-
    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
  authorName'  <-     return (flagToMaybe $ author flags)
                  ?>> maybePrompt flags (promptStr "Author name" authorName)
                  ?>> return authorName

  authorEmail' <-     return (flagToMaybe $ email flags)
                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)
                  ?>> return authorEmail

  return $ flags { author = maybeToFlag authorName'
                 , email  = maybeToFlag authorEmail'
                 }

-- | Prompt for a homepage URL.
getHomepage :: InitFlags -> IO InitFlags
getHomepage flags = do
  hp  <- queryHomepage
  hp' <-     return (flagToMaybe $ homepage flags)
240
         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
         ?>> return hp

  return $ flags { homepage = maybeToFlag hp' }

-- | Right now this does nothing, but it could be changed to do some
--   intelligent guessing.
queryHomepage :: IO (Maybe String)
queryHomepage = return Nothing     -- get default remote darcs repo?

-- | Prompt for a project synopsis.
getSynopsis :: InitFlags -> IO InitFlags
getSynopsis flags = do
  syn <-     return (flagToMaybe $ synopsis flags)
         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)

  return $ flags { synopsis = maybeToFlag syn }

-- | Prompt for a package category.
--   Note that it should be possible to do some smarter guessing here too, i.e.
--   look at the name of the top level source directory.
getCategory :: InitFlags -> IO InitFlags
getCategory flags = do
  cat <-     return (flagToMaybe $ category flags)
264
265
         ?>> fmap join (maybePrompt flags
                         (promptListOptional "Project category" [Codec ..]))
266
267
  return $ flags { category = maybeToFlag cat }

268
269
270
271
272
273
274
275
-- | Try to guess extra source files (don't prompt the user).
getExtraSourceFiles :: InitFlags -> IO InitFlags
getExtraSourceFiles flags = do
  extraSrcFiles <-     return (extraSrc flags)
                   ?>> Just `fmap` guessExtraSourceFiles flags

  return $ flags { extraSrc = extraSrcFiles }

276
277
278
defaultChangeLog :: FilePath
defaultChangeLog = "ChangeLog.md"

279
280
281
282
283
284
285
286
287
-- | Try to guess things to include in the extra-source-files field.
--   For now, we just look for things in the root directory named
--   'readme', 'changes', or 'changelog', with any sort of
--   capitalization and any extension.
guessExtraSourceFiles :: InitFlags -> IO [FilePath]
guessExtraSourceFiles flags = do
  dir <-
    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags
  files <- getDirectoryContents dir
288
289
290
291
  let extraFiles = filter isExtra files
  if any isLikeChangeLog extraFiles
    then return extraFiles
    else return (defaultChangeLog : extraFiles)
292
293

  where
294
295
296
297
    isExtra = likeFileNameBase ("README" : changeLogLikeBases)
    isLikeChangeLog = likeFileNameBase changeLogLikeBases
    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName
    changeLogLikeBases = ["CHANGES", "CHANGELOG"]
298

299
300
301
302
303
-- | Ask whether the project builds a library or executable.
getLibOrExec :: InitFlags -> IO InitFlags
getLibOrExec flags = do
  isLib <-     return (flagToMaybe $ packageType flags)
           ?>> maybePrompt flags (either (const Library) id `fmap`
EyalLotem's avatar
EyalLotem committed
304
305
306
                                   promptList "What does the package build"
                                   [Library, Executable]
                                   Nothing display False)
307
           ?>> return (Just Library)
308
  mainFile <- if isLib /= Just Executable then return Nothing else
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
309
                    getMainFile flags
310

311
  return $ flags { packageType = maybeToFlag isLib
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
312
                 , mainIs = maybeToFlag mainFile
313
314
                 }

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
315
316
317
318
319
320
321
322
-- | Try to guess the main file of the executable, and prompt the user to choose
-- one of them. Top-level modules including the word 'Main' in the file name
-- will be candidates, and shorter filenames will be preferred.
getMainFile :: InitFlags -> IO (Maybe FilePath)
getMainFile flags =
  return (flagToMaybe $ mainIs flags)
  ?>> do
    candidates <- guessMainFileCandidates flags
323
    let showCandidate = either (++" (does not yet exist, but will be created)") id
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
324
325
326
327
328
329
        defaultFile = listToMaybe candidates
    maybePrompt flags (either id (either id id) `fmap`
                       promptList "What is the main module of the executable"
                       candidates
                       defaultFile showCandidate True)
      ?>> return (fmap (either id id) defaultFile)
330

331
332
333
334
335
336
-- | Ask for the base language of the package.
getLanguage :: InitFlags -> IO InitFlags
getLanguage flags = do
  lang <-     return (flagToMaybe $ language flags)
          ?>> maybePrompt flags
                (either UnknownLanguage id `fmap`
EyalLotem's avatar
EyalLotem committed
337
338
339
                  promptList "What base language is the package written in"
                  [Haskell2010, Haskell98]
                  (Just Haskell2010) display True)
340
341
342
343
344
          ?>> return (Just Haskell2010)

  return $ flags { language = maybeToFlag lang }

-- | Ask whether to generate explanatory comments.
345
346
getGenComments :: InitFlags -> IO InitFlags
getGenComments flags = do
EyalLotem's avatar
EyalLotem committed
347
  genComments <-     return (not <$> flagToMaybe (noComments flags))
348
                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))
349
350
                 ?>> return (Just False)
  return $ flags { noComments = maybeToFlag (fmap not genComments) }
351
  where
352
    promptMsg = "Add informative comments to each field in the cabal file (y/n)"
353

354
-- | Ask for the source root directory.
355
356
getSrcDir :: InitFlags -> IO InitFlags
getSrcDir flags = do
357
358
  srcDirs <- return (sourceDirs flags)
             ?>> fmap (:[]) `fmap` guessSourceDir flags
359
             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt
360
361
                      flags
                      (promptListOptional' "Source directory" ["src"] id))
362
363
364

  return $ flags { sourceDirs = srcDirs }

365
-- | Try to guess source directory. Could try harder; for the
366
--   moment just looks to see whether there is a directory called 'src'.
367
368
guessSourceDir :: InitFlags -> IO (Maybe String)
guessSourceDir flags = do
EyalLotem's avatar
EyalLotem committed
369
370
  dir      <-
    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags
371
  srcIsDir <- doesDirectoryExist (dir </> "src")
372
373
374
  return $ if srcIsDir
             then Just "src"
             else Nothing
375

376
377
378
379
380
381
-- | Check whether a potential source file is located in one of the
--   source directories.
isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool
isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf
isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs

382
-- | Get the list of exposed modules and extra tools needed to build them.
383
getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags
384
getModulesBuildToolsAndDeps pkgIx flags = do
EyalLotem's avatar
EyalLotem committed
385
  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags
386

387
388
389
  sourceFiles0 <- scanForModules dir

  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0
390

391
  Just mods <-      return (exposedModules flags)
392
393
394
395
396
           ?>> (return . Just . map moduleName $ sourceFiles)

  tools <-     return (buildTools flags)
           ?>> (return . Just . neededBuildPrograms $ sourceFiles)

397
398
  deps <-      return (dependencies flags)
           ?>> Just <$> importsToDeps flags
399
400
401
402
403
404
405
406
                        (fromString "Prelude" :  -- to ensure we get base as a dep
                           (   nub   -- only need to consider each imported package once
                             . filter (`notElem` mods)  -- don't consider modules from
                                                        -- this package itself
                             . concatMap imports
                             $ sourceFiles
                           )
                        )
407
408
                        pkgIx

409
410
411
  exts <-     return (otherExts flags)
          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)

412
413
414
  return $ flags { exposedModules = Just mods
                 , buildTools     = tools
                 , dependencies   = deps
415
                 , otherExts      = exts
416
417
                 }

418
importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
importsToDeps flags mods pkgIx = do

  let modMap :: M.Map ModuleName [InstalledPackageInfo]
      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx

      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]
      modDeps = map (id &&& flip M.lookup modMap) mods

  message flags "\nGuessing dependencies..."
  nub . catMaybes <$> mapM (chooseDep flags) modDeps

-- Given a module and a list of installed packages providing it,
-- choose a dependency (i.e. package + version range) to use for that
-- module.
chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])
          -> IO (Maybe P.Dependency)

chooseDep flags (m, Nothing)
  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")
    >> return Nothing

chooseDep flags (m, Just [])
  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")
    >> return Nothing

    -- We found some packages: group them by name.
chooseDep flags (m, Just ps)
  = case pkgGroups of
      -- if there's only one group, i.e. multiple versions of a single package,
      -- we make it into a dependency, choosing the latest-ish version (see toDep).
      [grp] -> Just <$> toDep grp
      -- otherwise, we refuse to choose between different packages and make the user
      -- do it.
      grps  -> do message flags ("\nWarning: multiple packages found providing "
                                 ++ display m
                                 ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))
EyalLotem's avatar
EyalLotem committed
455
                  message flags "You will need to pick one and manually add it to the Build-depends: field."
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
                  return Nothing
  where
    pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)

    -- Given a list of available versions of the same package, pick a dependency.
    toDep :: [P.PackageIdentifier] -> IO P.Dependency

    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*
    toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize . P.pkgVersion $ pid)

    -- Otherwise, choose the latest version and issue a warning.
    toDep pids  = do
      message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")
      return $ P.Dependency (P.pkgName . head $ pids)
                            (pvpize . maximum . map P.pkgVersion $ pids)

472
473
474
475
-- | Given a version, return an API-compatible (according to PVP) version range.
--
-- Example: @0.4.1@ produces the version range @>= 0.4 && < 0.5@ (which is the
-- same as @0.4.*@).
476
477
478
479
480
pvpize :: Version -> VersionRange
pvpize v = orLaterVersion v'
           `intersectVersionRanges`
           earlierVersion (incVersion 1 v')
  where v' = (v { versionBranch = take 2 (versionBranch v) })
481

482
-- | Increment the nth version component (counting from 0).
483
484
485
486
487
488
489
incVersion :: Int -> Version -> Version
incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags
  where
    incVersion' 0 []     = [1]
    incVersion' 0 (v:_)  = [v+1]
    incVersion' m []     = replicate m 0 ++ [1]
    incVersion' m (v:vs) = v : incVersion' (m-1) vs
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507

---------------------------------------------------------------------------
--  Prompting/user interaction  -------------------------------------------
---------------------------------------------------------------------------

-- | Run a prompt or not based on the nonInteractive flag of the
--   InitFlags structure.
maybePrompt :: InitFlags -> IO t -> IO (Maybe t)
maybePrompt flags p =
  case nonInteractive flags of
    Flag True -> return Nothing
    _         -> Just `fmap` p

-- | Create a prompt with optional default value that returns a
--   String.
promptStr :: String -> Maybe String -> IO String
promptStr = promptDefault' Just id

508
509
510
511
512
513
514
515
516
517
518
519
-- | Create a yes/no prompt with optional default value.
--
promptYesNo :: String -> Maybe Bool -> IO Bool
promptYesNo =
    promptDefault' recogniseYesNo showYesNo
  where
    recogniseYesNo s | s == "y" || s == "Y" = Just True
                     | s == "n" || s == "N" = Just False
                     | otherwise            = Nothing
    showYesNo True  = "y"
    showYesNo False = "n"

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
-- | Create a prompt with optional default value that returns a value
--   of some Text instance.
prompt :: Text t => String -> Maybe t -> IO t
prompt = promptDefault'
           (either (const Nothing) Just . runReadE (readP_to_E id parse))
           display

-- | Create a prompt with an optional default value.
promptDefault' :: (String -> Maybe t)       -- ^ parser
               -> (t -> String)             -- ^ pretty-printer
               -> String                    -- ^ prompt message
               -> Maybe t                   -- ^ optional default value
               -> IO t
promptDefault' parser pretty pr def = do
  putStr $ mkDefPrompt pr (pretty `fmap` def)
  inp <- getLine
  case (inp, def) of
    ("", Just d)  -> return d
    _  -> case parser inp of
            Just t  -> return t
            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"
                          promptDefault' parser pretty pr def

-- | Create a prompt from a prompt string and a String representation
--   of an optional default value.
mkDefPrompt :: String -> Maybe String -> String
546
547
mkDefPrompt pr def = pr ++ "?" ++ defStr def
  where defStr Nothing  = " "
548
549
550
551
552
553
        defStr (Just s) = " [default: " ++ s ++ "] "

promptListOptional :: (Text t, Eq t)
                   => String            -- ^ prompt
                   -> [t]               -- ^ choices
                   -> IO (Maybe (Either String t))
554
555
556
557
558
559
560
561
promptListOptional pr choices = promptListOptional' pr choices display

promptListOptional' :: Eq t
                   => String            -- ^ prompt
                   -> [t]               -- ^ choices
                   -> (t -> String)     -- ^ show an item
                   -> IO (Maybe (Either String t))
promptListOptional' pr choices displayItem =
562
563
    fmap rearrange
  $ promptList pr (Nothing : map Just choices) (Just Nothing)
564
               (maybe "(none)" displayItem) True
565
  where
EyalLotem's avatar
EyalLotem committed
566
    rearrange = either (Just . Left) (fmap Right)
567
568

-- | Create a prompt from a list of items.
569
promptList :: Eq t
570
571
572
           => String            -- ^ prompt
           -> [t]               -- ^ choices
           -> Maybe t           -- ^ optional default value
573
           -> (t -> String)     -- ^ show an item
574
575
           -> Bool              -- ^ whether to allow an 'other' option
           -> IO (Either String t)
576
promptList pr choices def displayItem other = do
577
  putStrLn $ pr ++ ":"
578
  let options1 = map (\c -> (Just c == def, displayItem c)) choices
579
      options2 = zip ([1..]::[Int])
EyalLotem's avatar
EyalLotem committed
580
                     (options1 ++ [(False, "Other (specify)") | other])
581
  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2
582
  promptList' displayItem (length options2) choices def other
583
584
585
586
587
588
 where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest
                      | otherwise = " " ++ star i ++ rest
                  where rest = show n ++ ") "
                        star True = "*"
                        star False = " "

589
590
591
promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)
promptList' displayItem numChoices choices def other = do
  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)
592
593
594
595
596
597
598
  inp <- getLine
  case (inp, def) of
    ("", Just d) -> return $ Right d
    _  -> case readMaybe inp of
            Nothing -> invalidChoice inp
            Just n  -> getChoice n
 where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."
599
                              promptList' displayItem numChoices choices def other
600
601
602
603
604
605
606
607
608
609
610
611
       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)
                   | n < numChoices ||
                     (n == numChoices && not other)
                                  = return . Right $ choices !! (n-1)
                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing

---------------------------------------------------------------------------
--  File generation  ------------------------------------------------------
---------------------------------------------------------------------------

writeLicense :: InitFlags -> IO ()
writeLicense flags = do
612
  message flags "\nGenerating LICENSE..."
613
614
  year <- show <$> getYear
  let authors = fromMaybe "???" . flagToMaybe . author $ flags
615
616
  let licenseFile =
        case license flags of
617
618
619
620
621
          Flag BSD2
            -> Just $ bsd2 authors year

          Flag BSD3
            -> Just $ bsd3 authors year
622
623
624
625
626
627
628

          Flag (GPL (Just (Version {versionBranch = [2]})))
            -> Just gplv2

          Flag (GPL (Just (Version {versionBranch = [3]})))
            -> Just gplv3

629
630
          Flag (LGPL (Just (Version {versionBranch = [2, 1]})))
            -> Just lgpl21
631
632
633
634

          Flag (LGPL (Just (Version {versionBranch = [3]})))
            -> Just lgpl3

635
636
637
          Flag (AGPL (Just (Version {versionBranch = [3]})))
            -> Just agplv3

638
639
640
          Flag (Apache (Just (Version {versionBranch = [2, 0]})))
            -> Just apache20

641
642
643
          Flag MIT
            -> Just $ mit authors year

644
645
646
          Flag (MPL (Version {versionBranch = [2, 0]}))
            -> Just mpl20

647
648
649
          Flag ISC
            -> Just $ isc authors year

650
651
652
          _ -> Nothing

  case licenseFile of
653
    Just licenseText -> writeFileSafe flags "LICENSE" licenseText
654
655
656
657
658
659
660
661
662
663
664
665
666
    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."

getYear :: IO Integer
getYear = do
  u <- getCurrentTime
  z <- getCurrentTimeZone
  let l = utcToLocalTime z u
      (y, _, _) = toGregorian $ localDay l
  return y

writeSetupFile :: InitFlags -> IO ()
writeSetupFile flags = do
  message flags "Generating Setup.hs..."
667
  writeFileSafe flags "Setup.hs" setupFile
668
669
 where
  setupFile = unlines
670
    [ "import Distribution.Simple"
671
672
673
    , "main = defaultMain"
    ]

674
writeChangeLog :: InitFlags -> IO ()
675
writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
  message flags ("Generating "++ defaultChangeLog ++"...")
  writeFileSafe flags defaultChangeLog changeLog
 where
  changeLog = unlines
    [ "# Revision history for " ++ pname
    , ""
    , "## " ++ pver ++ "  -- YYYY-mm-dd"
    , ""
    , "* First version. Released on an unsuspecting world."
    ]
  pname = maybe "" display $ flagToMaybe $ packageName flags
  pver = maybe "" display $ flagToMaybe $ version flags



691
692
693
694
695
writeCabalFile :: InitFlags -> IO Bool
writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
  message flags "Error: no package name provided."
  return False
writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
Ian D. Bollinger's avatar
Ian D. Bollinger committed
696
  let cabalFileName = display p ++ ".cabal"
697
  message flags $ "Generating " ++ cabalFileName ++ "..."
698
  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
699
700
  return True

701
702
703
704
705
706
707
-- | Write a file \"safely\", backing up any existing version (unless
--   the overwrite flag is set).
writeFileSafe :: InitFlags -> FilePath -> String -> IO ()
writeFileSafe flags fileName content = do
  moveExistingFile flags fileName
  writeFile fileName content

708
709
710
711
712
713
-- | Create source directories, if they were given.
createSourceDirectories :: InitFlags -> IO ()
createSourceDirectories flags = case sourceDirs flags of
                                  Just dirs -> forM_ dirs (createDirectoryIfMissing True)
                                  Nothing   -> return ()

714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
-- | Create Main.hs, but only if we are init'ing an executable and
--   the mainIs flag has been provided.
createMainHs :: InitFlags -> IO ()
createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_)
                            , packageType = Flag Executable
                            , mainIs = Flag mainFile } =
  writeMainHs flags (srcPath </> mainFile)
createMainHs flags@InitFlags{ sourceDirs = _
                            , packageType = Flag Executable
                            , mainIs = Flag mainFile } =
  writeMainHs flags mainFile
createMainHs _ = return ()

-- | Write a main file if it doesn't already exist.
writeMainHs :: InitFlags -> FilePath -> IO ()
writeMainHs flags mainPath = do
  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
  let mainFullPath = dir </> mainPath
  exists <- doesFileExist mainFullPath
  unless exists $ do
      message flags $ "Generating " ++ mainPath ++ "..."
      writeFileSafe flags mainFullPath mainHs

-- | Default Main.hs file.  Used when no Main.hs exists.
mainHs :: String
mainHs = unlines
  [ "module Main where"
  , ""
  , "main :: IO ()"
743
  , "main = putStrLn \"Hello, Haskell!\""
744
745
  ]

746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
-- | Move an existing file, if there is one, and the overwrite flag is
--   not set.
moveExistingFile :: InitFlags -> FilePath -> IO ()
moveExistingFile flags fileName =
  unless (overwrite flags == Flag True) $ do
    e <- doesFileExist fileName
    when e $ do
      newName <- findNewName fileName
      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName
      copyFile fileName newName

findNewName :: FilePath -> IO FilePath
findNewName oldName = findNewName' 0
  where
    findNewName' :: Integer -> IO FilePath
    findNewName' n = do
      let newName = oldName <.> ("save" ++ show n)
      e <- doesFileExist newName
      if e then findNewName' (n+1) else return newName

766
767
768
769
770
771
772
773
774
-- | Generate a .cabal file from an InitFlags structure.  NOTE: this
--   is rather ad-hoc!  What we would REALLY like is to have a
--   standard low-level AST type representing .cabal files, which
--   preserves things like comments, and to write an *inverse*
--   parser/pretty-printer pair between .cabal files and this AST.
--   Then instead of this ad-hoc code we could just map an InitFlags
--   structure onto a low-level AST structure and use the existing
--   pretty-printing code to generate the file.
generateCabalFile :: String -> InitFlags -> String
775
generateCabalFile fileName c =
776
  (++ "\n") .
777
  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $
EyalLotem's avatar
EyalLotem committed
778
  (if minimal c /= Flag True
779
780
781
782
    then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "
                          ++ "init.  For further documentation, see "
                          ++ "http://haskell.org/cabal/users-guide/")
         $$ text ""
783
784
    else empty)
  $$
Ian D. Bollinger's avatar
Ian D. Bollinger committed
785
  vcat [ field  "name"          (packageName   c)
786
787
788
                (Just "The name of the package.")
                True

789
       , field  "version"       (version       c)
790
                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://wiki.haskell.org/Package_versioning_policy\n"
791
792
793
                ++ "PVP summary:      +-+------- breaking API changes\n"
                ++ "                  | | +----- non-breaking API additions\n"
                ++ "                  | | | +--- code changes with no API change")
794
795
                True

796
       , fieldS "synopsis"      (synopsis      c)
797
798
799
                (Just "A short (one-line) description of the package.")
                True

800
       , fieldS "description"   NoFlag
801
802
803
                (Just "A longer description of the package.")
                True

804
       , fieldS "homepage"      (homepage     c)
805
806
807
                (Just "URL for the project homepage or repository.")
                False

808
       , fieldS "bug-reports"   NoFlag
809
810
811
                (Just "A URL where users can report bugs.")
                False

812
       , field  "license"       (license      c)
813
814
815
                (Just "The license under which the package is released.")
                True

816
817
818
819
820
       , case (license c) of
           Flag PublicDomain -> empty
           _ -> fieldS "license-file" (Flag "LICENSE")
                       (Just "The file containing the license text.")
                       True
821

822
       , fieldS "author"        (author       c)
823
824
825
                (Just "The package author(s).")
                True

826
       , fieldS "maintainer"    (email        c)
827
828
829
                (Just "An email address to which users can send suggestions, bug reports, and patches.")
                True

830
831
832
833
834
       , case (license c) of
           Flag PublicDomain -> empty
           _ -> fieldS "copyright"     NoFlag
                       (Just "A copyright notice.")
                       True
835

836
       , fieldS "category"      (either id display `fmap` category c)
837
838
839
                Nothing
                True

840
       , fieldS "build-type"    (Flag "Simple")
841
842
843
                Nothing
                True

844
       , fieldS "extra-source-files" (listFieldS (extraSrc c))
845
                (Just "Extra files to be distributed with the package, such as examples or a README.")
846
                True
847

848
       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,10] []))
849
850
851
852
853
                (Just "Constraint on the version of Cabal needed to build this package.")
                False

       , case packageType c of
           Flag Executable ->
Ian D. Bollinger's avatar
Ian D. Bollinger committed
854
855
856
             text "\nexecutable" <+>
             text (maybe "" display . flagToMaybe $ packageName c) $$
             nest 2 (vcat
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
857
             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True
858

859
             , generateBuildInfo Executable c
860
             ])
EyalLotem's avatar
EyalLotem committed
861
           Flag Library    -> text "\nlibrary" $$ nest 2 (vcat
862
             [ fieldS "exposed-modules" (listField (exposedModules c))
863
864
865
                      (Just "Modules exported by the library.")
                      True

866
             , generateBuildInfo Library c
867
868
869
870
             ])
           _               -> empty
       ]
 where
871
872
873
874
875
876
   generateBuildInfo :: PackageType -> InitFlags -> Doc
   generateBuildInfo pkgtype c' = vcat
     [ fieldS "other-modules" (listField (otherModules c'))
              (Just $ case pkgtype of
                 Library    -> "Modules included in this library but not exported."
                 Executable -> "Modules included in this executable, other than Main.")
877
878
              True

879
880
881
882
     , fieldS "other-extensions" (listField (otherExts c'))
              (Just "LANGUAGE extensions used by modules in this package.")
              True

883
884
     , fieldS "build-depends" (listField (dependencies c'))
              (Just "Other library packages from which modules are imported.")
885
886
887
              True

     , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))
888
              (Just "Directories containing source files.")
889
              True
890

891
     , fieldS "build-tools" (listFieldS (buildTools c'))
892
              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")
893
              False
894
895
896
897

     , field  "default-language" (language c')
              (Just "Base language which the package is written in.")
              True
898
899
900
901
902
903
     ]

   listField :: Text s => Maybe [s] -> Flag String
   listField = listFieldS . fmap (map display)

   listFieldS :: Maybe [String] -> Flag String
904
   listFieldS = Flag . maybe "" (intercalate ", ")
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc
   field s f = fieldS s (fmap display f)

   fieldS :: String        -- ^ Name of the field
          -> Flag String   -- ^ Field contents
          -> Maybe String  -- ^ Comment to explain the field
          -> Bool          -- ^ Should the field be included (commented out) even if blank?
          -> Doc
   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty
   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty
   fieldS s f com _ = case (isJust com, noComments c, minimal c) of
                        (_, _, Flag True) -> id
                        (_, Flag True, _) -> id
                        (True, _, _)      -> (showComment com $$) . ($$ text "")
                        (False, _, _)     -> ($$ text "")
                      $
922
923
924
                      comment f <<>> text s <<>> colon
                                <<>> text (replicate (20 - length s) ' ')
                                <<>> text (fromMaybe "" . flagToMaybe $ f)
925
926
927
928
929
   comment NoFlag    = text "-- "
   comment (Flag "") = text "-- "
   comment _         = text ""

   showComment :: Maybe String -> Doc
EyalLotem's avatar
EyalLotem committed
930
931
   showComment (Just t) = vcat
                        . map (text . ("-- "++)) . lines
932
933
934
935
                        . renderStyle style {
                            lineLength = 76,
                            ribbonsPerLine = 1.05
                          }
936
937
938
939
                        . vcat
                        . map (fcat . map text . breakLine)
                        . lines
                        $ t
940
941
   showComment Nothing  = text ""

942
943
944
945
946
   breakLine  [] = []
   breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'
   breakLine' [] = []
   breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'

947
948
949
950
951
952
953
954
955
956
957
958
959
960
-- | Generate warnings for missing fields etc.
generateWarnings :: InitFlags -> IO ()
generateWarnings flags = do
  message flags ""
  when (synopsis flags `elem` [NoFlag, Flag ""])
       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")

  message flags "You may want to edit the .cabal file and add a Description field."

-- | Possibly generate a message to stdout, taking into account the
--   --quiet flag.
message :: InitFlags -> String -> IO ()
message (InitFlags{quiet = Flag True}) _ = return ()
message _ s = putStrLn s