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
= 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
; 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
}
; info <- tcIdInfo ignore_prags name ty info
; 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 })
+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,
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
- ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+ ; let ats = map (setAssocFamilyPermutation tyvars) ats'
; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
where
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
- -- For each AT argument compute the position of the corresponding class
- -- parameter in the class head. This will later serve as a permutation
- -- vector when checking the validity of instance declarations.
- setTyThingPoss (ATyCon tycon) atTyVars =
- let classTyVars = map fst tv_bndrs
- poss = catMaybes
- . map ((`elemIndex` classTyVars) . fst)
- $ atTyVars
- -- There will be no Nothing, as we already passed renaming
- in
- ATyCon (setTyConArgPoss tycon poss)
- setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
-
tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
; 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
; 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.
%************************************************************************
%* *
%************************************************************************
%* *
+ 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}
+
+
+%************************************************************************
+%* *
Vectorisation information
%* *
%************************************************************************
-- 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