cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs

   1 {-# LANGUAGE LambdaCase #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.Init.NonInteractive.Heuristics
   9 -- Copyright   :  (c) Benedikt Huber 2009
  10 -- License     :  BSD-like
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Stability   :  provisional
  14 -- Portability :  portable
  15 --
  16 -- Heuristics for creating initial cabal files.
  17 module Distribution.Client.Init.NonInteractive.Heuristics
  18   ( guessPackageName
  19   , guessMainFile
  20   , guessLicense
  21   , guessExtraDocFiles
  22   , guessAuthorName
  23   , guessAuthorEmail
  24   , guessCabalSpecVersion
  25   , guessLanguage
  26   , guessPackageType
  27   , guessSourceDirectories
  28   , guessApplicationDirectories
  29   ) where
  30
  31 import Distribution.Client.Compat.Prelude hiding (many, readFile, (<|>))
  32
  33 import Distribution.Simple.Setup (fromFlagOrDefault)
  34
  35 import qualified Data.List as L
  36 import qualified Data.Set as Set
  37 import Distribution.CabalSpecVersion
  38 import Distribution.Client.Init.Defaults
  39 import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
  40 import Distribution.Client.Init.Types
  41 import Distribution.Client.Init.Utils
  42 import Distribution.FieldGrammar.Newtypes
  43 import Distribution.Simple.Compiler
  44 import Distribution.Types.PackageName (PackageName)
  45 import Distribution.Version
  46 import Language.Haskell.Extension
  47 import System.FilePath
  48
  49 -- | Guess the main file, returns a default value if none is found.
  50 guessMainFile :: Interactive m => FilePath -> m HsFilePath
  51 guessMainFile pkgDir = do
  52   exists <- doesDirectoryExist pkgDir
  53   if exists
  54     then do
  55       files <- filter isMain <$> listFilesRecursive pkgDir
  56       return $
  57         case files of
  58           [] -> defaultMainIs
  59           (f : _) -> toHsFilePath f
  60     else return defaultMainIs
  61
  62 -- | Juggling characters around to guess the desired cabal version based on
  63 --   the system's cabal version.
  64 guessCabalSpecVersion :: Interactive m => m CabalSpecVersion
  65 guessCabalSpecVersion = do
  66   (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] ""
  67   case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of
  68     Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of
  69       [x, y, _, _] -> cabalSpecFromVersionDigits [x, y]
  70       [x, y, _] -> cabalSpecFromVersionDigits [x, y]
  71       _ -> Just defaultCabalVersion
  72     Nothing -> pure defaultCabalVersion
  73
  74 -- | Guess the language specification based on the GHC version
  75 guessLanguage :: Interactive m => Compiler -> m Language
  76 guessLanguage Compiler{compilerId = CompilerId GHC ver} =
  77   return $
  78     if ver < mkVersion [7, 0, 1]
  79       then Haskell98
  80       else Haskell2010
  81 guessLanguage _ = return defaultLanguage
  82
  83 -- | Guess the package name based on the given root directory.
  84 guessPackageName :: Interactive m => FilePath -> m PackageName
  85 guessPackageName = filePathToPkgName
  86
  87 -- | Try to guess the license from an already existing @LICENSE@ file in
  88 --   the package directory, comparing the file contents with the ones
  89 --   listed in @Licenses.hs@, for now it only returns a default value.
  90 guessLicense :: Interactive m => InitFlags -> m SpecLicense
  91 guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags
  92
  93 guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath))
  94 guessExtraDocFiles flags = do
  95   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
  96   files <- getDirectoryContents pkgDir
  97
  98   let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"]
  99       extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)]
 100
 101   return $
 102     Just $
 103       if null extraDocs
 104         then Set.singleton defaultChangelog
 105         else Set.fromList extraDocs
 106
 107 -- | Try to guess the package type from the files in the package directory,
 108 --   looking for unique characteristics from each type, defaults to Executable.
 109 guessPackageType :: Interactive m => InitFlags -> m PackageType
 110 guessPackageType flags = do
 111   if fromFlagOrDefault False (initializeTestSuite flags)
 112     then return TestSuite
 113     else do
 114       let lastDir dirs = L.last . splitDirectories $ dirs
 115           srcCandidates = [defaultSourceDir, "src", "source"]
 116           testCandidates = [defaultTestDir, "test", "tests"]
 117
 118       pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
 119       files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir
 120       files' <-
 121         filter (not . null . map (`elem` testCandidates) . splitDirectories)
 122           <$> listFilesRecursive pkgDir
 123
 124       let hasExe = not $ null [f | f <- files, isMain $ takeFileName f]
 125           hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates]
 126           hasTest = not $ null [f | f <- files', isMain $ takeFileName f]
 127
 128       return $ case (hasLib, hasExe, hasTest) of
 129         (True, True, _) -> LibraryAndExecutable
 130         (True, False, _) -> Library
 131         (False, False, True) -> TestSuite
 132         _ -> Executable
 133
 134 -- | Try to guess the application directories from the package directory,
 135 --   using a default value as fallback.
 136 guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath]
 137 guessApplicationDirectories flags = do
 138   pkgDirs <-
 139     fromFlagOrDefault
 140       getCurrentDirectory
 141       (return <$> packageDir flags)
 142   pkgDirsContents <- listDirectory pkgDirs
 143
 144   let candidates = [defaultApplicationDir, "app", "src-exe"]
 145    in return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of
 146         [] -> [defaultApplicationDir]
 147         x -> map (</> pkgDirs) . nub $ x
 148
 149 -- | Try to guess the source directories, using a default value as fallback.
 150 guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath]
 151 guessSourceDirectories flags = do
 152   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
 153
 154   doesDirectoryExist (pkgDir </> "src")
 155     >>= return . \case
 156       False -> [defaultSourceDir]
 157       True -> ["src"]
 158
 159 -- | Guess author and email using git configuration options.
 160 guessAuthorName :: Interactive m => m (Maybe String)
 161 guessAuthorName = guessGitInfo "user.name"
 162
 163 guessAuthorEmail :: Interactive m => m (Maybe String)
 164 guessAuthorEmail = guessGitInfo "user.email"
 165
 166 guessGitInfo :: Interactive m => String -> m (Maybe String)
 167 guessGitInfo target = do
 168   localInfo <- maybeReadProcessWithExitCode "git" ["config", "--local", target] ""
 169   case localInfo of
 170     Nothing -> return Nothing
 171     Just (_, localStdout, _) ->
 172       if null localStdout
 173         then do
 174           globalInfo <- maybeReadProcessWithExitCode "git" ["config", "--global", target] ""
 175           case globalInfo of
 176             Just (ExitSuccess, globalStdout, _) -> return $ Just (trim globalStdout)
 177             _ -> return Nothing
 178         else return $ Just (trim localStdout)