X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=50a9dcd1456e6e984aed0c23ab7d4879564011c0;hb=e7b69c553c58133ddbdc756bec03a43d35b0be5e;hp=31330f6f76a4e0981f0b8f5a81c36d84cbc00034;hpb=5a763550bf31ce446812d89f4967b601f122d344;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 31330f6..50a9dcd 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -14,7 +14,7 @@ import RnExpr import HsSyn import HscTypes ( GlobalRdrEnv ) import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars @@ -35,7 +35,7 @@ import RnMonad import Class ( FunDep, DefMeth (..) ) import DataCon ( dataConId ) -import Name ( Name, OccName, nameOccName, NamedThing(..) ) +import Name ( Name, NamedThing(..) ) import NameSet import PrelInfo ( derivableClassKeys, cCallishClassKeys ) import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, @@ -48,6 +48,7 @@ import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) +import Maybes ( maybeToBool ) import ErrUtils ( Message ) import CStrings ( isCLabelString ) import ListSetOps ( removeDupsEq ) @@ -71,7 +72,7 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* %* * -\subsection{Value declarations} +\subsection{Source code declarations} %* * %********************************************************* @@ -82,7 +83,7 @@ rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv -- The decls get reversed, but that's ok rnSourceDecls gbl_env local_fixity_env decls - = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls) + = initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) where -- Fixity and deprecations have been dealt with already; ignore them go fvs ds' [] = returnRn (ds', fvs) @@ -90,32 +91,21 @@ rnSourceDecls gbl_env local_fixity_env decls go fvs ds' (DeprecD _:ds) = go fvs ds' ds go fvs ds' (d:ds) = rnSourceDecl d `thenRn` \(d', fvs') -> go (fvs `plusFV` fvs') (d':ds') ds -\end{code} -%********************************************************* -%* * -\subsection{Value declarations} -%* * -%********************************************************* - -\begin{code} --- rnSourceDecl does all the work rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) rnSourceDecl (TyClD tycl_decl) - = rnTyClDecl tycl_decl `thenRn` \ new_decl -> - rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> - traceRn (text "rnClassDecl:" <+> (ppr (nameSetToList (tyClDeclFVs new_decl')) $$ - ppr (nameSetToList fvs))) `thenRn_` + = rnTyClDecl tycl_decl `thenRn` \ new_decl -> + finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') rnSourceDecl (InstD inst) - = rnInstDecl inst `thenRn` \ new_inst -> - rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) -> + = rnInstDecl inst `thenRn` \ new_inst -> + finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) -> returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') rnSourceDecl (RuleD rule) @@ -166,6 +156,7 @@ rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) \begin{code} rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) + -- Used for both source and interface file decls = pushSrcLocRn src_loc $ rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' -> @@ -178,10 +169,12 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) -- The typechecker checks that all the bindings are for the right class. returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) --- Compare rnClassBinds -rnInstBinds (InstDecl _ mbinds uprags _ _ ) - (InstDecl inst_ty _ _ maybe_dfun_rdr_name src_loc) - = let +-- Compare finishSourceTyClDecl +finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) + (InstDecl inst_ty _ _ maybe_dfun_name src_loc) + -- Used for both source decls only + = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl! + let meth_doc = text "the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds inst_tyvars = case inst_ty of @@ -212,7 +205,7 @@ rnInstBinds (InstDecl _ mbinds uprags _ _ ) renameSigsFVs (okInstDclSig binder_set) uprags ) `thenRn` \ (uprags', prag_fvs) -> - returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc, + returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, meth_fvs `plusFV` prag_fvs) \end{code} @@ -293,7 +286,7 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, - tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names}) + tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> @@ -301,10 +294,9 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, 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'}) + tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'}) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls @@ -323,11 +315,12 @@ rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLo -- 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 + unquantify glaExts ty = ty rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdSysNames = names, tcdLoc = src_loc}) + -- Used for both source and interface file decls = pushSrcLocRn src_loc $ lookupTopBndrRn cname `thenRn` \ cname' -> @@ -396,17 +389,18 @@ rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) 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 +finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) + -- Used for source file decls only + -- Renames the default-bindings of a class decl + -- the derivings of a data decl +finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Derivings in here + rn_ty_decl -- Everything else is here + = pushSrcLocRn src_loc $ + mapRn rnDeriv derivs `thenRn` \ derivs' -> + returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs') + +finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here + rn_cls_decl@(ClassDecl {tcdTyVars = tyvars}) -- 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 @@ -418,6 +412,7 @@ rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. -- Hence the + pushSrcLocRn src_loc $ extendTyVarEnvFVRn (map hsTyVarName tyvars) $ getLocalNameEnv `thenRn` \ name_env -> let @@ -432,7 +427,7 @@ rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here where meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl) -rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) +finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) -- Not a class declaration \end{code} @@ -444,19 +439,12 @@ rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) %********************************************************* \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name]) - -rnDerivs Nothing -- derivs not specified - = returnRn Nothing - -rnDerivs (Just clss) - = mapRn do_one clss `thenRn` \ clss' -> - returnRn (Just clss') - where - do_one cls = lookupOccRn cls `thenRn` \ clas_name -> - checkRn (getUnique clas_name `elem` derivableClassKeys) - (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name +rnDeriv :: RdrName -> RnMS Name +rnDeriv cls + = lookupOccRn cls `thenRn` \ clas_name -> + checkRn (getUnique clas_name `elem` derivableClassKeys) + (derivingNonStdClassErr clas_name) `thenRn_` + returnRn clas_name \end{code} \begin{code} @@ -645,13 +633,17 @@ rnForAll doc forall_tyvars ctxt ty rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext rnContext doc ctxt = mapRn rn_pred ctxt `thenRn` \ theta -> - let - (_, dups) = removeDupsEq theta - -- We only have equality, not ordering - in + -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_` + ifOptRn Opt_WarnMisc ( + let + (_, dups) = removeDupsEq theta + -- We only have equality, not ordering + in + mapRn (addWarnRn . dupClassAssertWarn theta) dups + ) `thenRn_` + returnRn theta where --Someone discovered that @CCallable@ and @CReturnable@ @@ -664,19 +656,19 @@ rnContext doc ctxt (naughtyCCallContextErr pred') `thenRn_` returnRn pred' - bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys + bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys bad_pred other = False -rnPred doc (HsPClass clas tys) +rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenRn` \ clas_name -> rnHsTypes doc tys `thenRn` \ tys' -> - returnRn (HsPClass clas_name tys') + returnRn (HsClassP clas_name tys') -rnPred doc (HsPIParam n ty) +rnPred doc (HsIParam n ty) = newIPName n `thenRn` \ name -> rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsPIParam name ty') + returnRn (HsIParam name ty') \end{code} \begin{code} @@ -701,9 +693,9 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar %********************************************************* \begin{code} -rnIdInfo (HsWorker worker) +rnIdInfo (HsWorker worker arity) = lookupOccRn worker `thenRn` \ worker' -> - returnRn (HsWorker worker') + returnRn (HsWorker worker' arity) rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> returnRn (HsUnfold inline expr') @@ -866,11 +858,9 @@ badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] forAllWarn doc ty tyvar - = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of - () | not warn_unused -> returnRn () - | otherwise - -> getModeRn `thenRn` \ mode -> - case mode of { + = ifOptRn Opt_WarnUnusedMatches $ + getModeRn `thenRn` \ mode -> + case mode of { #ifndef DEBUG InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files -- unless DEBUG is on, in which case it is slightly @@ -906,7 +896,7 @@ dupClassAssertWarn ctxt (assertion : dups) ptext SLIT("in the context:")], nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] -naughtyCCallContextErr (HsPClass clas _) +naughtyCCallContextErr (HsClassP clas _) = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), ptext SLIT("in a context")] \end{code}