{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Init.NonInteractive.Heuristics
-- Copyright   :  (c) Benedikt Huber 2009
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Heuristics for creating initial cabal files.
module Distribution.Client.Init.NonInteractive.Heuristics
  ( guessPackageName
  , guessMainFile
  , guessLicense
  , guessExtraDocFiles
  , guessAuthorName
  , guessAuthorEmail
  , guessCabalSpecVersion
  , guessLanguage
  , guessPackageType
  , guessSourceDirectories
  , guessApplicationDirectories
  ) where

import Distribution.Client.Compat.Prelude hiding (many, readFile, (<|>))

import Distribution.Simple.Setup (fromFlagOrDefault)

import qualified Data.List as L
import qualified Data.Set as Set
import Distribution.CabalSpecVersion
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
import Distribution.Client.Init.Types
import Distribution.Client.Init.Utils
import Distribution.FieldGrammar.Newtypes
import Distribution.Simple.Compiler
import Distribution.Types.PackageName (PackageName)
import Distribution.Version
import Language.Haskell.Extension
import System.FilePath

-- | Guess the main file, returns a default value if none is found.
guessMainFile :: Interactive m => FilePath -> m HsFilePath
guessMainFile :: forall (m :: * -> *). Interactive m => FilePath -> m HsFilePath
guessMainFile FilePath
pkgDir = do
  exists <- FilePath -> m Bool
forall (m :: * -> *). Interactive m => FilePath -> m Bool
doesDirectoryExist FilePath
pkgDir
  if exists
    then do
      files <- filter isMain <$> listFilesRecursive pkgDir
      return $
        case files of
          [] -> HsFilePath
defaultMainIs
          (FilePath
f : [FilePath]
_) -> FilePath -> HsFilePath
toHsFilePath FilePath
f
    else return defaultMainIs

-- | Juggling characters around to guess the desired cabal version based on
--   the system's cabal version.
guessCabalSpecVersion :: Interactive m => m CabalSpecVersion
guessCabalSpecVersion :: forall (m :: * -> *). Interactive m => m CabalSpecVersion
guessCabalSpecVersion = do
  (_, verString, _) <- FilePath
-> [FilePath] -> FilePath -> m (ExitCode, FilePath, FilePath)
forall (m :: * -> *).
Interactive m =>
FilePath
-> [FilePath] -> FilePath -> m (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"cabal" [FilePath
"--version"] FilePath
""
  case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of
    Just Version
v -> CabalSpecVersion -> m CabalSpecVersion
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CabalSpecVersion -> m CabalSpecVersion)
-> CabalSpecVersion -> m CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion -> Maybe CabalSpecVersion -> CabalSpecVersion
forall a. a -> Maybe a -> a
fromMaybe CabalSpecVersion
defaultCabalVersion (Maybe CabalSpecVersion -> CabalSpecVersion)
-> Maybe CabalSpecVersion -> CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ case Version -> [Int]
versionNumbers Version
v of
      [Int
x, Int
y, Int
_, Int
_] -> [Int] -> Maybe CabalSpecVersion
cabalSpecFromVersionDigits [Int
x, Int
y]
      [Int
x, Int
y, Int
_] -> [Int] -> Maybe CabalSpecVersion
cabalSpecFromVersionDigits [Int
x, Int
y]
      [Int]
_ -> CabalSpecVersion -> Maybe CabalSpecVersion
forall a. a -> Maybe a
Just CabalSpecVersion
defaultCabalVersion
    Maybe Version
Nothing -> CabalSpecVersion -> m CabalSpecVersion
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalSpecVersion
defaultCabalVersion

-- | Guess the language specification based on the GHC version
guessLanguage :: Interactive m => Compiler -> m Language
guessLanguage :: forall (m :: * -> *). Interactive m => Compiler -> m Language
guessLanguage Compiler{compilerId :: Compiler -> CompilerId
compilerId = CompilerId CompilerFlavor
GHC Version
ver} =
  Language -> m Language
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Language -> m Language) -> Language -> m Language
forall a b. (a -> b) -> a -> b
$
    if Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
0, Int
1]
      then Language
Haskell98
      else Language
Haskell2010
guessLanguage Compiler
_ = Language -> m Language
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Language
defaultLanguage

-- | Guess the package name based on the given root directory.
guessPackageName :: Interactive m => FilePath -> m PackageName
guessPackageName :: forall (m :: * -> *). Interactive m => FilePath -> m PackageName
guessPackageName = FilePath -> m PackageName
forall (m :: * -> *). Interactive m => FilePath -> m PackageName
filePathToPkgName

-- | Try to guess the license from an already existing @LICENSE@ file in
--   the package directory, comparing the file contents with the ones
--   listed in @Licenses.hs@, for now it only returns a default value.
guessLicense :: Interactive m => InitFlags -> m SpecLicense
guessLicense :: forall (m :: * -> *). Interactive m => InitFlags -> m SpecLicense
guessLicense InitFlags
flags = SpecLicense -> m SpecLicense
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecLicense -> m SpecLicense)
-> (CabalSpecVersion -> SpecLicense)
-> CabalSpecVersion
-> m SpecLicense
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CabalSpecVersion -> SpecLicense
defaultLicense (CabalSpecVersion -> m SpecLicense)
-> CabalSpecVersion -> m SpecLicense
forall a b. (a -> b) -> a -> b
$ InitFlags -> CabalSpecVersion
getCabalVersionNoPrompt InitFlags
flags

guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath))
guessExtraDocFiles :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m (Maybe (Set FilePath))
guessExtraDocFiles InitFlags
flags = do
  pkgDir <- m FilePath -> Flag (m FilePath) -> m FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault m FilePath
forall (m :: * -> *). Interactive m => m FilePath
getCurrentDirectory (Flag (m FilePath) -> m FilePath)
-> Flag (m FilePath) -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> Flag FilePath -> Flag (m FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitFlags -> Flag FilePath
packageDir InitFlags
flags
  files <- getDirectoryContents pkgDir

  let extraDocCandidates = [FilePath
"CHANGES", FilePath
"CHANGELOG", FilePath
"README"]
      extraDocs = [FilePath
y | FilePath
x <- [FilePath]
extraDocCandidates, FilePath
y <- [FilePath]
files, FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (FilePath -> FilePath
takeBaseName FilePath
y)]

  return $
    Just $
      if null extraDocs
        then Set.singleton defaultChangelog
        else Set.fromList extraDocs

-- | Try to guess the package type from the files in the package directory,
--   looking for unique characteristics from each type, defaults to Executable.
guessPackageType :: Interactive m => InitFlags -> m PackageType
guessPackageType :: forall (m :: * -> *). Interactive m => InitFlags -> m PackageType
guessPackageType InitFlags
flags = do
  if Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InitFlags -> Flag Bool
initializeTestSuite InitFlags
flags)
    then PackageType -> m PackageType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageType
TestSuite
    else do
      let lastDir :: FilePath -> FilePath
lastDir FilePath
dirs = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
L.last ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dirs
          srcCandidates :: [FilePath]
srcCandidates = [FilePath
defaultSourceDir, FilePath
"src", FilePath
"source"]
          testCandidates :: [FilePath]
testCandidates = [FilePath
defaultTestDir, FilePath
"test", FilePath
"tests"]

      pkgDir <- m FilePath -> Flag (m FilePath) -> m FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault m FilePath
forall (m :: * -> *). Interactive m => m FilePath
getCurrentDirectory (Flag (m FilePath) -> m FilePath)
-> Flag (m FilePath) -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> Flag FilePath -> Flag (m FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitFlags -> Flag FilePath
packageDir InitFlags
flags
      files <- listFilesInside (\FilePath
x -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
lastDir FilePath
x FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath]
testCandidates) pkgDir
      files' <-
        filter (not . null . map (`elem` testCandidates) . splitDirectories)
          <$> listFilesRecursive pkgDir

      let hasExe = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath
f | FilePath
f <- [FilePath]
files, FilePath -> Bool
isMain (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
f]
          hasLib = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath
f | FilePath
f <- [FilePath]
files, FilePath -> FilePath
lastDir FilePath
f FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
srcCandidates]
          hasTest = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath
f | FilePath
f <- [FilePath]
files', FilePath -> Bool
isMain (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
f]

      return $ case (hasLib, hasExe, hasTest) of
        (Bool
True, Bool
True, Bool
_) -> PackageType
LibraryAndExecutable
        (Bool
True, Bool
False, Bool
_) -> PackageType
Library
        (Bool
False, Bool
False, Bool
True) -> PackageType
TestSuite
        (Bool, Bool, Bool)
_ -> PackageType
Executable

-- | Try to guess the application directories from the package directory,
--   using a default value as fallback.
guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath]
guessApplicationDirectories :: forall (m :: * -> *). Interactive m => InitFlags -> m [FilePath]
guessApplicationDirectories InitFlags
flags = do
  pkgDirs <-
    m FilePath -> Flag (m FilePath) -> m FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault
      m FilePath
forall (m :: * -> *). Interactive m => m FilePath
getCurrentDirectory
      (FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> Flag FilePath -> Flag (m FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitFlags -> Flag FilePath
packageDir InitFlags
flags)
  pkgDirsContents <- listDirectory pkgDirs

  let candidates = [FilePath
defaultApplicationDir, FilePath
"app", FilePath
"src-exe"]
   in return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of
        [] -> [FilePath
defaultApplicationDir]
        [FilePath]
x -> (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
pkgDirs) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
x

-- | Try to guess the source directories, using a default value as fallback.
guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath]
guessSourceDirectories :: forall (m :: * -> *). Interactive m => InitFlags -> m [FilePath]
guessSourceDirectories InitFlags
flags = do
  pkgDir <- m FilePath -> Flag (m FilePath) -> m FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault m FilePath
forall (m :: * -> *). Interactive m => m FilePath
getCurrentDirectory (Flag (m FilePath) -> m FilePath)
-> Flag (m FilePath) -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> Flag FilePath -> Flag (m FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitFlags -> Flag FilePath
packageDir InitFlags
flags

  doesDirectoryExist (pkgDir </> "src")
    >>= return . \case
      Bool
False -> [FilePath
defaultSourceDir]
      Bool
True -> [FilePath
"src"]

-- | Guess author and email using git configuration options.
guessAuthorName :: Interactive m => m (Maybe String)
guessAuthorName :: forall (m :: * -> *). Interactive m => m (Maybe FilePath)
guessAuthorName = FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
Interactive m =>
FilePath -> m (Maybe FilePath)
guessGitInfo FilePath
"user.name"

guessAuthorEmail :: Interactive m => m (Maybe String)
guessAuthorEmail :: forall (m :: * -> *). Interactive m => m (Maybe FilePath)
guessAuthorEmail = FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
Interactive m =>
FilePath -> m (Maybe FilePath)
guessGitInfo FilePath
"user.email"

guessGitInfo :: Interactive m => String -> m (Maybe String)
guessGitInfo :: forall (m :: * -> *).
Interactive m =>
FilePath -> m (Maybe FilePath)
guessGitInfo FilePath
target = do
  localInfo <- FilePath
-> [FilePath] -> FilePath -> m (ExitCode, FilePath, FilePath)
forall (m :: * -> *).
Interactive m =>
FilePath
-> [FilePath] -> FilePath -> m (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"git" [FilePath
"config", FilePath
"--local", FilePath
target] FilePath
""
  if null $ snd' localInfo
    then do
      globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] ""
      case fst' globalInfo of
        ExitCode
ExitSuccess -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> m (Maybe FilePath))
-> Maybe FilePath -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> FilePath
trim (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (ExitCode, FilePath, FilePath) -> FilePath
forall {a} {b} {c}. (a, b, c) -> b
snd' (ExitCode, FilePath, FilePath)
globalInfo)
        ExitCode
_ -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
    else return $ Just (trim $ snd' localInfo)
  where
    fst' :: (a, b, c) -> a
fst' (a
x, b
_, c
_) = a
x
    snd' :: (a, b, c) -> b
snd' (a
_, b
x, c
_) = b
x