loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
+
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags )
+import LoadIface ( loadHomeInterface, loadInterface, predInstGates,
+ discardDeclPrags, loadDecls )
import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
+ mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
- ModIface(..), ModDetails(..), InstPool, ModGuts,
- TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList,
- lookupTypeEnv, lookupType, typeEnvIds,
- RulePool )
-import InstEnv ( extendInstEnv )
+ ModIface(..), ModDetails(..), ModGuts,
+ mkTypeEnv, extendTypeEnv,
+ lookupTypeEnv, lookupType, typeEnvIds )
+import InstEnv ( extendInstEnvList )
import CoreSyn
import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
setArityInfo, setInlinePragInfo, setCafInfo,
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
-import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
-import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
-import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
- tupleTyCon, tupleCon )
+import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
+import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
import Var ( TyVar, mkTyVar, tyVarKind )
-import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom,
- isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe )
+import Name ( Name, nameModule, nameIsLocalOrFrom,
+ isWiredInName, wiredInNameTyThing_maybe, nameParent )
import NameEnv
import OccName ( OccName )
-import Module ( Module, ModuleName, moduleName )
+import Module ( Module )
import UniqSupply ( initUs_ )
import Outputable
+import ErrUtils ( Message )
+import Maybes ( MaybeErr(..) )
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, dropList, equalLength, zipLazy )
-import Maybes ( expectJust )
import CmdLineOpts ( DynFlag(..) )
-
-import UniqFM (sizeUFM)
-
\end{code}
This module takes
also turn out to be needed by the code that e2 expands to.
\begin{code}
-tcImportDecl :: Name -> IfG TyThing
+tcImportDecl :: Name -> TcM TyThing
+-- Entry point for source-code uses of importDecl
+tcImportDecl name
+ = do { traceIf (text "tcLookupGlobal" <+> ppr name)
+ ; mb_thing <- initIfaceTcRn (importDecl name)
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed err -> failWithTc err }
+
+importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
-- Get the TyThing for this Name from an interface file
-tcImportDecl name
+importDecl name
| Just thing <- wiredInNameTyThing_maybe name
- -- This case only happens for tuples, because we pre-populate the eps_PTE
- -- with other wired-in things. We can't do that for tuples because we
+ -- This case definitely happens for tuples, because we
-- don't know how many of them we'll find
+ -- It also now happens for all other wired in things. We used
+ -- to pre-populate the eps_PTE with other wired-in things, but
+ -- we don't seem to do that any more. I guess it keeps the PTE smaller?
= do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
- ; return thing }
+ ; return (Succeeded thing) }
| otherwise
= do { traceIf nd_doc
-- Load the interface, which should populate the PTE
- ; loadHomeInterface nd_doc name
+ ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+ ; case mb_iface of {
+ Failed err_msg -> return (Failed err_msg) ;
+ Succeeded iface -> do
-- Now look it up again; this time we should find it
- ; eps <- getEps
+ { eps <- getEps
; case lookupTypeEnv (eps_PTE eps) name of
- Just thing -> return thing
- Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
- -- Declaration not found!
- -- No errors-var to accumulate errors in, so just
- -- print out the error right now
- }
+ Just thing -> return (Succeeded thing)
+ Nothing -> return (Failed not_found_msg)
+ }}}
where
nd_doc = ptext SLIT("Need decl for") <+> ppr name
- msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
- 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
- ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
+ not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
%************************************************************************
-- It's not actually *wrong* to do so, but in fact GHCi is unable
-- to handle unboxed tuples, so it must not see unfoldings.
ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface)
- | otherwise = map snd (mi_decls iface)
- ; rules | ignore_prags = []
- | otherwise = mi_rules iface
- ; dfuns = mi_insts iface
- ; mod_name = moduleName (mi_module iface)
- }
- -- Typecheck the decls
- ; names <- mappM (lookupOrig mod_name . ifName) decls
- ; ty_things <- fixM (\ rec_ty_things -> do
- { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
- -- This only makes available the "main" things,
- -- but that's enough for the strictly-checked part
- ; mapM tcIfaceDecl decls })
-
- -- Now augment the type envt with all the implicit things
- -- These will be needed when type-checking the unfoldings for
- -- the IfaceIds, but this is done lazily, so writing the thing
- -- now is sufficient
- ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing
- ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
+
+ -- Load & typecheck the decls
+ ; decl_things <- loadDecls ignore_prags (mi_decls iface)
+
+ ; let type_env = mkNameEnv decl_things
; writeMutVar tc_env_var type_env
-- Now do those rules and instances
+ ; let { rules | ignore_prags = []
+ | otherwise = mi_rules iface
+ ; dfuns = mi_insts iface
+ }
; dfuns <- mapM tcIfaceInst dfuns
; rules <- mapM tcIfaceRule rules
; return (AnId (mkVanillaGlobal name ty info)) }
tcIfaceDecl (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
+ ifTyVars = tv_bndrs,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
ifGeneric = want_generic })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
- { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt)
-
- ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $
- tcIfaceCtxt rdr_ctxt
- -- The reason for laziness here is to postpone
- -- looking at the context, because the class may not
- -- be in the type envt yet. E.g.
- -- class Real a where { toRat :: a -> Ratio Integer }
- -- data (Real a) => Ratio a = ...
- -- We suck in the decl for Real, and type check it, which sucks
- -- in the data type Ratio; but we must postpone typechecking the
- -- context
-
- ; tycon <- fixM ( \ tycon -> do
- { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
- ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons
+ { tycon <- fixM ( \ tycon -> do
+ { cons <- tcIfaceDataCons tycon tyvars rdr_cons
+ ; tycon <- buildAlgTyCon tc_name tyvars cons
arg_vrcs is_rec want_generic
; return tycon
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
- } }
+ }}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0 [])) }
-tcIfaceDataCons tycon tyvars ctxt if_cons
+tcIfaceDataCons tycon tc_tyvars if_cons
= case if_cons of
- IfAbstractTyCon -> return mkAbstractTyConRhs
- IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
- ; return (mkDataTyConRhs data_cons) }
- IfNewTyCon con -> do { data_con <- tc_con_decl con
- ; return (mkNewTyConRhs data_con) }
+ IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt
+ ; data_cons <- mappM tc_con_decl cons
+ ; return (mkDataTyConRhs mb_theta data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; return (mkNewTyConRhs tycon data_con) }
where
- tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls)
- = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
- { name <- lookupIfaceTop occ
- ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here
+ tc_ctxt Nothing = return Nothing
+ tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }
+
+ tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
+ ifConStricts = stricts, ifConFields = field_lbls})
+ = do { name <- lookupIfaceTop occ
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; buildDataCon name is_infix True {- Vanilla -}
+ stricts lbl_names
+ tc_tyvars [] arg_tys tycon
+ (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
+ }
+
+ tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt,
+ ifConArgTys = args, ifConResTys = ress,
+ ifConStricts = stricts})
+ = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
+ { name <- lookupIfaceTop occ
+ ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
+ -- At one stage I thought that this context checking *had*
+ -- to be lazy, because of possible mutual recursion between the
+ -- type and the classe:
+ -- E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- But now I think that the laziness in checking class ops breaks
+ -- the loop, so no laziness needed
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ;
-
- ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
- ; buildDataCon name is_infix stricts lbl_names
- tyvars ctxt ex_tyvars ex_theta
- arg_tys tycon
+ ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
+ stricts [{- No fields -}]
+ con_tyvars theta
+ arg_tys tycon res_tys
}
- mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args]
+ mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
\end{code}
do { eps <- getEps; return (eps_inst_env eps) }
else do
{ traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
- nest 2 (vcat (map ppr iface_insts))])
+ nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])])
-- Typecheck the new instances
; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
-- And put them in the package instance environment
; updateEps ( \ eps ->
let
- inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
+ inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
in
(eps { eps_inst_env = inst_env' }, inst_env')
)}}
where
wired_doc = ptext SLIT("Need home inteface for wired-in thing")
-tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst)
+tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst)
+ where
+ full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst))
tcIfaceInst :: IfaceInst -> IfL DFunId
tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
= tcIfaceExtId (LocalTop dfun_occ)
-selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceInst)])
+selectInsts :: Name -> [Name] -> ExternalPackageState
+ -> (ExternalPackageState, [(Module, SDoc, IfaceInst)])
selectInsts cls tycons eps
= (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
where
{ -- Get new rules
if_rules <- updateEps selectRules
- ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
+ ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
- ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
; core_rules <- mapM tc_rule if_rules
-- Debug print
; return core_rules
}
-
-selectRules :: ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceRule)])
+tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
+ where
+ full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
+
+selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
-- Not terribly efficient. Look at each rule in the pool to see if
-- all its gates are in the type env. If so, take it out of the pool.
-- If not, trim its gates for next time.
do { fn <- tcIfaceExtId fn_rdr
; args' <- mappM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
- ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) }
+ ; let rule = Rule rule_name act bndrs' args' rhs'
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
+ where
tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
= do { fn <- tcIfaceExtId fn_rdr
- ; returnM (fn, core_rule) }
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
+
+isOrphNm :: IfaceExtName -> Bool
+-- An orphan name comes from somewhere other than this module,
+-- so it has a non-local name
+isOrphNm name = not (isLocalIfaceExtName name)
\end{code}
tcIfaceExpr arg `thenM` \ arg' ->
returnM (App fun' arg')
-tcIfaceExpr (IfaceCase scrut case_bndr alts)
+tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
= tcIfaceExpr scrut `thenM` \ scrut' ->
newIfaceName case_bndr `thenM` \ case_bndr_name ->
let
in
extendIfaceIdEnv [case_bndr'] $
mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
- returnM (Case scrut' case_bndr' alts')
+ tcIfaceType ty `thenM` \ ty' ->
+ returnM (Case scrut' case_bndr' ty' alts')
tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
= tcIfaceExpr rhs `thenM` \ rhs' ->
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
- = let
- tycon_mod = nameModuleName (tyConName tycon)
- in
- tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con ->
- newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- ex_tyvars = dataConExistentialTyVars con
- main_tyvars = tyConTyVars tycon
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = dropList ex_tyvars arg_names
- arg_ids
-#ifdef DEBUG
- | not (equalLength id_names arg_tys)
- = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$
- (ppr main_tyvars <+> ppr ex_tyvars) $$
- ppr arg_tys)
- | otherwise
-#endif
- = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys
- in
- ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars,
- ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars )
- extendIfaceTyVarEnv ex_tyvars' $
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+ = do { let tycon_mod = nameModule (tyConName tycon)
+ ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
+ ; ASSERT2( con `elem` tyConDataCons tycon,
+ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
+
+ if isVanillaDataCon con then
+ tcVanillaAlt con inst_tys arg_occs rhs
+ else
+ do { -- General case
+ arg_names <- newIfaceNames arg_occs
+ ; let tyvars = [ mkTyVar name (tyVarKind tv)
+ | (name,tv) <- arg_names `zip` dataConTyVars con]
+ arg_tys = dataConArgTys con (mkTyVarTys tyvars)
+ id_names = dropList tyvars arg_names
+ arg_ids = ASSERT2( equalLength id_names arg_tys,
+ ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
+ zipWith mkLocalId id_names arg_tys
+
+ ; rhs' <- extendIfaceTyVarEnv tyvars $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
- = newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- [con] = tyConDataCons tycon
- arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys
- in
- ASSERT( isTupleTyCon tycon )
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, arg_ids, rhs')
+ = ASSERT( isTupleTyCon tycon )
+ do { let [data_con] = tyConDataCons tycon
+ ; tcVanillaAlt data_con inst_tys arg_occs rhs }
+
+tcVanillaAlt data_con inst_tys arg_occs rhs
+ = do { arg_names <- newIfaceNames arg_occs
+ ; let arg_tys = dataConArgTys data_con inst_tys
+ ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
+ ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
+ zipWith mkLocalId arg_names arg_tys
+ ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
+ ; returnM (DataAlt data_con, arg_ids, rhs') }
\end{code}
\begin{code}
-tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core
-tcExtCoreBindings mod [] = return []
-tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs)
+tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
+tcExtCoreBindings [] = return []
+tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
-do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
-do_one mod (IfaceNonRec bndr rhs) thing_inside
+do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
+do_one (IfaceNonRec bndr rhs) thing_inside
= do { rhs' <- tcIfaceExpr rhs
- ; bndr' <- newExtCoreBndr mod bndr
+ ; bndr' <- newExtCoreBndr bndr
; extendIfaceIdEnv [bndr'] $ do
{ core_binds <- thing_inside
; return (NonRec bndr' rhs' : core_binds) }}
-do_one mod (IfaceRec pairs) thing_inside
- = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs
+do_one (IfaceRec pairs) thing_inside
+ = do { bndrs' <- mappM newExtCoreBndr bndrs
; extendIfaceIdEnv bndrs' $ do
{ rhss' <- mappM tcIfaceExpr rhss
; core_binds <- thing_inside
%************************************************************************
\begin{code}
-tcIfaceGlobal :: Name -> IfM a TyThing
+tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
= do { (eps,hpt) <- getEpsAndHpt
; case lookupType hpt (eps_PTE eps) name of {
Just thing -> return thing ;
- Nothing ->
+ Nothing -> do
- setLclEnv () $ do -- This gets us back to IfG, mainly to
- -- pacify get_type_env; rather untidy
{ env <- getGblEnv
- ; case if_rec_types env of
+ ; case if_rec_types env of {
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do -- It's defined in the module being compiled
- { type_env <- get_type_env
+ { type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
- other -> tcImportDecl name -- It's imported; go get it
- }}}
+ ; other -> do
+
+ { mb_thing <- importDecl name -- It's imported; go get it
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
+ }}}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = return intTyCon
-----------------------
-newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id
-newExtCoreBndr mod (occ, ty)
- = do { name <- newGlobalBinder mod occ Nothing noSrcLoc
+newExtCoreBndr :: (OccName, IfaceType) -> IfL Id
+newExtCoreBndr (occ, ty)
+ = do { mod <- getIfModule
+ ; name <- newGlobalBinder mod occ Nothing noSrcLoc
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
projects / ghc-hetmet.git / blobdiff