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 import Distribution.Utils.Generic (safeLast)
  31
  32 import Distribution.Simple.Setup (fromFlagOrDefault)
  33
  34 import qualified Data.List as L
  35 import Distribution.Client.Init.Defaults
  36 import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
  37 import Distribution.Client.Init.Types
  38 import Distribution.Client.Init.Utils
  39 import System.FilePath
  40 import Distribution.CabalSpecVersion
  41 import Language.Haskell.Extension
  42 import Distribution.Version
  43 import Distribution.Types.PackageName (PackageName, mkPackageName)
  44 import Distribution.Simple.Compiler
  45 import qualified Data.Set as Set
  46 import Distribution.FieldGrammar.Newtypes
  47
  48
  49
  50 -- | Guess the main file, returns a default value if none is found.
  51 guessMainFile :: Interactive m => FilePath -> m HsFilePath
  52 guessMainFile pkgDir = do
  53   exists <- doesDirectoryExist pkgDir
  54   if exists
  55     then do
  56       files  <- filter isMain <$> listFilesRecursive pkgDir
  57       return $ if null files
  58         then defaultMainIs
  59         else toHsFilePath $ L.head files
  60     else
  61       return defaultMainIs
  62
  63 -- | Juggling characters around to guess the desired cabal version based on
  64 --   the system's cabal version.
  65 guessCabalSpecVersion :: Interactive m => m CabalSpecVersion
  66 guessCabalSpecVersion = do
  67   (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] ""
  68   case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of
  69     Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of
  70       [x,y,_,_] -> cabalSpecFromVersionDigits [x,y]
  71       [x,y,_] -> cabalSpecFromVersionDigits [x,y]
  72       _ -> Just defaultCabalVersion
  73     Nothing -> pure defaultCabalVersion
  74
  75 -- | Guess the language specification based on the GHC version
  76 guessLanguage :: Interactive m => Compiler -> m Language
  77 guessLanguage Compiler {compilerId = CompilerId GHC ver} =
  78     return $ 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 = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
  86                  . canonicalizePathNoThrow
  87   where
  88     -- Treat each span of non-alphanumeric characters as a hyphen. Each
  89     -- hyphenated component of a package name must contain at least one
  90     -- alphabetic character. An arbitrary character ('x') will be prepended if
  91     -- this is not the case for the first component, and subsequent components
  92     -- will simply be run together. For example, "1+2_foo-3" will become
  93     -- "x12-foo3".
  94     repair = repair' ('x' :) id
  95     repair' invalid valid x = case dropWhile (not . isAlphaNum) x of
  96         "" -> repairComponent ""
  97         x' -> let (c, r) = first repairComponent $ span isAlphaNum x'
  98               in c ++ repairRest r
  99       where
 100         repairComponent c | all isDigit c = invalid c
 101                           | otherwise     = valid c
 102     repairRest = repair' id ('-' :)
 103
 104 -- | Try to guess the license from an already existing @LICENSE@ file in
 105 --   the package directory, comparing the file contents with the ones
 106 --   listed in @Licenses.hs@, for now it only returns a default value.
 107 guessLicense :: Interactive m => InitFlags -> m SpecLicense
 108 guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags
 109
 110 guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath))
 111 guessExtraDocFiles flags = do
 112   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
 113   files  <- getDirectoryContents pkgDir
 114
 115   let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"]
 116       extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)]
 117
 118   return $ Just $ if null extraDocs
 119     then Set.singleton defaultChangelog
 120     else Set.fromList extraDocs
 121
 122 -- | Try to guess the package type from the files in the package directory,
 123 --   looking for unique characteristics from each type, defaults to Executable.
 124 guessPackageType :: Interactive m => InitFlags -> m PackageType
 125 guessPackageType flags = do
 126   if fromFlagOrDefault False (initializeTestSuite flags)
 127     then
 128       return TestSuite
 129     else do
 130       let lastDir dirs   = L.last . splitDirectories $ dirs
 131           srcCandidates  = [defaultSourceDir, "src", "source"]
 132           testCandidates = [defaultTestDir, "test", "tests"]
 133
 134       pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
 135       files  <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir
 136       files' <- filter (not . null . map (`elem` testCandidates) . splitDirectories) <$>
 137         listFilesRecursive pkgDir
 138
 139       let hasExe   = not $ null [f | f <- files,  isMain $ takeFileName f]
 140           hasLib   = not $ null [f | f <- files,  lastDir f `elem` srcCandidates]
 141           hasTest  = not $ null [f | f <- files', isMain $ takeFileName f]
 142
 143       return $ case (hasLib, hasExe, hasTest) of
 144         (True , True , _   ) -> LibraryAndExecutable
 145         (True , False, _   ) -> Library
 146         (False, False, True) -> TestSuite
 147         _                    -> Executable
 148
 149 -- | Try to guess the application directories from the package directory,
 150 --   using a default value as fallback.
 151 guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath]
 152 guessApplicationDirectories flags = do
 153   pkgDirs <- fromFlagOrDefault getCurrentDirectory
 154                 (return <$> packageDir flags)
 155   pkgDirsContents <- listDirectory pkgDirs
 156
 157   let candidates = [defaultApplicationDir, "app", "src-exe"] in
 158     return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of
 159       [] -> [defaultApplicationDir]
 160       x  -> map (</> pkgDirs) . nub $ x
 161
 162 -- | Try to guess the source directories, using a default value as fallback.
 163 guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath]
 164 guessSourceDirectories flags = do
 165   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
 166
 167   doesDirectoryExist (pkgDir </> "src") >>= return . \case
 168     False -> [defaultSourceDir]
 169     True  -> ["src"]
 170
 171 -- | Guess author and email using git configuration options.
 172 guessAuthorName :: Interactive m => m String
 173 guessAuthorName = guessGitInfo "user.name"
 174
 175 guessAuthorEmail :: Interactive m => m String
 176 guessAuthorEmail = guessGitInfo "user.email"
 177
 178 guessGitInfo :: Interactive m => String -> m String
 179 guessGitInfo target = do
 180   info <- readProcessWithExitCode "git" ["config", "--local", target] ""
 181   if null $ snd' info
 182     then trim . snd' <$> readProcessWithExitCode "git" ["config", "--global", target] ""
 183     else return . trim $ snd' info
 184
 185   where
 186     snd' (_, x, _) = x