Reorder 'cabal init' author heuristics.

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

@@ -31,7 +31,7 @@ import Distribution.Simple.Utils
 
 import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )
 import Control.Applicative ( pure, (<$>), (<*>) )
-import Control.Monad (liftM )
+import Control.Monad ( liftM, join )
 import Data.Char   ( isUpper, isLower, isSpace )
 import Data.Either ( partitionEithers )
 import Data.List   ( isPrefixOf )
@@ -156,44 +156,39 @@ neededBuildPrograms entries =
 -- | Guess author and email using darcs and git configuration options. Use
 -- the following in decreasing order of preference:
 --
--- 1. darcs env vars ($DARCS_EMAIL or $EMAIL)
--- 2. darcs local prefs (./_darcs/prefs/author)
--- 3. darcs global prefs (~/.darcs/author)
--- 4. git env vars ($GIT_AUTHOR_{NAME,EMAIL})
--- 5. git local prefs
--- 6. git global prefs
+-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)
+-- 2. Local repo configs
+-- 3. Global vcs configs
+-- 4. The generic $EMAIL
 --
--- The last two are checked simultaneously with a call to `git config`.
+-- Name and email are processed separately, so the guess might end up being
+-- a name from DARCS_EMAIL and an email from git config.
+--
+-- Darcs has preference, for tradition's sake.
 guessAuthorNameMail :: IO (Flag String, Flag String)
 guessAuthorNameMail = fmap mconcat $ sequence
-  [ gitConfigAuthorNameMail
-  , gitEnvAuthorNameMail
-  , guessAuthorNameMailDarcs
-  ]
+    [ emailEnv
+    , gitCfg Global
+    , darcsGlobal
+    , gitCfg Local
+    , darcsRepo
+    , gitEnv
+    , darcsEnv
+    ]
+
+-- Types and functions used for guessing the author are now defined:
 
--- | Look up darcs prefs
-guessAuthorNameMailDarcs :: IO (Flag String, Flag String)
-guessAuthorNameMailDarcs =
-  update (readFromFile authorRepoFile) mempty >>=
-  update (getAuthorHome >>= readFromFile) >>=
-  update readFromEnvironment
+type AuthorGuess   = (Flag String, Flag String)
+data GitLoc        = Local | Global
+
+
+darcsEnv :: IO AuthorGuess
+darcsEnv = fmap extractDarcs getEnvironment
   where
-    update _ info@(Flag _, Flag _) = return info
-    update extract info = liftM (`mappend` info) extract -- prefer info
-    readFromFile file = do
-      exists <- doesFileExist file
-      if exists then liftM nameAndMail (readFile file) else return mempty
-    readFromEnvironment = fmap extractFromEnvironment getEnvironment
-    extractFromEnvironment env =
-        let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env)
-            emailEnv      = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env)
-        in darcsEmailEnv `mappend` emailEnv
-    getAuthorHome   = liftM (</> (".darcs" </> "author")) getHomeDirectory
-    authorRepoFile  = "_darcs" </> "prefs" </> "author"
+    extractDarcs = maybe mempty nameAndMail . lookup "DARCS_EMAIL"
 
--- | Find author name and email from git env vars.
-gitEnvAuthorNameMail :: IO (Flag String, Flag String)
-gitEnvAuthorNameMail = do
+gitEnv :: IO AuthorGuess
+gitEnv = do
     env <- getEnvironment
     let name  = toFlag "GIT_AUTHOR_NAME" env
         email = toFlag "GIT_AUTHOR_EMAIL" env
@@ -201,25 +196,47 @@ gitEnvAuthorNameMail = do
   where
     toFlag k ls = maybe mempty Flag $ lookup k ls
 
--- | Find author name and email from 'git config'.
-gitConfigAuthorNameMail :: IO (Flag String, Flag String)
-gitConfigAuthorNameMail = do
-  name <- gitConfigVar "user.name"
-  mail <- gitConfigVar "user.email"
+darcsRepo :: IO AuthorGuess
+darcsRepo = readFromFile authorRepoFile
+  where
+    authorRepoFile  = "_darcs" </> "prefs" </> "author"
+
+darcsGlobal = join . fmap readFromFile $ globalCfg
+  where
+    globalCfg = fmap (</> ".darcs" </> "author") getHomeDirectory
+
+readFromFile file = do
+  exists <- doesFileExist file
+  if exists then liftM nameAndMail (readFile file) else return mempty
+
+emailEnv :: IO AuthorGuess
+emailEnv = fmap ((,) mempty) email
+  where
+    email = maybe mempty Flag
+          <$> lookup "EMAIL"
+          <$> getEnvironment
+
+gitCfg which = do
+  name <- gitVar which "user.name"
+  mail <- gitVar which "user.email"
   return (name, mail)
 
--- | Given a config parameter, attempt to pull it from git config files
--- (repo-local and user-global files are both attempted), then clean it up.
-gitConfigVar :: String -> IO (Flag String)
-gitConfigVar = (fmap . fmap) trim . fmap happyOutput . gitConfigQuery
+gitVar :: GitLoc -> String -> IO (Flag String)
+gitVar which = fmap happyOutput . gitConfigQuery which
 
 happyOutput :: (ExitCode, a, t) -> Flag a
 happyOutput v = case v of
   (ExitSuccess, s, _) -> Flag s
-  _                   -> NoFlag
+  _                   -> mempty
 
-gitConfigQuery :: String -> IO (ExitCode, String, String)
-gitConfigQuery key = readProcessWithExitCode "git" ["config", "--get", key] ""
+gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)
+gitConfigQuery which key =
+    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""
+  where
+    w = case which of
+        Local  -> "--local"
+        Global -> "--global"
+    trim' (a, b, c) = (a, trim b, c)
 
 -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached
 knownCategories :: SourcePackageDb -> [String]