import RnExpr
import HsSyn
+import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
+import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
import RnMonad
import Class ( FunDep, DefMeth (..) )
+import DataCon ( dataConId )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
+import TysWiredIn ( tupleCon )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
%*********************************************************
\begin{code}
-rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
+rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
+ -> [RdrNameHsDecl]
+ -> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
-rnSourceDecls decls
- = go emptyFVs [] decls
+rnSourceDecls gbl_env local_fixity_env decls
+ = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
However, we can also do some scoping checks at the same time.
\begin{code}
-rnTyClDecl (IfaceSig name ty id_infos loc)
+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 name' ty' id_infos' loc)
+ returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
-rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
+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' ->
- lookupSysBinder gen_name1 `thenRn` \ name1' ->
- lookupSysBinder gen_name2 `thenRn` \ name2' ->
+ mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
rnDerivs derivings `thenRn` \ derivings' ->
- returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' src_loc name1' name2')
+ 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 name tyvars ty src_loc)
+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 name' tyvars' ty' src_loc)
+ 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 context cname tyvars fds sigs mbinds names src_loc)
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+ tcdSysNames = names, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc)
+ 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 maybe_dm_stuff ty locn)
+rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
lookupTopBndrRn op `thenRn` \ op_name ->
rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
-- Make the default-method name
- (case maybe_dm_stuff of
- Nothing -> returnRn Nothing -- Source-file class decl
-
- Just (DefMeth dm_rdr_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 (Just (DefMeth 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
- Just GenDefMeth -> returnRn (Just GenDefMeth)
- Just NoDefMeth -> returnRn (Just NoDefMeth)
- ) `thenRn` \ maybe_dm_stuff' ->
+ GenDefMeth -> returnRn GenDefMeth
+ NoDefMeth -> returnRn NoDefMeth
+ ) `thenRn` \ dm_stuff' ->
- returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn)
+ returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
- -- Rename the mbinds only; the rest is done already
-rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here
- (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here
+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
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 (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
+ returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
- meth_doc = text "the default-methods for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class declaration
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
+rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
-- Don't do lookupOccRn, because this is built-in syntax
-- so it doesn't need to be in scope
= mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (HsTupleTy (HsTupCon n' boxity) tys')
+ returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
where
- n' = tupleTyCon_name boxity (length tys)
+ tup_name = tupleTyCon_name boxity arity
rnHsType doc (HsAppTy ty1 ty2)
\end{code}
\begin{code}
--- We use lookupOcc here because this is interface file only stuff
--- and we need the workers...
-rnHsTupCon (HsTupCon n boxity)
- = lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-
-rnHsTupConWkr (HsTupCon n boxity)
- -- Tuple construtors are for the *worker* of the tuple
- -- Going direct saves needless messing about
- = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-\end{code}
-
-\begin{code}
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
rnContext doc ctxt `thenRn` \ new_ctxt ->
= rnHsType (text "ccall") ty `thenRn` \ ty' ->
returnRn (UfCCall cc ty')
-rnCoreExpr (UfTuple con args)
- = rnHsTupConWkr con `thenRn` \ con' ->
- mapRn rnCoreExpr args `thenRn` \ args' ->
- returnRn (UfTuple con' args')
+rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
+ = mapRn rnCoreExpr args `thenRn` \ args' ->
+ returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
+ where
+ tup_name = getName (dataConId (tupleCon boxity arity))
+ -- Get the *worker* name and use that
rnCoreExpr (UfApp fun arg)
= rnCoreExpr fun `thenRn` \ fun' ->
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con bndrs `thenRn` \ con' ->
+ = rnUfCon con `thenRn` \ con' ->
bindCoreLocalsRn bndrs $ \ bndrs' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (con', bndrs', rhs')
rnNote UfInlineMe = returnRn UfInlineMe
-rnUfCon UfDefault _
+rnUfCon UfDefault
= returnRn UfDefault
-rnUfCon (UfTupleAlt tup_con) bndrs
- = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) ->
- returnRn (UfDataAlt con')
- -- Makes the type checker a little easier
+rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
+ = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
+ where
+ tup_name = getName (tupleCon boxity arity)
-rnUfCon (UfDataAlt con) _
+rnUfCon (UfDataAlt con)
= lookupOccRn con `thenRn` \ con' ->
returnRn (UfDataAlt con')
-rnUfCon (UfLitAlt lit) _
+rnUfCon (UfLitAlt lit)
= returnRn (UfLitAlt lit)
-rnUfCon (UfLitLitAlt lit ty) _
+rnUfCon (UfLitLitAlt lit ty)
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLitAlt lit ty')
\end{code}
projects / ghc-hetmet.git / blobdiff