X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=845bdd4e47a02851f20c3b72fd2eabd8a2dccb32;hb=f7e8044f26652537e9b87c4481a45cdfb1bafb8a;hp=71a20d82f4915adb6c71977e99967c8a18da5684;hpb=00007e64fd17385867ab6b835a2ef77575e86229;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 71a20d8..845bdd4 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -12,14 +12,15 @@ import IOEnv -- Re-export all import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), + isHsBoot, ModSummary(..), ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, lookupType, unQualInScope ) import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName ) +import Name ( Name, isInternalName, mkInternalName, getOccName, getSrcLoc ) import Type ( Type ) import NameEnv ( extendNameEnvList ) import InstEnv ( emptyInstEnv ) @@ -29,6 +30,7 @@ import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) +import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) @@ -42,7 +44,6 @@ import StaticFlags ( opt_PprStyle_Debug ) import Bag ( snocBag, unionBags ) import Panic ( showException ) -import Maybe ( isJust ) import IO ( stderr ) import DATA_IOREF ( newIORef, readIORef ) import EXCEPTION ( Exception ) @@ -93,6 +94,7 @@ initTc hsc_env hsc_src mod do_this tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, + tcg_home_mods = home_mods, tcg_dus = emptyDUs, tcg_rn_decls = Nothing, tcg_binds = emptyLHsBinds, @@ -109,7 +111,7 @@ initTc hsc_env hsc_src mod do_this tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, - tcl_arrow_ctxt = panic "initTc:arrow", -- only used inside proc + tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE @@ -134,7 +136,17 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails { imp_env = unitModuleEnv mod emptyNameSet } + home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) + -- A guess at the home modules. This will be correct in + -- --make and GHCi modes, but in one-shot mode we need to + -- fix it up after we know the real dependencies of the current + -- module (see tcRnModule). + -- Setting it here is necessary for the typechecker entry points + -- other than tcRnModule: tcRnGetInfo, for example. These are + -- all called via the GHC module, so hsc_mod_graph will contain + -- something sensible. + + init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat @@ -147,7 +159,7 @@ initTcPrintErrors -- Used from the interactive loop only -> IO (Maybe r) initTcPrintErrors env mod todo = do (msgs, res) <- initTc env HsSrcFile mod todo - printErrorsAndWarnings msgs + printErrorsAndWarnings (hsc_dflags env) msgs return res -- mkImpTypeEnv makes the imported symbol table @@ -304,6 +316,11 @@ newUniqueSupply let { (us1, us2) = splitUniqSupply us } ; writeMutVar u_var us1 ; return us2 } + +newLocalName :: Name -> TcRnIf gbl lcl Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} @@ -315,22 +332,22 @@ newUniqueSupply \begin{code} traceTc, traceRn :: SDoc -> TcRn () -traceRn = dumpOptTcRn Opt_D_dump_rn_trace -traceTc = dumpOptTcRn Opt_D_dump_tc_trace -traceSplice = dumpOptTcRn Opt_D_dump_splices +traceRn = traceOptTcRn Opt_D_dump_rn_trace +traceTc = traceOptTcRn Opt_D_dump_tc_trace +traceSplice = traceOptTcRn Opt_D_dump_splices traceIf :: SDoc -> TcRnIf m n () -traceIf = dumpOptIf Opt_D_dump_if_trace -traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs -dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -dumpOptIf flag doc = ifOptM flag $ +traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything +traceOptIf flag doc = ifOptM flag $ ioToIOEnv (printForUser stderr alwaysQualify doc) -dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag $ do +traceOptTcRn :: DynFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = ifOptM flag $ do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt @@ -340,6 +357,9 @@ dumpOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + +dumpOptTcRn :: DynFlag -> SDoc -> TcRn () +dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) \end{code} @@ -353,6 +373,9 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } +setModule :: Module -> TcRn a -> TcRn a +setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -428,7 +451,9 @@ addErrAt loc msg = addLongErrAt loc msg empty addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () addLongErrAt loc msg extra - = do { errs_var <- getErrsVar ; + = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + + errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; @@ -491,68 +516,88 @@ discardWarnings thing_inside \begin{code} +try_m :: TcRn r -> TcRn (Either Exception r) +-- Does try_m, with a debug-trace on failure +try_m thing + = do { mb_r <- tryM thing ; + case mb_r of + Left exn -> do { traceTc (exn_msg exn); return mb_r } + Right r -> return mb_r } + where + exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) + +----------------------- recoverM :: TcRn r -- Recovery action; do this if the main one fails -> TcRn r -- Main action: do this first -> TcRn r +-- Errors in 'thing' are retained recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } +----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) - -- (tryTc m) executes m, and returns - -- Just r, if m succeeds (returning r) and caused no errors - -- Nothing, if m fails, or caused errors - -- It also returns all the errors accumulated by m - -- (even in the Just case, there might be warnings) - -- - -- It always succeeds (never raises an exception) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) tryTc m = do { errs_var <- newMutVar emptyMessages ; - - mb_r <- try_m (setErrsVar errs_var m) ; - - new_errs <- readMutVar errs_var ; - - dflags <- getDOpts ; - - return (new_errs, - case mb_r of - Left exn -> Nothing - Right r | errorsFound dflags new_errs -> Nothing - | otherwise -> Just r) + res <- try_m (setErrsVar errs_var m) ; + msgs <- readMutVar errs_var ; + return (msgs, case res of + Left exn -> Nothing + Right val -> Just val) + -- The exception is always the IOEnv built-in + -- in exception; see IOEnv.failM } -try_m :: TcRn r -> TcRn (Either Exception r) --- Does try_m, with a debug-trace on failure -try_m thing - = do { mb_r <- tryM thing ; - case mb_r of - Left exn -> do { traceTc (exn_msg exn); return mb_r } - Right r -> return mb_r } - where - exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) +----------------------- +tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) +-- Run the thing, returning +-- Just r, if m succceeds with no error messages +-- Nothing, if m fails, or if it succeeds but has error messages +-- Either way, the messages are returned; even in the Just case +-- there might be warnings +tryTcErrs thing + = do { (msgs, res) <- tryTc thing + ; dflags <- getDOpts + ; let errs_found = errorsFound dflags msgs + ; return (msgs, case res of + Nothing -> Nothing + Just val | errs_found -> Nothing + | otherwise -> Just val) + } +----------------------- tryTcLIE :: TcM a -> TcM (Messages, Maybe a) --- Just like tryTc, except that it ensures that the LIE +-- Just like tryTcErrs, except that it ensures that the LIE -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ; - ifM (isJust mb_r) (extendLIEs lie) ; - return (errs, mb_r) } + = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ; + ; case mb_res of + Nothing -> return (msgs, Nothing) + Just val -> do { extendLIEs lie; return (msgs, Just val) } + } +----------------------- tryTcLIE_ :: TcM r -> TcM r -> TcM r --- (tryTcLIE_ r m) tries m; if it succeeds it returns it, --- otherwise it returns r. Any error messages added by m are discarded, --- whether or not m succeeds. +-- (tryTcLIE_ r m) tries m; +-- if m succeeds with no error messages, it's the answer +-- otherwise tryTcLIE_ drops everything from m and tries r instead. tryTcLIE_ recover main - = do { (_msgs, mb_res) <- tryTcLIE main ; - case mb_res of - Just res -> return res - Nothing -> recover } + = do { (msgs, mb_res) <- tryTcLIE main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } +----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors -- If m fails then (checkNoErrsTc m) fails. @@ -561,12 +606,12 @@ checkNoErrs :: TcM r -> TcM r -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. checkNoErrs main - = do { (msgs, mb_res) <- tryTcLIE main ; - addMessages msgs ; - case mb_res of - Just r -> return r - Nothing -> failM - } + = do { (msgs, mb_res) <- tryTcLIE main + ; addMessages msgs + ; case mb_res of + Nothing -> failM + Just val -> return val + } ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out main @@ -889,7 +934,7 @@ failIfM :: Message -> IfL a -- We use IfL here so that we can get context info out of the local env failIfM msg = do { env <- getLclEnv - ; let full_msg = if_loc env $$ nest 2 msg + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) ; failM } @@ -929,7 +974,8 @@ forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside = do { mb_res <- forkM_maybe doc thing_inside ; return (case mb_res of - Nothing -> pprPanic "forkM" doc + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc Just r -> r) } \end{code}