From 381766efcdddb4c8706408a90c515470a6aa43a7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Nov 2016 21:29:54 -0400 Subject: 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. --- CmdLine/Action.hs | 2 +- CmdLine/Batch.hs | 2 +- CmdLine/GitAnnexShell.hs | 8 ++++---- CmdLine/GitAnnexShell/Checks.hs | 6 +++--- CmdLine/Seek.hs | 16 ++++++++-------- 5 files changed, 17 insertions(+), 17 deletions(-) (limited to 'CmdLine') diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 7d9dce574..27621e445 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -38,7 +38,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do showerrcount =<< Annex.getState Annex.errcounter where showerrcount 0 = noop - showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed" + showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed" {- Runs one of the actions needed to perform a command. - Individual actions can fail without stopping the whole command, diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index cca93b0b3..627c1df10 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -56,7 +56,7 @@ batchInput parser a = do either parseerr a (parser v) batchInput parser a where - parseerr s = error $ "Batch input parse failure: " ++ s + parseerr s = giveup $ "Batch input parse failure: " ++ s -- Runs a CommandStart in batch mode. -- diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 599d12fec..70c86ec2f 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -71,7 +71,7 @@ globalOptions = check Nothing = unexpected expected "uninitialized repository" check (Just u) = unexpectedUUID expected u unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u - unexpected expected s = error $ + unexpected expected s = giveup $ "expected repository UUID " ++ expected ++ " but found " ++ s run :: [String] -> IO () @@ -109,7 +109,7 @@ builtin cmd dir params = do Git.Config.read r `catchIO` \_ -> do hn <- fromMaybe "unknown" <$> getHostname - error $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved" + giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved" external :: [String] -> IO () external params = do @@ -120,7 +120,7 @@ external params = do checkDirectory lastparam checkNotLimited unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $ - error "git-shell failed" + giveup "git-shell failed" {- Split the input list into 3 groups separated with a double dash --. - Parameters between two -- markers are field settings, in the form: @@ -150,6 +150,6 @@ checkField (field, val) | otherwise = False failure :: IO () -failure = error $ "bad parameters\n\n" ++ usage h cmds +failure = giveup $ "bad parameters\n\n" ++ usage h cmds where h = "git-annex-shell [-c] command [parameters ...] [option ...]" diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs index 63d2e594f..47bc11a76 100644 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -26,7 +26,7 @@ checkEnv var = do case v of Nothing -> noop Just "" -> noop - Just _ -> error $ "Action blocked by " ++ var + Just _ -> giveup $ "Action blocked by " ++ var checkDirectory :: Maybe FilePath -> IO () checkDirectory mdir = do @@ -44,7 +44,7 @@ checkDirectory mdir = do then noop else req d' (Just dir') where - req d mdir' = error $ unwords + req d mdir' = giveup $ unwords [ "Only allowed to access" , d , maybe "and could not determine directory from command line" ("not " ++) mdir' @@ -64,4 +64,4 @@ gitAnnexShellCheck :: Command -> Command gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists where okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ - error "Not a git-annex or gcrypt repository." + giveup "Not a git-annex or gcrypt repository." diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 5d20ad0db..7fc64c528 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -40,7 +40,7 @@ withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force) ( withFilesInGit a params , if null params - then error needforce + then giveup needforce else seekActions $ prepFiltered a (getfiles [] params) ) where @@ -54,7 +54,7 @@ withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force) [] -> do void $ liftIO $ cleanup getfiles c ps - _ -> error needforce + _ -> giveup needforce withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesNotInGit skipdotfiles a params @@ -117,7 +117,7 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs - pairs _ _ = error "expected pairs" + pairs _ _ = giveup "expected pairs" withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesToBeCommitted a params = seekActions $ prepFiltered a $ @@ -152,11 +152,11 @@ withFilesMaybeModified a params = seekActions $ withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek withKeys a params = seekActions $ return $ map (a . parse) params where - parse p = fromMaybe (error "bad key") $ file2key p + parse p = fromMaybe (giveup "bad key") $ file2key p withNothing :: CommandStart -> CmdParams -> CommandSeek withNothing a [] = seekActions $ return [a] -withNothing _ _ = error "This command takes no parameters." +withNothing _ _ = giveup "This command takes no parameters." {- Handles the --all, --branch, --unused, --failed, --key, and - --incomplete options, which specify particular keys to run an @@ -191,7 +191,7 @@ withKeyOptions' withKeyOptions' ko auto mkkeyaction fallbackaction params = do bare <- fromRepo Git.repoIsLocalBare when (auto && bare) $ - error "Cannot use --auto in a bare repository" + giveup "Cannot use --auto in a bare repository" case (null params, ko) of (True, Nothing) | bare -> noauto $ runkeyaction loggedKeys @@ -203,10 +203,10 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k]) (True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys (True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs - (False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" + (False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" where noauto a - | auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" + | auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" | otherwise = a incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True runkeyaction getks = do -- cgit v1.2.3