-----------------------------------------------------------------------------
-- |
-- 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
  , incVersion

  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (empty)

import Distribution.Deprecated.ReadP (readP_to_E)

import System.IO
  ( hSetBuffering, stdout, BufferMode(..) )
import System.Directory
  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile
  , getDirectoryContents, createDirectoryIfMissing )
import System.FilePath
  ( (</>), (<.>), takeBaseName, takeExtension, equalFilePath )
import Data.Time
  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )

import Data.List
  ( (\\) )
import qualified Data.List.NonEmpty as NE
import Data.Function
  ( on )
import qualified Data.Map as M
import qualified Data.Set as Set
import Control.Monad
  ( (>=>), join, forM_, mapM, mapM_ )
import Control.Arrow
  ( (&&&), (***) )

import Text.PrettyPrint hiding (mode, cat)

import Distribution.Version
  ( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion
  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )
import Distribution.Verbosity
  ( Verbosity )
import Distribution.ModuleName
  ( ModuleName )  -- And for the Text instance
import qualified Distribution.ModuleName as ModuleName
  ( fromString, toFilePath )
import Distribution.InstalledPackageInfo
  ( InstalledPackageInfo, exposed )
import qualified Distribution.Package as P
import Distribution.Types.LibraryName
  ( LibraryName(..) )
import Language.Haskell.Extension ( Language(..) )

import Distribution.Client.Init.Types
  ( InitFlags(..), BuildType(..), PackageType(..), Category(..)
  , displayPackageType )
import Distribution.Client.Init.Licenses
  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )
import Distribution.Client.Init.Heuristics
  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,
    SourceFileEntry(..),
    scanForModules, neededBuildPrograms )

import Distribution.License
  ( License(..), knownLicenses, licenseToSPDX )
import qualified Distribution.SPDX as SPDX

import Distribution.ReadE
  ( runReadE )
import Distribution.Simple.Setup
  ( Flag(..), flagToMaybe )
import Distribution.Simple.Utils
  ( dropWhileEndLE )
import Distribution.Simple.Configure
  ( getInstalledPackages )
import Distribution.Simple.Compiler
  ( PackageDBStack, Compiler )
import Distribution.Simple.Program
  ( ProgramDb )
import Distribution.Simple.PackageIndex
  ( InstalledPackageIndex, moduleNameIndex )
import Distribution.Deprecated.Text
  ( display, Text(..) )
import Distribution.Pretty
  ( prettyShow )
import Distribution.Parsec
  ( eitherParsec )

import Distribution.Solver.Types.PackageIndex
  ( elemByPackageName )

import Distribution.Client.IndexUtils
  ( getSourcePackages )
import Distribution.Client.Types
  ( SourcePackageDb(..) )
import Distribution.Client.Setup
  ( RepoContext(..) )

initCabal :: Verbosity
          -> PackageDBStack
          -> RepoContext
          -> Compiler
          -> ProgramDb
          -> InitFlags
          -> IO ()
initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do

  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
  sourcePkgDb <- getSourcePackages verbosity repoCtxt

  hSetBuffering stdout NoBuffering

  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags

  case license initFlags' of
    Flag PublicDomain -> return ()
    _                 -> writeLicense initFlags'
  writeSetupFile initFlags'
  writeChangeLog initFlags'
  createDirectories (sourceDirs initFlags')
  createLibHs initFlags'
  createDirectories (applicationDirs initFlags')
  createMainHs initFlags'
  -- If a test suite was requested and this is not an executable-only
  -- package, then create the "test" directory.
  when (eligibleForTestSuite initFlags') $ do
    createDirectories (testDirs initFlags')
    createTestHs initFlags'
  success <- writeCabalFile initFlags'

  when success $ generateWarnings initFlags'

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

-- | Fill in more details by guessing, discovering, or prompting the
--   user.
extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags
extendFlags pkgIx sourcePkgDb =
      getSimpleProject
  >=> getLibOrExec
  >=> getCabalVersion
  >=> getPackageName sourcePkgDb
  >=> getVersion
  >=> getLicense
  >=> getAuthorInfo
  >=> getHomepage
  >=> getSynopsis
  >=> getCategory
  >=> getExtraSourceFiles
  >=> getAppDir
  >=> getSrcDir
  >=> getGenTests
  >=> getTestDir
  >=> getLanguage
  >=> getGenComments
  >=> getModulesBuildToolsAndDeps pkgIx

-- | 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

defaultCabalVersion :: Version
defaultCabalVersion = mkVersion [1,10]

displayCabalVersion :: Version -> String
displayCabalVersion v = case versionNumbers v of
  [1,10] -> "1.10   (legacy)"
  [2,0]  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"
  [2,2]  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"
  [2,4]  -> "2.4    (+ support for '**' globbing)"
  _      -> display v

-- | Ask if a simple project with sensible defaults should be created.
getSimpleProject :: InitFlags -> IO InitFlags
getSimpleProject flags = do
  simpleProj <-     return (flagToMaybe $ simpleProject flags)
                ?>> maybePrompt flags
                    (promptYesNo
                      "Should I generate a simple project with sensible defaults"
                      (Just True))
  return $ case maybeToFlag simpleProj of
    Flag True ->
      flags { interactive = Flag False
            , simpleProject = Flag True
            , packageType = Flag LibraryAndExecutable
            , cabalVersion = Flag (mkVersion [2,4])
            }
    simpleProjFlag@_ ->
      flags { simpleProject = simpleProjFlag }


-- | Ask which version of the cabal spec to use.
getCabalVersion :: InitFlags -> IO InitFlags
getCabalVersion flags = do
  cabVer <-     return (flagToMaybe $ cabalVersion flags)
            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`
                                  promptList "Please choose version of the Cabal specification to use"
                                  [mkVersion [1,10], mkVersion [2,0], mkVersion [2,2], mkVersion [2,4]]
                                  (Just defaultCabalVersion) displayCabalVersion False)
            ?>> return (Just defaultCabalVersion)

  return $  flags { cabalVersion = maybeToFlag cabVer }


-- | Get the package name: use the package directory (supplied, or the current
--   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
  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)
              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)

  let guess' | isPkgRegistered guess = Nothing
             | otherwise = guess

  pkgName' <-     return (flagToMaybe $ packageName flags)
              ?>> 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

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

-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user
--  if possible.
getVersion :: InitFlags -> IO InitFlags
getVersion flags = do
  let v = Just $ mkVersion [0,1,0,0]
  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)
         ?>> fmap (fmap (either UnknownLicense id))
                  (maybePrompt flags
                    (promptList "Please choose a license" listedLicenses
                     (Just BSD3) displayLicense True))

  case checkLicenseInvalid lic of
    Just msg -> putStrLn msg >> getLicense flags
    Nothing  -> return $ flags { license = maybeToFlag lic }

  where
    displayLicense l | needSpdx  = prettyShow (licenseToSPDX l)
                     | otherwise = display l

    checkLicenseInvalid (Just (UnknownLicense t))
      | needSpdx  = case eitherParsec t :: Either String SPDX.License of
                      Right _ -> Nothing
                      Left _  -> Just "\nThe license must be a valid SPDX expression."
      | otherwise = if any (not . isAlphaNum) t
                    then Just promptInvalidOtherLicenseMsg
                    else Nothing
    checkLicenseInvalid _ = Nothing

    promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++
                                   "If your license name has many words, " ++
                                   "the convention is to use camel case (e.g. PublicDomain). " ++
                                   "Please choose a different license."

    listedLicenses =
      knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing
                       , Apache Nothing, OtherLicense]

    needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags)

-- | The author's name and email. Prompt, or try to guess from an existing
--   darcs repo.
getAuthorInfo :: InitFlags -> IO InitFlags
getAuthorInfo flags = do
  (authorName, authorEmail)  <-
    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail
  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)
         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)
         ?>> 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)
         ?>> fmap join (maybePrompt flags
                         (promptListOptional "Project category" [Codec ..]))
  return $ flags { category = maybeToFlag cat }

-- | 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 }

defaultChangeLog :: FilePath
defaultChangeLog = "CHANGELOG.md"

-- | 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
  let extraFiles = filter isExtra files
  if any isLikeChangeLog extraFiles
    then return extraFiles
    else return (defaultChangeLog : extraFiles)

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

-- | Ask whether the project builds a library or executable.
getLibOrExec :: InitFlags -> IO InitFlags
getLibOrExec flags = do
  pkgType <-     return (flagToMaybe $ packageType flags)
           ?>> maybePrompt flags (either (const Executable) id `fmap`
                                   promptList "What does the package build"
                                   [Executable, Library, LibraryAndExecutable]
                                   Nothing displayPackageType False)
           ?>> return (Just Executable)

  -- If this package contains an executable, get the main file name.
  mainFile <- if pkgType == Just Library then return Nothing else
                    getMainFile flags

  return $ flags { packageType = maybeToFlag pkgType
                 , mainIs = maybeToFlag mainFile
                 }


-- | 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
    let showCandidate = either (++" (does not yet exist, but will be created)") id
        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)

-- | Ask if a test suite should be generated for the library.
getGenTests :: InitFlags -> IO InitFlags
getGenTests flags = do
  genTests <-     return (flagToMaybe $ initializeTestSuite flags)
                  -- Only generate a test suite if the package contains a library.
              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing
              ?>> maybePrompt flags
                  (promptYesNo
                    "Should I generate a test suite for the library"
                    (Just True))
  return $ flags { initializeTestSuite = maybeToFlag genTests }

-- | Ask for the test root directory.
getTestDir :: InitFlags -> IO InitFlags
getTestDir flags = do
  dirs <- return (testDirs flags)
              -- Only need testDirs when test suite generation is enabled.
          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing
          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt
                   flags
                   (promptList "Test directory" ["test"] (Just "test") id True))

  return $ flags { testDirs = dirs }

-- | 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`
                  promptList "What base language is the package written in"
                  [Haskell2010, Haskell98]
                  (Just Haskell2010) display True)
          ?>> return (Just Haskell2010)

  if invalidLanguage lang
    then putStrLn invalidOtherLanguageMsg >> getLanguage flags
    else return $ flags { language = maybeToFlag lang }

  where
    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t
    invalidLanguage _ = False

    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++
                              "Please enter a different language."

-- | Ask whether to generate explanatory comments.
getGenComments :: InitFlags -> IO InitFlags
getGenComments flags = do
  genComments <-     return (not <$> flagToMaybe (noComments flags))
                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))
                 ?>> return (Just False)
  return $ flags { noComments = maybeToFlag (fmap not genComments) }
  where
    promptMsg = "Add informative comments to each field in the cabal file (y/n)"

-- | Ask for the application root directory.
getAppDir :: InitFlags -> IO InitFlags
getAppDir flags = do
  appDirs <- return (applicationDirs flags)
             -- No application dir if this is a 'Library'.
             ?>> if (packageType flags) == Flag Library then return (Just []) else return Nothing
             ?>> fmap (:[]) `fmap` guessAppDir flags
             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt
                      flags
                      (promptListOptional'
                       ("Application " ++ mainFile ++ "directory")
                       ["src-exe", "app"] id))

  return $ flags { applicationDirs = appDirs }

  where
    mainFile = case mainIs flags of
      Flag mainPath -> "(" ++ mainPath ++ ") "
      _             -> ""

-- | Try to guess app directory. Could try harder; for the
--   moment just looks to see whether there is a directory called 'app'.
guessAppDir :: InitFlags -> IO (Maybe String)
guessAppDir flags = do
  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags
  appIsDir <- doesDirectoryExist (dir </> "app")
  return $ if appIsDir
             then Just "app"
             else Nothing

-- | Ask for the source (library) root directory.
getSrcDir :: InitFlags -> IO InitFlags
getSrcDir flags = do
  srcDirs <- return (sourceDirs flags)
             -- source dir if this is an 'Executable'.
             ?>> if (packageType flags) == Flag Executable then return (Just []) else return Nothing
             ?>> fmap (:[]) `fmap` guessSourceDir flags
             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt
                      flags
                      (promptListOptional' "Library source directory"
                       ["src", "lib", "src-lib"] id))

  return $ flags { sourceDirs = srcDirs }

-- | Try to guess source directory. Could try harder; for the
--   moment just looks to see whether there is a directory called 'src'.
guessSourceDir :: InitFlags -> IO (Maybe String)
guessSourceDir flags = do
  dir      <-
    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags
  srcIsDir <- doesDirectoryExist (dir </> "src")
  return $ if srcIsDir
             then Just "src"
             else Nothing

-- | 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

-- | Get the list of exposed modules and extra tools needed to build them.
getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags
getModulesBuildToolsAndDeps pkgIx flags = do
  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags

  sourceFiles0 <- scanForModules dir

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

  Just mods <-      return (exposedModules flags)
           ?>> (return . Just . map moduleName $ sourceFiles)

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

  deps <-      return (dependencies flags)
           ?>> Just <$> importsToDeps flags
                        (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
                           )
                        )
                        pkgIx

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

  -- If we're initializing a library and there were no modules discovered
  -- then create an empty 'MyLib' module.
  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because
  -- then the executable needs to set 'other-modules: MyLib' or else the build
  -- fails.
  let (finalModsList, otherMods) = case (packageType flags, mods) of

        -- For an executable leave things as they are.
        (Flag Executable, _) -> (mods, otherModules flags)

        -- If a non-empty module list exists don't change anything.
        (_, (_:_)) -> (mods, otherModules flags)

        -- Library only: 'MyLib' in 'other-modules' only.
        (Flag Library, _) -> ([myLibModule], Nothing)

        -- For a 'LibraryAndExecutable' we need to have special handling.
        -- If we don't have a module list (Nothing or empty), then create a Lib.
        (_, []) ->
          if sourceDirs flags == applicationDirs flags
          then ([myLibModule], Just [myLibModule])
          else ([myLibModule], Nothing)

  return $ flags { exposedModules = Just finalModsList
                 , otherModules   = otherMods
                 , buildTools     = tools
                 , dependencies   = deps
                 , otherExts      = exts
                 }

importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]
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 ", " (fmap (display . P.pkgName . NE.head) grps))
                  message flags "You will need to pick one and manually add it to the Build-depends: field."
                  return Nothing
  where
    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)

    desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags)

    -- Given a list of available versions of the same package, pick a dependency.
    toDep :: NonEmpty 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 desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries

    -- Otherwise, choose the latest version and issue a warning.
    toDep pids  = do
      message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")
      return $ P.Dependency (P.pkgName . NE.head $ pids)
                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)
                            (Set.singleton LMainLibName) --TODO take into account sublibraries

-- | Given a version, return an API-compatible (according to PVP) version range.
--
-- If the boolean argument denotes whether to use a desugared
-- representation (if 'True') or the new-style @^>=@-form (if
-- 'False').
--
-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the
-- same as @0.4.*@).
pvpize :: Bool -> Version -> VersionRange
pvpize False  v = majorBoundVersion v
pvpize True   v = orLaterVersion v'
           `intersectVersionRanges`
           earlierVersion (incVersion 1 v')
  where v' = alterVersion (take 2) v

-- | Increment the nth version component (counting from 0).
incVersion :: Int -> Version -> Version
incVersion n = alterVersion (incVersion' n)
  where
    incVersion' 0 []     = [1]
    incVersion' 0 (v:_)  = [v+1]
    incVersion' m []     = replicate m 0 ++ [1]
    incVersion' m (v:vs) = v : incVersion' (m-1) vs

-- | Returns true if this package is eligible for test suite initialization.
eligibleForTestSuite :: InitFlags -> Bool
eligibleForTestSuite flags =
  Flag True == initializeTestSuite flags
  && Flag Executable /= packageType flags

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

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

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

-- | 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"

-- | 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
mkDefPrompt pr def = pr ++ "?" ++ defStr def
  where defStr Nothing  = " "
        defStr (Just s) = " [default: " ++ s ++ "] "

promptListOptional :: (Text t, Eq t)
                   => String            -- ^ prompt
                   -> [t]               -- ^ choices
                   -> IO (Maybe (Either String t))
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 =
    fmap rearrange
  $ promptList pr (Nothing : map Just choices) (Just Nothing)
               (maybe "(none)" displayItem) True
  where
    rearrange = either (Just . Left) (fmap Right)

-- | Create a prompt from a list of items.
promptList :: Eq t
           => String            -- ^ prompt
           -> [t]               -- ^ choices
           -> Maybe t           -- ^ optional default value
           -> (t -> String)     -- ^ show an item
           -> Bool              -- ^ whether to allow an 'other' option
           -> IO (Either String t)
promptList pr choices def displayItem other = do
  putStrLn $ pr ++ ":"
  let options1 = map (\c -> (Just c == def, displayItem c)) choices
      options2 = zip ([1..]::[Int])
                     (options1 ++ [(False, "Other (specify)") | other])
  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2
  promptList' displayItem (length options2) choices def other
 where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest
                      | otherwise = " " ++ star i ++ rest
                  where rest = show n ++ ") "
                        star True = "*"
                        star False = " "

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)
  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."
                              promptList' displayItem numChoices choices def other
       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
  message flags "\nGenerating LICENSE..."
  year <- show <$> getYear
  let authors = fromMaybe "???" . flagToMaybe . author $ flags
  let licenseFile =
        case license flags of
          Flag BSD2
            -> Just $ bsd2 authors year

          Flag BSD3
            -> Just $ bsd3 authors year

          Flag (GPL (Just v)) | v == mkVersion [2]
            -> Just gplv2

          Flag (GPL (Just v)) | v == mkVersion [3]
            -> Just gplv3

          Flag (LGPL (Just v)) | v == mkVersion [2,1]
            -> Just lgpl21

          Flag (LGPL (Just v)) | v == mkVersion [3]
            -> Just lgpl3

          Flag (AGPL (Just v)) | v == mkVersion [3]
            -> Just agplv3

          Flag (Apache (Just v)) | v == mkVersion [2,0]
            -> Just apache20

          Flag MIT
            -> Just $ mit authors year

          Flag (MPL v) | v == mkVersion [2,0]
            -> Just mpl20

          Flag ISC
            -> Just $ isc authors year

          _ -> Nothing

  case licenseFile of
    Just licenseText -> writeFileSafe flags "LICENSE" licenseText
    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..."
  writeFileSafe flags "Setup.hs" setupFile
 where
  setupFile = unlines
    [ "import Distribution.Simple"
    , "main = defaultMain"
    ]

writeChangeLog :: InitFlags -> IO ()
writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do
  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



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
  let cabalFileName = display p ++ ".cabal"
  message flags $ "Generating " ++ cabalFileName ++ "..."
  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
  return True

-- | 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

-- | Create directories, if they were given, and don't already exist.
createDirectories :: Maybe [String] -> IO ()
createDirectories mdirs = case mdirs of
  Just dirs -> forM_ dirs (createDirectoryIfMissing True)
  Nothing   -> return ()

-- | Create MyLib.hs file, if its the only module in the liste.
createLibHs :: InitFlags -> IO ()
createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do
  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"
  case sourceDirs flags of
    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)
    _                -> writeLibHs flags modFilePath

-- | Write a MyLib.hs file if it doesn't already exist.
writeLibHs :: InitFlags -> FilePath -> IO ()
writeLibHs flags libPath = do
  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
  let libFullPath = dir </> libPath
  exists <- doesFileExist libFullPath
  unless exists $ do
    message flags $ "Generating " ++ libPath ++ "..."
    writeFileSafe flags libFullPath myLibHs

myLibModule :: ModuleName
myLibModule = ModuleName.fromString "MyLib"

-- | Default MyLib.hs file.  Used when no Lib.hs exists.
myLibHs :: String
myLibHs = unlines
  [ "module MyLib (someFunc) where"
  , ""
  , "someFunc :: IO ()"
  , "someFunc = putStrLn \"someFunc\""
  ]

-- | Create Main.hs, but only if we are init'ing an executable and
--   the mainIs flag has been provided.
createMainHs :: InitFlags -> IO ()
createMainHs flags =
  if hasMainHs flags then
    case applicationDirs flags of
      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)
      _ -> writeMainHs flags mainFile
  else return ()
  where
    mainFile = case mainIs flags of
      Flag x -> x
      NoFlag -> error "createMainHs: no mainIs"

--- | 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 flags)

-- | Check that a main file exists.
hasMainHs :: InitFlags -> Bool
hasMainHs flags = case mainIs flags of
  Flag _ -> (packageType flags == Flag Executable
             || packageType flags == Flag LibraryAndExecutable)
  _ -> False

-- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.
--
--   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.
mainHs :: InitFlags -> String
mainHs flags = (unlines . map prependPrefix) $ case packageType flags of
  Flag LibraryAndExecutable ->
    [ "module Main where"
    , ""
    , "import qualified MyLib (someFunc)"
    , ""
    , "main :: IO ()"
    , "main = do"
    , "  putStrLn \"Hello, Haskell!\""
    , "  MyLib.someFunc"
    ]
  _ ->
    [ "module Main where"
    , ""
    , "main :: IO ()"
    , "main = putStrLn \"Hello, Haskell!\""
    ]
  where
    prependPrefix "" = ""
    prependPrefix line
      | isLiterate = "> " ++ line
      | otherwise  = line
    isLiterate = case mainIs flags of
      Flag mainPath -> takeExtension mainPath == ".lhs"
      _             -> False

testFile :: String
testFile = "MyLibTest.hs"

-- | Create MyLibTest.hs, but only if we are init'ing a library and
--   the initializeTestSuite flag has been set.
createTestHs :: InitFlags -> IO ()
createTestHs flags =
  when (eligibleForTestSuite flags) $
    case testDirs flags of
      Just (testPath:_) -> writeTestHs flags (testPath </> testFile)
      _ -> writeMainHs flags testFile

--- | Write a test file.
writeTestHs :: InitFlags -> FilePath -> IO ()
writeTestHs flags testPath = do
  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
  let testFullPath = dir </> testPath
  exists <- doesFileExist testFullPath
  unless exists $ do
      message flags $ "Generating " ++ testPath ++ "..."
      writeFileSafe flags testFullPath testHs

-- | Default MyLibTest.hs file.
testHs :: String
testHs = unlines
  [ "module Main (main) where"
  , ""
  , "main :: IO ()"
  , "main = putStrLn \"Test suite not yet implemented.\""
  ]


-- | 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

-- | 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
generateCabalFile fileName c = trimTrailingWS $
  (++ "\n") .
  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $
  -- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD
  (if specVer < mkVersion [1,12]
   then field "cabal-version" (Flag $ orLaterVersion specVer) -- legacy
   else field "cabal-version" (Flag $ specVer))
              Nothing -- NB: the first line must be the 'cabal-version' declaration
              False
  $$
  (if minimal c /= Flag True
    then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated "
                          ++ "by 'cabal init'.  For further documentation, see "
                          ++ "http://haskell.org/cabal/users-guide/")
         $$ text ""
    else empty)
  $$
  vcat [ field  "name"          (packageName   c)
                (Just "The name of the package.")
                True

       , field  "version"       (version       c)
                (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"
                ++ "PVP summary:      +-+------- breaking API changes\n"
                ++ "                  | | +----- non-breaking API additions\n"
                ++ "                  | | | +--- code changes with no API change")
                True

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

       , fieldS "description"   NoFlag
                (Just "A longer description of the package.")
                True

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

       , fieldS "bug-reports"   NoFlag
                (Just "A URL where users can report bugs.")
                True

       , fieldS  "license"      licenseStr
                (Just "The license under which the package is released.")
                True

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

       , fieldS "author"        (author       c)
                (Just "The package author(s).")
                True

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

       , case (license c) of
           Flag PublicDomain -> empty
           _ -> fieldS "copyright"     NoFlag
                       (Just "A copyright notice.")
                       True

       , fieldS "category"      (either id display `fmap` category c)
                Nothing
                True

       , fieldS "build-type"    (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple")
                Nothing
                False

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

       , case packageType c of
           Flag Executable -> executableStanza
           Flag Library    -> libraryStanza
           Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza
           _               -> empty

       , if eligibleForTestSuite c then testSuiteStanza else empty
       ]
 where
   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)

   licenseStr | specVer < mkVersion [2,2] = prettyShow `fmap` license c
              | otherwise                 = go `fmap` license c
     where
       go (UnknownLicense s) = s
       go l                  = prettyShow (licenseToSPDX l)

   generateBuildInfo :: BuildType -> InitFlags -> Doc
   generateBuildInfo buildType c' = vcat
     [ fieldS "other-modules" (listField otherMods)
              (Just $ case buildType of
                 LibBuild    -> "Modules included in this library but not exported."
                 ExecBuild -> "Modules included in this executable, other than Main.")
              True

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

     , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c'))
              (Just "Other library packages from which modules are imported.")
              True

     , fieldS "hs-source-dirs" (listFieldS (case buildType of
                                            LibBuild  -> sourceDirs c'
                                            ExecBuild -> applicationDirs c'))
              (Just "Directories containing source files.")
              True

     , fieldS "build-tools" (listFieldS (buildTools c'))
              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")
              False

     , field  "default-language" (language c')
              (Just "Base language which the package is written in.")
              True
     ]
     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).
     where
       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild
                      then case packageName c' of
                             Flag pkgName -> ", " ++ P.unPackageName pkgName
                             _ -> ""
                      else ""

       -- Only include 'MyLib' in 'other-modules' of the executable.
       otherModsFromFlag = otherModules c'
       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]
                   then Nothing
                   else otherModsFromFlag

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

   listFieldS :: Maybe [String] -> Flag String
   listFieldS = Flag . maybe "" (intercalate ", ")

   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 "")
                      $
                      comment f <<>> text s <<>> colon
                                <<>> text (replicate (20 - length s) ' ')
                                <<>> text (fromMaybe "" . flagToMaybe $ f)
   comment NoFlag    = text "-- "
   comment (Flag "") = text "-- "
   comment _         = text ""

   showComment :: Maybe String -> Doc
   showComment (Just t) = vcat
                        . map (text . ("-- "++)) . lines
                        . renderStyle style {
                            lineLength = 76,
                            ribbonsPerLine = 1.05
                          }
                        . vcat
                        . map (fcat . map text . breakLine)
                        . lines
                        $ t
   showComment Nothing  = text ""

   breakLine  [] = []
   breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'
   breakLine' [] = []
   breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'

   trimTrailingWS :: String -> String
   trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines

   executableStanza :: Doc
   executableStanza = text "\nexecutable" <+>
             text (maybe "" display . flagToMaybe $ packageName c) $$
             nest 2 (vcat
             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True

             , generateBuildInfo ExecBuild c
             ])

   libraryStanza :: Doc
   libraryStanza = text "\nlibrary" $$ nest 2 (vcat
             [ fieldS "exposed-modules" (listField (exposedModules c))
                      (Just "Modules exported by the library.")
                      True

             , generateBuildInfo LibBuild c
             ])

   testSuiteStanza :: Doc
   testSuiteStanza = text "\ntest-suite" <+>
     text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$
     nest 2 (vcat
             [ field  "default-language" (language c)
               (Just "Base language which the package is written in.")
               True

             , fieldS "type" (Flag "exitcode-stdio-1.0")
               (Just "The interface type and version of the test suite.")
               True

             , fieldS "hs-source-dirs" (listFieldS (testDirs c))
               (Just "The directory where the test specifications are found.")
               True

             , fieldS "main-is" (Flag testFile)
               (Just "The entrypoint to the test suite.")
               True

             , fieldS "build-depends" (listField (dependencies c))
               (Just "Test dependencies.")
               True
             ])

-- | 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
