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

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