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 )
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 )
import Unique ( Unique )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
-import Bag ( snocBag, unionBags, unitBag )
+import Bag ( snocBag, unionBags )
import Panic ( showException )
import IO ( stderr )
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,
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
-> 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
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}
\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
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}
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)) }
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 ;
- traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ;
- -- Ugh! traceTc is too specific; unitBag is horrible
writeMutVar errs_var (warns, errs `snocBag` err) }
addErrs :: [(SrcSpan,Message)] -> TcRn ()
-- 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 }
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}