Avoid backtraces on expected failures when built with ghc 8; only use backtraces for unexpected errors.

ghc 8 added backtraces on uncaught errors. This is great, but git-annex was
using error in many places for a error message targeted at the user, in
some known problem case. A backtrace only confuses such a message, so omit it.

Notably, commands like git annex drop that failed due to eg, numcopies,
used to use error, so had a backtrace.

This commit was sponsored by Ethan Aubin.

9 files changed, 26 insertions, 11 deletions

diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 3cc2eb261..5c0ea4169 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -111,7 +111,7 @@ lockPidFile pidfile = do
 #endif
 
 alreadyRunning :: IO ()
-alreadyRunning = error "Daemon is already running."
+alreadyRunning = giveup "Daemon is already running."
 
 {- Checks if the daemon is running, by checking that the pid file
  - is locked by the same process that is listed in the pid file.
@@ -135,7 +135,7 @@ checkDaemon pidfile = bracket setup cleanup go
 	check _ Nothing = Nothing
 	check (Just (pid, _)) (Just pid')
 		| pid == pid' = Just pid
-		| otherwise = error $
+		| otherwise = giveup $
 			"stale pid in " ++ pidfile ++ 
 			" (got " ++ show pid' ++ 
 			"; expected " ++ show pid ++ " )"
diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs
index a07139c44..d7472d490 100644
--- a/Utility/DirWatcher/FSEvents.hs
+++ b/Utility/DirWatcher/FSEvents.hs
@@ -17,7 +17,7 @@ import Data.Bits ((.&.))
 watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO EventStream
 watchDir dir ignored scanevents hooks = do
 	unlessM fileLevelEventsSupported $
-		error "Need at least OSX 10.7.0 for file-level FSEvents"
+		giveup "Need at least OSX 10.7.0 for file-level FSEvents"
 	scan dir
 	eventStreamCreate [dir] 1.0 True True True dispatch
   where
diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs
index 4d11b95a8..1890b8af5 100644
--- a/Utility/DirWatcher/INotify.hs
+++ b/Utility/DirWatcher/INotify.hs
@@ -152,7 +152,7 @@ watchDir i dir ignored scanevents hooks
 		-- disk full error.
 		| isFullError e =
 			case errHook hooks of
-				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+				Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
 				Just hook -> tooManyWatches hook dir
 		-- The directory could have been deleted.
 		| isDoesNotExistError e = return ()
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 0ffc7103f..5cd8fd199 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,6 +1,6 @@
 {- Simple IO exception handling (and some more)
  -
- - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -10,6 +10,7 @@
 
 module Utility.Exception (
 	module X,
+	giveup,
 	catchBoolIO,
 	catchMaybeIO,
 	catchDefaultIO,
@@ -40,6 +41,17 @@ import GHC.IO.Exception (IOErrorType(..))
 
 import Utility.Data
 
+{- Like error, this throws an exception. Unlike error, if this exception
+ - is not caught, it won't generate a backtrace. So use this for situations
+ - where there's a problem that the user is excpected to see in some
+ - circumstances. -}
+giveup :: [Char] -> a
+#if MIN_VERSION_base(4,9,0)
+giveup = errorWithoutStackTrace
+#else
+giveup = error
+#endif
+
 {- Catches IO errors and returns a Bool -}
 catchBoolIO :: MonadCatch m => m Bool -> m Bool
 catchBoolIO = catchDefaultIO False
diff --git a/Utility/Glob.hs b/Utility/Glob.hs
index 98ffe751b..119ea4834 100644
--- a/Utility/Glob.hs
+++ b/Utility/Glob.hs
@@ -12,6 +12,8 @@ module Utility.Glob (
 	matchGlob
 ) where
 
+import Utility.Exception
+
 import System.Path.WildMatch
 
 import "regex-tdfa" Text.Regex.TDFA
@@ -26,7 +28,7 @@ compileGlob :: String -> GlobCase -> Glob
 compileGlob glob globcase = Glob $
 	case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of
 		Right r -> r
-		Left _ -> error $ "failed to compile regex: " ++ regex
+		Left _ -> giveup $ "failed to compile regex: " ++ regex
   where
 	regex = '^':wildToRegex glob
 	casesentitive = case globcase of
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 21171b6fb..118515222 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -253,7 +253,7 @@ genRandom cmd highQuality size = checksize <$> readStrict cmd params
 			then s
 			else shortread len
 
-	shortread got = error $ unwords
+	shortread got = giveup $ unwords
 		[ "Not enough bytes returned from gpg", show params
 		, "(got", show got, "; expected", show expectedlength, ")"
 		]
diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index 6a3e86a3f..bc8ddfe6b 100644
--- a/Utility/LockFile/PidLock.hs
+++ b/Utility/LockFile/PidLock.hs
@@ -210,7 +210,7 @@ waitLock (Seconds timeout) lockfile = go timeout
 			=<< tryLock lockfile
 		| otherwise = do
 			hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
-			error $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
+			giveup $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
 
 dropLock :: LockHandle -> IO ()
 dropLock (LockHandle lockfile _ sidelock) = do
diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs
index 09f74968b..417ab7041 100644
--- a/Utility/Quvi.hs
+++ b/Utility/Quvi.hs
@@ -79,8 +79,8 @@ forceQuery :: Query (Maybe Page)
 forceQuery v ps url = query' v ps url `catchNonAsync` onerr
   where
 	onerr e = ifM (inPath "quvi")
-		( error ("quvi failed: " ++ show e)
-		, error "quvi is not installed"
+		( giveup ("quvi failed: " ++ show e)
+		, giveup "quvi is not installed"
 		)
 
 {- Returns Nothing if the page is not a video page, or quvi is not
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index ec0b0d0b2..dd66c331e 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -16,6 +16,7 @@ module Utility.UserInfo (
 
 import Utility.Env
 import Utility.Data
+import Utility.Exception
 
 import System.PosixCompat
 import Control.Applicative
@@ -25,7 +26,7 @@ import Prelude
  -
  - getpwent will fail on LDAP or NIS, so use HOME if set. -}
 myHomeDir :: IO FilePath
-myHomeDir = either error return =<< myVal env homeDirectory
+myHomeDir = either giveup return =<< myVal env homeDirectory
   where
 #ifndef mingw32_HOST_OS
 	env = ["HOME"]