Type checking of type signatures in interface files
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
- tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
+ tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
import Type
import TypeRep
import HscTypes
+import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
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 iface -> do
+ Succeeded _ -> do
-- Now look it up again; this time we should find it
{ eps <- getEps
; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
- -- Now do those rules and instances
+ -- Now do those rules, instances and annotations
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
+ ; anns <- tcIfaceAnnotations (mi_anns iface)
-- Vectorisation information
; vect_info <- tcIfaceVectInfo (mi_module iface) type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
+ , md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
}
; case lookupUFM hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (hm_details info)
- other -> return emptyModDetails }
+ _ -> return emptyModDetails }
else do
-- OK, so we're in one-shot mode.
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
; info <- tcIdInfo ignore_prags name ty info
- ; return (AnId (mkVanillaGlobal name ty info)) }
-
-tcIfaceDecl ignore_prags
- (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 ignore_prags
- (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,
ATyCon (setTyConArgPoss tycon poss)
setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
-tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
; lbl_names <- mapM lookupIfaceTop field_lbls
+ -- Remember, tycon is the representation tycon
+ ; let orig_res_ty = mkFamilyTyConApp tycon
+ (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
+
; buildDataCon name is_infix {- Not infix -}
stricts lbl_names
univ_tyvars ex_tyvars
eq_spec theta
- arg_tys tycon
+ arg_tys orig_res_ty tycon
}
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
+tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
where
; 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.
%************************************************************************
%* *
\begin{code}
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
- ifInstCls = cls, ifInstTys = mb_tcs,
- ifInstOrph = orph })
+ ifInstCls = cls, ifInstTys = mb_tcs })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
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
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
- ifRuleOrph = orph })
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
forkM (ptext (sLit "Rule") <+> ftext name) $
-- to write them out in coreRuleToIfaceRule
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
- ifTopFreeName (IfaceApp f a) = ifTopFreeName f
+ ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
- ifTopFreeName other = Nothing
+ ifTopFreeName _ = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ Annotations
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceAnnotations = mapM tcIfaceAnnotation
+
+tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
+tcIfaceAnnotation (IfaceAnnotation target serialized) = do
+ target' <- tcIfaceAnnTarget target
+ return $ Annotation {
+ ann_target = target',
+ ann_value = serialized
+ }
+
+tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
+tcIfaceAnnTarget (NamedTarget occ) = do
+ name <- lookupIfaceTop occ
+ return $ NamedTarget name
+tcIfaceAnnTarget (ModuleTarget mod) = do
+ return $ ModuleTarget mod
+
\end{code}
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
tcIfaceExpr (IfaceNote note expr) = do
expr' <- tcIfaceExpr expr
case note of
- IfaceInlineMe -> return (Note InlineMe expr')
IfaceSCC cc -> return (Note (SCC cc) expr')
IfaceCoreNote n -> return (Note (CoreNote n) expr')
-------------------------
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+ -> (IfaceConAlt, [FastString], IfaceExpr)
+ -> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
= ASSERT( null names ) do
rhs' <- tcIfaceExpr rhs
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt con inst_tys arg_strs rhs }
-tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
+tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
= ASSERT( isTupleTyCon tycon )
do { let [data_con] = tyConDataCons tycon
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+ -> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
-- 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)
+ tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
-- The next two are lazy, so they don't transitively suck stuff in
- tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
- tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
- tcPrag info (HsUnfold expr) = do
- maybe_expr' <- tcPragExpr name expr
- let
- -- maybe_expr' doesn't get looked at if the unfolding
- -- is never inspected; so the typecheck doesn't even happen
- unfold_info = case maybe_expr' of
- Nothing -> noUnfolding
- Just expr' -> mkTopUnfolding expr'
- return (info `setUnfoldingInfoLazily` unfold_info)
+ tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf
+ ; return (info `setUnfoldingInfoLazily` unf) }
\end{code}
\begin{code}
-tcWorkerInfo ty info wkr arity
+tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding name _ _ (IfCoreUnfold if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkTopUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkInlineRule expr arity) }
+
+tcUnfolding name ty info (IfWrapper arity wkr)
= do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
-
- -- We return without testing maybe_wkr_id, but as soon as info is
- -- looked at we will test it. That's ok, because its outside the
- -- knot; and there seems no big reason to further defer the
- -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
- -- over the unfolding until it's actually used does seem worth while.)
; us <- newUniqueSupply
-
; return (case mb_wkr_id of
- Nothing -> info
- Just wkr_id -> add_wkr_info us wkr_id info) }
+ Nothing -> noUnfolding
+ Just wkr_id -> make_inline_rule wkr_id us) }
where
- doc = text "Worker for" <+> ppr wkr
- add_wkr_info us wkr_id info
- = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
- `setWorkerInfo` HasWorker wkr_id arity
+ doc = text "Worker for" <+> ppr name
- mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ make_inline_rule wkr_id us
+ = mkWwInlineRule (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ arity wkr_id
-- We are relying here on strictness info always appearing
-- before worker info, fingers crossed ....
{ type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
- Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
- ; other -> do
+ ; _ -> 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
check_tc tc
| debugIsOn = case toIfaceTyCon tc of
IfaceTc _ -> tc
- other -> pprTrace "check_tc" (ppr tc) tc
+ _ -> pprTrace "check_tc" (ppr tc) tc
| otherwise = tc
-- we should be okay just returning Kind constructors without extra loading
tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
ADataCon dc -> return dc
- other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
- other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
\end{code}
%************************************************************************
thing_inside (b':bs')
-----------------------
+tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
tcIfaceLetBndr (IfLetBndr fs ty info)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
-----------------------
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