X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=d1d85287959cbd3e168d40a6f19edb19cdc771b0;hb=ca1b9eb214a0ad9880c4f373d54236856c6a256b;hp=ea8b69d3956ffd61c6b79ece66c78d898d70da2c;hpb=3370ed763b1b71326fdebf143b840dc023170aab;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index ea8b69d..d1d8528 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 ) @@ -27,8 +28,9 @@ import InstEnv ( emptyInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors, + mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) +import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) @@ -92,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, @@ -133,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 @@ -146,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 @@ -303,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} @@ -314,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 @@ -339,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} @@ -431,8 +452,10 @@ addLongErrAt loc msg extra rdr_env <- getGlobalRdrEnv ; let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; - traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ; - -- Ugh! traceTc is too specific; unitBag is horrible + + let style = mkErrStyle (unQualInScope rdr_env) + doc = mkLocMessage loc (msg $$ extra) + in traceTc (ptext SLIT("Adding error:") <+> doc) ; writeMutVar errs_var (warns, errs `snocBag` err) } addErrs :: [(SrcSpan,Message)] -> TcRn () @@ -910,7 +933,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 } @@ -950,7 +973,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}