An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.
- -- For (b) consider: f = $(...h....)
+ -- For (b) consider: f = \$(...h....)
-- where h is imported, and calls f via an hi-boot file.
-- This is bad! But it is not seen as a staging error, because h
-- is indeed imported. We don't want the type-checker to black-hole
= return ()
| otherwise
= do { mod <- getModule
- ; unless (mod == nameModule tc_name)
+ ; ASSERT( isExternalName tc_name )
+ unless (mod == nameModule tc_name)
(initIfaceTcRn (loadWiredInHomeIface tc_name))
-- Don't look for (non-existent) Float.hi when
-- compiling Float.lhs, which mentions Float of course
do { traceIf nd_doc
-- Load the interface, which should populate the PTE
- ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+ ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+ loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of {
Failed err_msg -> return (Failed err_msg) ;
Succeeded _ -> do
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
; info <- tcIdInfo ignore_prags name ty info
- ; return (AnId (mkVanillaGlobal name ty info)) }
-
-tcIfaceDecl _
- (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs,
- ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
- ifCons = rdr_cons,
- ifRec = is_rec,
- ifGeneric = want_generic,
- ifFamInst = mb_family })
+ ; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
+
+tcIfaceDecl _ (IfaceData {ifName = occ_name,
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifRec = is_rec,
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
; return (ATyCon tycon)
}}
-tcIfaceDecl _
- (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
- ifFamInst = mb_family})
+tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_tyki <- tcIfaceType rdr_rhs_ty
- ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
- else SynonymTyCon rhs_tyki
- ; famInst <- case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
- do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
- }
- ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+ ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; ~(rhs, fam) <- forkM (mk_doc tc_name) $
+ do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
+ ; fam <- tc_syn_fam mb_family
+ ; return (rhs, fam) }
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
; return $ ATyCon tycon
}
+ where
+ mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+ tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing)
+ tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
+ tc_syn_fam Nothing
+ = return Nothing
+ tc_syn_fam (Just (fam, tys))
+ = do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
tcIfaceDecl ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
; return (tv,ty) }
\end{code}
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff). To see why,
+consider this (Trac #2412)
+
+M.hs: module M where { import X; data T = MkT S }
+X.hs: module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot: module M where { data T }
+
+When kind-checking M.hs we need S's kind. But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet! Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
%************************************************************************
%* *
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
ifFamInstFam = fam, ifFamInstTys = mb_tcs })
-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
--- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
+-- the above line doesn't work, but this below does => CPP in Haskell = evil!
= do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
tcIfaceTyCon tycon
let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-- we start; default assumption is that it has CAFs
init_info = vanillaIdInfo
+ tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str)
; _ -> do
- { (eps,hpt) <- getEpsAndHpt
- ; dflags <- getDOpts
- ; case lookupType dflags hpt (eps_PTE eps) name of {
+ { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+ ; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
-- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
-- the HPT, so without the test we'll demand-load it into the PIT!
-- C.f. the same test in checkWiredInTyCon above
- ; unless (mod == nameModule name)
+ ; ASSERT2( isExternalName name, ppr name )
+ unless (mod == nameModule name)
(loadWiredInHomeIface name) }
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-----------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
- = do { name <- newIfaceName (mkTyVarOcc occ)
+ = do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
- = do { names <- newIfaceNames (map mkTyVarOcc occs)
+ = do { names <- newIfaceNames (map mkTyVarOccFS occs)
; tyvars <- zipWithM mk_iface_tyvar names kinds
; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
where
projects / ghc-hetmet.git / blobdiff