+\subsection{Type, class and iface sig declarations}
+%* *
+%*********************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
+
+\begin{code}
+rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ rnHsType doc_str ty `thenRn` \ ty' ->
+ mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
+ returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
+ where
+ doc_str = text "the interface signature for" <+> quotes (ppr name)
+
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
+ tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
+ tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
+ = pushSrcLocRn src_loc $
+ lookupTopBndrRn tycon `thenRn` \ tycon' ->
+ bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ rnContext data_doc context `thenRn` \ context' ->
+ checkDupOrQualNames data_doc con_names `thenRn_`
+ mapRn rnConDecl condecls `thenRn` \ condecls' ->
+ mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
+ rnDerivs derivings `thenRn` \ derivings' ->
+ returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+ tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'})
+ where
+ data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+ con_names = map conDeclName condecls
+
+rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
+ = pushSrcLocRn src_loc $
+ doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+ lookupTopBndrRn name `thenRn` \ name' ->
+ bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
+ returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
+ where
+ syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+
+ -- For H98 we do *not* universally quantify on the RHS of a synonym
+ -- Silently discard context... but the tyvars in the rest won't be in scope
+ -- In interface files all types are quantified, so this is a no-op
+ unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
+ unquantify glaExys ty = ty
+
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+ tcdSysNames = names, tcdLoc = src_loc})
+ = pushSrcLocRn src_loc $
+
+ lookupTopBndrRn cname `thenRn` \ cname' ->
+
+ -- Deal with the implicit tycon and datacon name
+ -- They aren't in scope (because they aren't visible to the user)
+ -- and what we want to do is simply look them up in the cache;
+ -- we jolly well ought to get a 'hit' there!
+ mapRn lookupSysBinder names `thenRn` \ names' ->
+
+ -- Tyvars scope over bindings and context
+ bindTyVars2Rn cls_doc tyvars $ \ clas_tyvar_names tyvars' ->
+
+ -- Check the superclasses
+ rnContext cls_doc context `thenRn` \ context' ->
+
+ -- Check the functional dependencies
+ rnFds cls_doc fds `thenRn` \ fds' ->
+
+ -- Check the signatures
+ -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
+ let
+ (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+ in
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs `thenRn` \ sigs' ->
+ let
+ binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+ in
+ renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' ->
+
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
+
+ returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+ tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
+ tcdSysNames = names', tcdLoc = src_loc})
+ where
+ cls_doc = text "the declaration for class" <+> ppr cname
+ sig_doc = text "the signatures for class" <+> ppr cname
+
+rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
+ = pushSrcLocRn locn $
+ lookupTopBndrRn op `thenRn` \ op_name ->
+
+ -- Check the signature
+ rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
+
+ -- Make the default-method name
+ (case dm_stuff of
+ DefMeth dm_rdr_name
+ -> -- Imported class that has a default method decl
+ -- See comments with tname, snames, above
+ lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
+ returnRn (DefMeth dm_name)
+ -- An imported class decl for a class decl that had an explicit default
+ -- method, mentions, rather than defines,
+ -- the default method, so we must arrange to pull it in
+
+ GenDefMeth -> returnRn GenDefMeth
+ NoDefMeth -> returnRn NoDefMeth
+ ) `thenRn` \ dm_stuff' ->
+
+ returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
+
+rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
+rnClassBinds (ClassDecl {tcdMeths = Nothing})
+ rn_cls_decl@(ClassDecl {tcdSigs = sigs})
+ -- No method bindings, so this class decl comes from an interface file,
+ -- However we want to treat the default-method names as free (they should
+ -- be defined somewhere else). [In source code this is not so; the class
+ -- decl will bind whatever default-methods are necessary.]
+ = returnRn (rn_cls_decl, mkFVs [v | ClassOpSig _ (DefMeth v) _ _ <- sigs])
+
+rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here
+ rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
+ -- There are some default-method bindings (abeit possibly empty) so
+ -- this is a source-code class declaration
+ = -- The newLocals call is tiresome: given a generic class decl
+ -- class C a where
+ -- op :: a -> a
+ -- op {| x+y |} (Inl a) = ...
+ -- op {| x+y |} (Inr b) = ...
+ -- op {| a*b |} (a*b) = ...
+ -- we want to name both "x" tyvars with the same unique, so that they are
+ -- easy to group together in the typechecker.
+ -- Hence the
+ extendTyVarEnvFVRn (map hsTyVarName tyvars) $
+ getLocalNameEnv `thenRn` \ name_env ->
+ let
+ meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
+ gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
+ not (tv `elemRdrEnv` name_env)]
+ in
+ checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
+ newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
+ rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
+ returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
+ where
+ meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+
+rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
+ -- Not a class declaration
+\end{code}
+
+
+%*********************************************************
+%* *
projects / ghc-hetmet.git / blobdiff