From f4eba96b198baf4499ca6ccd7242d9daa41337ac Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 28 Mar 2001 11:01:19 +0000 Subject: [PATCH] [project @ 2001-03-28 11:01:19 by simonmar] Clean up GHC's error reporting. - the GhcException type has some more constructors: CmdLineError, UserError, and InstallationError. OtherError has gone. - most error messages should begin with ":". When the error is on the command-line or in GHC itself, is "ghc", for consistency with std Unix semantics. - GHCi no longer prints a superfluous "ghc: " before certain error messages. --- ghc/compiler/compMan/CmLink.lhs | 3 +-- ghc/compiler/compMan/CompManager.lhs | 25 ++++++++++++------------- ghc/compiler/ghci/InteractiveUI.hs | 26 +++++++++++++------------- ghc/compiler/main/DriverFlags.hs | 6 +++--- ghc/compiler/main/DriverMkDepend.hs | 11 +++++------ ghc/compiler/main/DriverPipeline.hs | 20 ++++++++++---------- ghc/compiler/main/DriverState.hs | 6 +++--- ghc/compiler/main/Main.hs | 19 ++++++++++++------- 8 files changed, 59 insertions(+), 57 deletions(-) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index a059ea7..297b0a6 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -260,8 +260,7 @@ linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls linkInterpretedCode ls (uls++ul_trees) pls{objects_loaded = l : objects_loaded pls} | any isObject uls - = throwDyn (OtherError - "can't link object code that depends on interpreted code") + = panic "linkInterpretedCode: trying to link object code to interpreted code") | otherwise = invalidLinkable invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code" diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 28630ec..bf8d0cf 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -149,7 +149,7 @@ cmSetContext cmstate str Nothing -> do mod <- moduleNameToModule mn if isHomeModule mod - then throwDyn (OtherError (showSDoc + then throwDyn (UserError (showSDoc (quotes (ppr (moduleName mod)) <+> text "is not currently loaded"))) else return mod @@ -163,7 +163,7 @@ moduleNameToModule :: ModuleName -> IO Module moduleNameToModule mn = do maybe_stuff <- findModule mn case maybe_stuff of - Nothing -> throwDyn (OtherError ("can't find module `" + Nothing -> throwDyn (UserError ("can't find module `" ++ moduleNameUserString mn ++ "'")) Just (m,_) -> return m @@ -955,7 +955,7 @@ downsweep rootNm old_summaries | haskellish_file file = do exists <- doesFileExist file if exists then summariseFile file else do - throwDyn (OtherError ("can't find file `" ++ file ++ "'")) + throwDyn (UserError ("can't find file `" ++ file ++ "'")) | otherwise = do exists <- doesFileExist hs_file if exists then summariseFile hs_file else do @@ -978,7 +978,7 @@ downsweep rootNm old_summaries let old_summary = findModInSummaries old_summaries mod summarise mod location old_summary - Nothing -> throwDyn (OtherError + Nothing -> throwDyn (UserError ("can't find module `" ++ showSDoc (ppr nm) ++ "'")) @@ -1055,10 +1055,10 @@ summarise mod location old_summary let (srcimps,imps,mod_name) = getImports modsrc when (mod_name /= moduleName mod) $ - throwDyn (OtherError - (showSDoc (text "file name does not match module name: " - <+> ppr (moduleName mod) <+> text "vs" - <+> ppr mod_name))) + throwDyn (UserError + (showSDoc (text modsrc + <> text ": file name does not match module name" + <+> quotes (ppr (moduleName mod))))) return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} srcimps imps src_timestamp)) @@ -1067,11 +1067,10 @@ summarise mod location old_summary | otherwise = return Nothing noHsFileErr mod - = throwDyn (OtherError (showSDoc (text "no source file for module" - <+> quotes (ppr mod)))) + = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod))) packageModErr mod - = throwDyn (OtherError (showSDoc (text "module" <+> - quotes (ppr mod) <+> - text "is a package module"))) + = throwDyn (UserError (showSDoc (text "module" <+> + quotes (ppr mod) <+> + text "is a package module"))) \end{code} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index cd531b2..dc75318 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.58 2001/03/27 16:55:03 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.59 2001/03/28 11:01:19 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -301,7 +301,7 @@ specialCommand str = do foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")") >> return False) -noArgs c = throwDyn (OtherError ("command `" ++ c ++ "' takes no arguments")) +noArgs c = throwDyn (UserError ("command `" ++ c ++ "' takes no arguments")) ----------------------------------------------------------------------------- -- Commands @@ -310,13 +310,13 @@ help :: String -> GHCi () help _ = io (putStr helpText) addModule :: String -> GHCi () -addModule _ = throwDyn (OtherError ":add not implemented") +addModule _ = throwDyn (InstallationError ":add not implemented") setContext :: String -> GHCi () setContext "" - = throwDyn (OtherError "syntax: `:m '") + = throwDyn (UserError "syntax: `:m '") setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m)) - = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'")) + = throwDyn (UserError ("strange looking module name: `" ++ m ++ "'")) setContext str = do st <- getGHCiState new_cmstate <- io (cmSetContext (cmstate st) str) @@ -333,10 +333,10 @@ defineMacro s = do let (macro_name, definition) = break isSpace s cmds <- io (readIORef commands) if (null macro_name) - then throwDyn (OtherError "invalid macro name") + then throwDyn (UserError "invalid macro name") else do if (macro_name `elem` map fst cmds) - then throwDyn (OtherError + then throwDyn (UserError ("command `" ++ macro_name ++ "' is already defined")) else do @@ -363,11 +363,11 @@ undefineMacro :: String -> GHCi () undefineMacro macro_name = do cmds <- io (readIORef commands) if (macro_name `elem` map fst builtin_commands) - then throwDyn (OtherError + then throwDyn (UserError ("command `" ++ macro_name ++ "' cannot be undefined")) else do if (macro_name `notElem` map fst cmds) - then throwDyn (OtherError + then throwDyn (UserError ("command `" ++ macro_name ++ "' not defined")) else do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) @@ -472,7 +472,7 @@ setOptions str writeIORef v_InitDynFlags dyn_flags if (not (null leftovers)) - then throwDyn (OtherError ("unrecognised flags: " ++ + then throwDyn (UserError ("unrecognised flags: " ++ unwords leftovers)) else return () ) @@ -492,7 +492,7 @@ unsetOptions str -- can't do GHC flags for now if (not (null minus_opts)) - then throwDyn (OtherError "can't unset GHC command-line flags") + then throwDyn (UserError "can't unset GHC command-line flags") else return () isMinus ('-':s) = True @@ -620,7 +620,7 @@ linkPackages cmdline_lib_specs pkgs putStr ("failed (" ++ str ++ ")\n") croak - croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.") + croak = throwDyn (UserError "user specified .o/.so/.DLL could not be loaded.") linkPackage :: PackageConfig -> IO () @@ -653,7 +653,7 @@ loadClassified (Right dll_unadorned) if maybe_errmsg == nullPtr then return () else do str <- peekCString maybe_errmsg - throwDyn (OtherError ("can't find .o or .so/.DLL for: " + throwDyn (UserError ("can't find .o or .so/.DLL for: " ++ dll_unadorned ++ " (" ++ str ++ ")" )) locateOneObj :: [FilePath] -> String -> IO LibrarySpec diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index b128364..dd09900 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.50 2001/03/27 16:55:03 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.51 2001/03/28 11:01:19 simonmar Exp $ -- -- Driver flags -- @@ -352,7 +352,7 @@ setVerbosityAtLeast n = setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) setVerbosity n | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) - | otherwise = throwDyn (OtherError "can't parse verbosity flag (-v)") + | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v)") getVerbFlag = do verb <- dynFlag verbosity @@ -483,7 +483,7 @@ decodeSize str | c == "K" || c == "k" = truncate (n * 1000) | c == "M" || c == "m" = truncate (n * 1000 * 1000) | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwDyn (OtherError ("can't decode size: " ++ str)) + | otherwise = throwDyn (CmdLineError ("can't decode size: " ++ str)) where (m, c) = span pred str n = read m :: Double pred c = isDigit c || c == '.' diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index e22a1da..3e78934 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.7 2000/12/12 14:35:08 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.8 2001/03/28 11:01:19 simonmar Exp $ -- -- GHC Driver -- @@ -164,8 +164,8 @@ endMkDependHS = do (unwords [ "cp", tmp_file, makefile ]) -findDependency :: Bool -> String -> ModuleName -> IO (Maybe (String, Bool)) -findDependency is_source mod imp = do +findDependency :: Bool -> FilePath -> ModuleName -> IO (Maybe (String, Bool)) +findDependency is_source src imp = do dir_contents <- readIORef v_Dep_dir_contents ignore_dirs <- readIORef v_Dep_ignore_dirs hisuf <- readIORef v_Hi_suf @@ -181,9 +181,8 @@ findDependency is_source mod imp = do deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ] | otherwise = [ imp_hi, imp_hs, imp_lhs ] - search [] = throwDyn (OtherError ("can't find one of the following: " ++ - unwords (map (\d -> '`': d ++ "'") deps) ++ - " (imported from `" ++ mod ++ "')")) + search [] = throwDyn (UserError (src ++ ": " ++ "can't find one of the following: " ++ + unwords (map (\d -> '`': d ++ "'") deps))) search ((dir, contents) : dirs) | null present = search dirs | otherwise = diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 04392a1..1e4705f 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.60 2001/03/27 16:32:46 rrt Exp $ +-- $Id: DriverPipeline.hs,v 1.61 2001/03/28 11:01:19 simonmar Exp $ -- -- GHC Driver -- @@ -94,7 +94,7 @@ getGhcMode flags ([] , rest) -> return (rest, DoLink, "") -- default is to do linking ([(flag,one)], rest) -> return (rest, one, flag) (_ , _ ) -> - throwDyn (OtherError + throwDyn (UsageError "only one of the flags -M, -E, -C, -S, -c, --make, --interactive, -mk-dll is allowed") ----------------------------------------------------------------------------- @@ -199,13 +199,13 @@ genPipeline todo stop_flag persistent_output lang filename -- ToDo: this is somewhat cryptic - not_valid = throwDyn (OtherError ("invalid option combination")) + not_valid = throwDyn (UsageError ("invalid option combination")) ----------- ----- ---- --- -- -- - - - -- this shouldn't happen. if start_phase /= Ln && start_phase `notElem` pipeline - then throwDyn (OtherError ("can't find starting phase for " - ++ filename)) + then throwDyn (CmdLineError ("can't find starting phase for " + ++ filename)) else do let @@ -256,7 +256,7 @@ genPipeline todo stop_flag persistent_output lang filename -- is already in linkable form (for example). if start_phase `elem` pipeline && (stop_phase /= Ln && stop_phase `notElem` pipeline) - then throwDyn (OtherError + then throwDyn (UsageError ("flag " ++ stop_flag ++ " is incompatible with source file `" ++ filename ++ "'")) else do @@ -366,8 +366,8 @@ run_phase MkDependHS basename suff input_fn _output_fn = do src <- readFile input_fn let (import_sources, import_normals, module_name) = getImports src - deps_sources <- mapM (findDependency True basename) import_sources - deps_normals <- mapM (findDependency False basename) import_normals + deps_sources <- mapM (findDependency True src) import_sources + deps_normals <- mapM (findDependency False src) import_normals let deps = deps_sources ++ deps_normals osuf_opt <- readIORef v_Object_suf @@ -762,7 +762,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ -- Complain about non-dynamic flags in OPTIONS pragmas checkProcessArgsResult flags basename suff - = do when (not (null flags)) (throwDyn (OtherError ( + = do when (not (null flags)) (throwDyn (UserError ( basename ++ "." ++ suff ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t" ++ unwords flags)) (ExitFailure 1)) @@ -838,7 +838,7 @@ doLink o_files = do when (WayPar `elem` ways_) (do success <- run_phase_MoveBinary output_fn if success then return () - else throwDyn (OtherError ("cannot move binary to PVM dir"))) + else throwDyn (InstallationError ("cannot move binary to PVM dir"))) ----------------------------------------------------------------------------- -- Making a DLL diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 8aadde5..522330e 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.36 2001/03/27 10:33:03 simonmar Exp $ +-- $Id: DriverState.hs,v 1.37 2001/03/28 11:01:19 simonmar Exp $ -- -- Settings for the driver -- @@ -336,7 +336,7 @@ addPackage :: String -> IO () addPackage package = do pkg_details <- readIORef v_Package_details case lookupPkg package pkg_details of - Nothing -> throwDyn (OtherError ("unknown package name: " ++ package)) + Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package)) Just details -> do ps <- readIORef v_Packages unless (package `elem` ps) $ do @@ -470,7 +470,7 @@ findBuildTag = do return (wayOpts details) ws -> if not (allowed_combination ws) - then throwDyn (OtherError $ + then throwDyn (CmdLineError $ "combination not supported: " ++ foldr1 (\a b -> a ++ '/':b) (map (wayName . lkupWay) ws)) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 88ddba7..6bbded7 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.61 2001/03/27 10:33:24 simonmar Exp $ +-- $Id: Main.hs,v 1.62 2001/03/28 11:01:19 simonmar Exp $ -- -- GHC Driver program -- @@ -139,7 +139,9 @@ main = else do am_inplace <- doesFileExist inplace_pkgconfig if am_inplace then writeIORef v_Path_package_config inplace_pkgconfig - else throwDyn (OtherError ("Can't find package.conf in " ++ inplace_pkgconfig)) + else throwDyn (InstallationError + ("Can't find package.conf in " ++ + inplace_pkgconfig)) -- set the location of our various files if am_installed @@ -157,7 +159,7 @@ main = conf_file <- readIORef v_Path_package_config r <- parsePkgConf conf_file case r of { - Left err -> throwDyn (OtherError (showSDoc err)); + Left err -> throwDyn (InstallationError (showSDoc err)); Right pkg_details -> do writeIORef v_Package_details pkg_details @@ -183,7 +185,7 @@ main = writeIORef v_OptLevel 0 orig_ways <- readIORef v_Ways when (not (null orig_ways) && mode == DoInteractive) $ - do throwDyn (OtherError + do throwDyn (UsageError "--interactive can't be used with -prof, -ticky, -unreg or -smp.") -- Find the build tag, and re-process the build-specific options. @@ -275,9 +277,12 @@ main = let compileFile src = do writeIORef v_DynFlags init_dyn_flags + exists <- doesFileExist src + when (not exists) $ + throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) + -- We compile in two stages, because the file may have an -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C) - let (basename, suffix) = splitFilename src -- just preprocess @@ -307,7 +312,7 @@ setTopDir :: [String] -> IO [String] setTopDir args = do let (minusbs, others) = partition (prefixMatch "-B") args (case minusbs of - [] -> throwDyn (OtherError ("missing -B option")) + [] -> throwDyn (InstallationError ("missing -B option")) some -> writeIORef v_TopDir (drop 2 (last some))) return others @@ -326,7 +331,7 @@ beginMake fileish_args beginInteractive :: [String] -> IO () #ifndef GHCI -beginInteractive = throwDyn (OtherError "not built for interactive use") +beginInteractive = throwDyn (CmdLineError "not built for interactive use") #else beginInteractive fileish_args = do minus_ls <- readIORef v_Cmdline_libraries -- 1.7.10.4