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
; 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
}
; 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
%************************************************************************
%* *
+ 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
%* *
%************************************************************************