<commit_before>{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Init
-- Copyright   :  (c) <NAME> 2009
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- 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

  ) where

import System.IO
  ( hSetBuffering, stdout, BufferMode(..) )
import System.Directory
  ( getCurrentDirectory )
import Data.Time
  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )

import Data.List
  ( intersperse, (\\) )
import Data.Maybe
  ( fromMaybe, isJust )
import Data.Traversable
  ( traverse )
import Control.Monad
  ( when )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
  ( (>=>), join )
#endif

import Text.PrettyPrint hiding (mode, cat)

import Data.Version
  ( Version(..) )
import Distribution.Version
  ( orLaterVersion )

import Distribution.Client.Init.Types
  ( InitFlags(..), PackageType(..), Category(..) )
import Distribution.Client.Init.Licenses
  ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )
import Distribution.Client.Init.Heuristics
  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )

import Distribution.License
  ( License(..), knownLicenses )
import Distribution.ModuleName
  ( ) -- for the Text instance

import Distribution.ReadE
  ( runReadE, readP_to_E )
import Distribution.Simple.Setup
  ( Flag(..), flagToMaybe )
import Distribution.Text
  ( display, Text(..) )

initCabal :: InitFlags -> IO ()
initCabal initFlags = do
  hSetBuffering stdout NoBuffering

  initFlags' <- extendFlags initFlags

  writeLicense initFlags'
  writeSetupFile initFlags'
  success <- writeCabalFile initFlags'

  when success $ generateWarnings initFlags'

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

-- | Fill in more details by guessing, discovering, or prompting the
--   user.
extendFlags :: InitFlags -> IO InitFlags
extendFlags =  getPackageName
           >=> getVersion
           >=> getLicense
           >=> getAuthorInfo
           >=> getHomepage
           >=> getSynopsis
           >=> getCategory
           >=> getLibOrExec
           >=> getGenComments
           >=> getSrcDir
           >=> getModulesAndBuildTools

-- | 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
--   directory by default) as a guess.
getPackageName :: InitFlags -> IO InitFlags
getPackageName flags = do
  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)
              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)

  pkgName' <-     return (flagToMaybe $ packageName flags)
              ?>> maybePrompt flags (promptStr "Package name" guess)
              ?>> return guess

  return $ flags { packageName = maybeToFlag pkgName' }

-- | 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 $ Version { versionBranch = [0,1,0,0], versionTags = [] }
  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) . join)
                  (maybePrompt flags
                    (promptListOptional "Please choose a license" listedLicenses))
  return $ flags { license = maybeToFlag lic }
  where
    listedLicenses =
      knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]

-- | 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)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `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 }

-- | 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`
                                   (promptList "What does the package build"
                                               [Library, Executable]
                                               Nothing display False))
           ?>> return (Just Library)

  return $ flags { packageType = maybeToFlag isLib }

-- | Ask whether to generate explanitory comments.
getGenComments :: InitFlags -> IO InitFlags
getGenComments flags = do
  genComments <-     return (flagToMaybe $ noComments flags)
                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))
                 ?>> return (Just False)
  return $ flags { noComments = maybeToFlag (fmap not genComments) }
  where
    promptMsg = "Include documentation on what each field means (y/n)"

-- | Try to guess the source root directory (don't prompt the user).
getSrcDir :: InitFlags -> IO InitFlags
getSrcDir flags = do
  srcDirs <-     return (sourceDirs flags)
             ?>> guessSourceDirs

  return $ flags { sourceDirs = srcDirs }

-- XXX
-- | Try to guess source directories.
guessSourceDirs :: IO (Maybe [String])
guessSourceDirs = return Nothing

-- | Get the list of exposed modules and extra tools needed to build them.
getModulesAndBuildTools :: InitFlags -> IO InitFlags
getModulesAndBuildTools flags = do
  dir <- fromMaybe getCurrentDirectory
                   (fmap return . flagToMaybe $ packageDir flags)

  -- XXX really should use guessed source roots.
  sourceFiles <- scanForModules dir

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

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

  return $ flags { exposedModules = mods
                 , buildTools     = tools }

---------------------------------------------------------------------------
--  Prompting/user interaction  -------------------------------------------
---------------------------------------------------------------------------
<commit_msg>init: see whether source directory 'src' exists.<commit_after>{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Init
-- Copyright   :  (c) <NAME> 2009
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- 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

  ) where

import System.IO
  ( hSetBuffering, stdout, BufferMode(..) )
import System.Directory
  ( getCurrentDirectory, doesDirectoryExist )
import System.FilePath
  ( (</>) )
import Data.Time
  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )

import Data.List
  ( intersperse, (\\) )
import Data.Maybe
  ( fromMaybe, isJust )
import Data.Traversable
  ( traverse )
import Control.Monad
  ( when )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
  ( (>=>), join )
#endif

import Text.PrettyPrint hiding (mode, cat)

import Data.Version
  ( Version(..) )
import Distribution.Version
  ( orLaterVersion )

import Distribution.Client.Init.Types
  ( InitFlags(..), PackageType(..), Category(..) )
import Distribution.Client.Init.Licenses
  ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )
import Distribution.Client.Init.Heuristics
  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )

import Distribution.License
  ( License(..), knownLicenses )
import Distribution.ModuleName
  ( ) -- for the Text instance

import Distribution.ReadE
  ( runReadE, readP_to_E )
import Distribution.Simple.Setup
  ( Flag(..), flagToMaybe )
import Distribution.Text
  ( display, Text(..) )

initCabal :: InitFlags -> IO ()
initCabal initFlags = do
  hSetBuffering stdout NoBuffering

  initFlags' <- extendFlags initFlags

  writeLicense initFlags'
  writeSetupFile initFlags'
  success <- writeCabalFile initFlags'

  when success $ generateWarnings initFlags'

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

-- | Fill in more details by guessing, discovering, or prompting the
--   user.
extendFlags :: InitFlags -> IO InitFlags
extendFlags =  getPackageName
           >=> getVersion
           >=> getLicense
           >=> getAuthorInfo
           >=> getHomepage
           >=> getSynopsis
           >=> getCategory
           >=> getLibOrExec
           >=> getGenComments
           >=> getSrcDir
           >=> getModulesAndBuildTools

-- | 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
--   directory by default) as a guess.
getPackageName :: InitFlags -> IO InitFlags
getPackageName flags = do
  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)
              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)

  pkgName' <-     return (flagToMaybe $ packageName flags)
              ?>> maybePrompt flags (promptStr "Package name" guess)
              ?>> return guess

  return $ flags { packageName = maybeToFlag pkgName' }

-- | 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 $ Version { versionBranch = [0,1,0,0], versionTags = [] }
  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) . join)
                  (maybePrompt flags
                    (promptListOptional "Please choose a license" listedLicenses))
  return $ flags { license = maybeToFlag lic }
  where
    listedLicenses =
      knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]

-- | 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)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `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 }

-- | 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`
                                   (promptList "What does the package build"
                                               [Library, Executable]
                                               Nothing display False))
           ?>> return (Just Library)

  return $ flags { packageType = maybeToFlag isLib }

-- | Ask whether to generate explanitory comments.
getGenComments :: InitFlags -> IO InitFlags
getGenComments flags = do
  genComments <-     return (flagToMaybe $ noComments flags)
                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))
                 ?>> return (Just False)
  return $ flags { noComments = maybeToFlag (fmap not genComments) }
  where
    promptMsg = "Include documentation on what each field means (y/n)"

-- | Try to guess the source root directory (don't prompt the user).
getSrcDir :: InitFlags -> IO InitFlags
getSrcDir flags = do
  srcDirs <-     return (sourceDirs flags)
             ?>> Just `fmap` (guessSourceDirs flags)

  return $ flags { sourceDirs = srcDirs }

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

-- | Get the list of exposed modules and extra tools needed to build them.
getModulesAndBuildTools :: InitFlags -> IO InitFlags
getModulesAndBuildTools flags = do
  dir <- fromMaybe getCurrentDirectory
                   (fmap return . flagToMaybe $ packageDir flags)

  -- XXX really should use guessed source roots.
  sourceFiles <- scanForModules dir

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

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

  return $ flags { exposedModules = mods
                 , buildTools     = tools }

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

{'fraction_non_alphanumeric': 0.15265474399688006, 'fraction_numerical': 0.002339963229149256, 'mean_word_length': 2.1474662458355254, 'pattern_counts': {'":': 0, '<': 53, '<?xml version=': 0, '>': 188, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 2, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1677391', 'n_tokens_mistral': 4917, 'n_tokens_neox': 4717, 'n_words': 1613}