Commit 0dfa678a authored by simonpj's avatar simonpj
Browse files

[project @ 2003-10-09 15:38:22 by simonpj]

Wibles
parent f46d760f
...@@ -279,7 +279,8 @@ tcIfaceGlobal name ...@@ -279,7 +279,8 @@ tcIfaceGlobal name
Just thing -> return thing ; Just thing -> return thing ;
Nothing -> Nothing ->
setLclEnv () $ do setLclEnv () $ do -- This gets us back to IfG, mainly to
-- pacify get_type_env; rather untidy
{ env <- getGblEnv { env <- getGblEnv
; case if_rec_types env of ; case if_rec_types env of
Just (mod, get_type_env) Just (mod, get_type_env)
......
...@@ -342,7 +342,7 @@ toIfaceKind k ...@@ -342,7 +342,7 @@ toIfaceKind k
| Just (arg,res) <- splitFunTy_maybe k | Just (arg,res) <- splitFunTy_maybe k
= IfaceFunKind (toIfaceKind arg) (toIfaceKind res) = IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
#ifdef DEBUG #ifdef DEBUG
| otherwise = pprPanic "toIfaceKind" (crudePprType k) | otherwise = pprTrace "toIfaceKind" (crudePprType k) IfaceOpenTypeKind
#endif #endif
--------------------- ---------------------
......
...@@ -26,7 +26,7 @@ import Type ( Kind, openTypeKind, liftedTypeKind, ...@@ -26,7 +26,7 @@ import Type ( Kind, openTypeKind, liftedTypeKind,
import TypeRep ( Type(..), PredType(..) ) import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName ) import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), PackageInstEnv, import HscTypes ( ExternalPackageState(..), PackageInstEnv,
TyThing(..), implicitTyThings, TyThing(..), implicitTyThings, typeEnvIds,
ModIface(..), ModDetails(..), InstPool, ModIface(..), ModDetails(..), InstPool,
TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
...@@ -445,10 +445,6 @@ loadImportedInsts cls tys ...@@ -445,10 +445,6 @@ loadImportedInsts cls tys
; let { (inst_pool', iface_insts) ; let { (inst_pool', iface_insts)
= selectInsts (eps_insts eps) cls_gate tc_gates } = selectInsts (eps_insts eps) cls_gate tc_gates }
; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys,
text "new pool" <+> ppr inst_pool',
text "new insts" <+> ppr iface_insts])
-- Empty => finish up rapidly, without writing to eps -- Empty => finish up rapidly, without writing to eps
; if null iface_insts then ; if null iface_insts then
return (eps_inst_env eps) return (eps_inst_env eps)
...@@ -829,7 +825,8 @@ tcPragExpr name expr ...@@ -829,7 +825,8 @@ tcPragExpr name expr
-- Check for type consistency in the unfolding -- Check for type consistency in the unfolding
ifOptM Opt_DoCoreLinting ( ifOptM Opt_DoCoreLinting (
case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of get_in_scope_ids `thenM` \ in_scope ->
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> returnM () Nothing -> returnM ()
Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg) Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
) `thenM_` ) `thenM_`
...@@ -837,6 +834,14 @@ tcPragExpr name expr ...@@ -837,6 +834,14 @@ tcPragExpr name expr
returnM core_expr' returnM core_expr'
where where
doc = text "Unfolding of" <+> ppr name doc = text "Unfolding of" <+> ppr name
get_in_scope_ids -- Urgh; but just for linting
= setLclEnv () $
do { env <- getGblEnv
; case if_rec_types env of {
Nothing -> return [] ;
Just (_, get_env) -> do
{ type_env <- get_env
; return (typeEnvIds type_env) }}}
\end{code} \end{code}
......
...@@ -517,9 +517,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) ...@@ -517,9 +517,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- Deal with the type declarations; first bring their stuff -- Deal with the type declarations; first bring their stuff
-- into scope, then rname them, then type check them -- into scope, then rname them, then type check them
(rdr_env, imports) <- importsFromLocalDecls $ (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup decls) ;
HsGroup { hs_tyclds = decls, hs_valds = EmptyBinds, hs_fords = [] } ;
-- Rather clumsy; lots of unused fields
updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
tcg_imports = imports `plusImportAvails` tcg_imports gbl }) tcg_imports = imports `plusImportAvails` tcg_imports gbl })
...@@ -570,6 +568,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) ...@@ -570,6 +568,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
return mod_guts return mod_guts
}}}} }}}}
mkFakeGroup decls -- Rather clumsy; lots of unused fields
= HsGroup { hs_tyclds = decls, -- This is the one we want
hs_valds = EmptyBinds, hs_fords = [],
hs_instds = [], hs_fixds = [], hs_depds = [],
hs_ruleds = [] }
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment