X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=50c9ee59a46672cf7c479e1f6657ce5695f38576;hb=f6cd95ff9a2bddbd78682dcd9287aec7d152cc13;hp=31330f6f76a4e0981f0b8f5a81c36d84cbc00034;hpb=5a763550bf31ce446812d89f4967b601f122d344;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 31330f6..50c9ee5 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,8 +48,7 @@ import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) -import ErrUtils ( Message ) -import CStrings ( isCLabelString ) +import Maybes ( maybeToBool ) import ListSetOps ( removeDupsEq ) \end{code} @@ -71,7 +70,7 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* %* * -\subsection{Value declarations} +\subsection{Source code declarations} %* * %********************************************************* @@ -82,7 +81,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,71 +89,65 @@ 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) = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) -> returnRn (RuleD new_rule, fvs) +rnSourceDecl (ForD ford) + = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) -> + returnRn (ForD new_ford, fvs) + rnSourceDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) -> returnRn (DefD (DefaultDecl tys' src_loc), fvs) where - doc_str = text "a `default' declaration" + doc_str = text "In a `default' declaration" +\end{code} -rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) - = pushSrcLocRn src_loc $ - lookupOccRn name `thenRn` \ name' -> - let - extra_fvs FoExport - | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR, - bindIO_RDR, returnIO_RDR] - | otherwise = - lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs -> - returnRn (addOneFV fvs name') - extra_fvs other = returnRn emptyFVs - in - checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` - extra_fvs imp_exp `thenRn` \ fvs1 -> +%********************************************************* +%* * +\subsection{Foreign declarations} +%* * +%********************************************************* + +\begin{code} +rnHsForeignDecl (ForeignImport name ty spec src_loc) + = pushSrcLocRn src_loc $ + lookupOccRn name `thenRn` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> + lookupOrigNames (extras spec) `thenRn` \ fvs2 -> + returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2) + where + extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR] + extras other = [] - rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) -> - returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), - fvs1 `plusFV` fvs2) - where - fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name - isDyn = isDynamicExtName ext_nm +rnHsForeignDecl (ForeignExport name ty spec src_loc) + = pushSrcLocRn src_loc $ + lookupOccRn name `thenRn` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> + lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 -> + returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2) - ok_ext_nm Dynamic = True - ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb - ok_ext_nm (ExtName nm Nothing) = isCLabelString nm +fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name \end{code} @@ -166,6 +159,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,11 +172,13 @@ 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 - meth_doc = text "the bindings in an instance declaration" +-- 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 "In the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds inst_tyvars = case inst_ty of HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars @@ -212,7 +208,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} @@ -250,7 +246,7 @@ rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc, fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where - doc = text "the transformation rule" <+> ptext rule_name + doc = text "In the transformation rule" <+> ptext rule_name sig_tvs = extractRuleBndrsTyVars vars get_var (RuleBndr v) = v @@ -289,24 +285,39 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc 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) + doc_str = text "In the interface signature for" <+> quotes (ppr name) + +rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) + = pushSrcLocRn loc $ + lookupTopBndrRn name `thenRn` \ name' -> + returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) 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' -> rnContext data_doc context `thenRn` \ context' -> checkDupOrQualNames data_doc con_names `thenRn_` + + -- Check that there's at least one condecl, + -- or else we're reading an interface file, or -fglasgow-exts + (if null condecls then + doptRn Opt_GlasgowExts `thenRn` \ glaExts -> + getModeRn `thenRn` \ mode -> + checkRn (glaExts || isInterfaceMode mode) + (emptyConDeclsErr tycon) + else returnRn () + ) `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) + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) @@ -317,17 +328,18 @@ rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLo 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) + syn_doc = text "In 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 + 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' -> @@ -369,8 +381,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 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 + cls_doc = text "In the declaration for class" <+> ppr cname + sig_doc = text "In the signatures for class" <+> ppr cname rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) = pushSrcLocRn locn $ @@ -396,17 +408,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 +431,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 @@ -430,10 +444,10 @@ rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here 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) + meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) -rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) - -- Not a class declaration +finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) + -- Not a class or data type declaration \end{code} @@ -444,19 +458,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} @@ -477,7 +484,7 @@ rnConDecl (ConDecl name wkr tvs cxt details locn) rnConDetails doc locn details `thenRn` \ new_details -> returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn) where - doc = text "the definition of data constructor" <+> quotes (ppr name) + doc = text "In the definition of data constructor" <+> quotes (ppr name) rnConDetails doc locn (VanillaCon tys) = mapRn (rnBangTy doc) tys `thenRn` \ new_tys -> @@ -500,17 +507,9 @@ rnField doc (names, ty) rnBangTy doc ty `thenRn` \ new_ty -> returnRn (new_names, new_ty) -rnBangTy doc (Banged ty) +rnBangTy doc (BangType s ty) = rnHsType doc ty `thenRn` \ new_ty -> - returnRn (Banged new_ty) - -rnBangTy doc (Unbanged ty) - = rnHsType doc ty `thenRn` \ new_ty -> - returnRn (Unbanged new_ty) - -rnBangTy doc (Unpacked ty) - = rnHsType doc ty `thenRn` \ new_ty -> - returnRn (Unpacked new_ty) + returnRn (BangType s new_ty) -- This data decl will parse OK -- data T = a Int @@ -549,7 +548,7 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty - = rnHsType (text "the type signature for" <+> doc_str) ty + = rnHsType (text "In the type signature for" <+> doc_str) ty --------------------------------------- rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType @@ -645,13 +644,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 +667,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,16 +704,15 @@ 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') rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) rnIdInfo (HsArity arity) = returnRn (HsArity arity) rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs -rnIdInfo HsCprInfo = returnRn HsCprInfo \end{code} @UfCore@ expressions. @@ -731,9 +733,9 @@ rnCoreExpr (UfLitLit l ty) = rnHsType (text "litlit") ty `thenRn` \ ty' -> returnRn (UfLitLit l ty') -rnCoreExpr (UfCCall cc ty) +rnCoreExpr (UfFCall cc ty) = rnHsType (text "ccall") ty `thenRn` \ ty' -> - returnRn (UfCCall cc ty') + returnRn (UfFCall cc ty') rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) = mapRn rnCoreExpr args `thenRn` \ args' -> @@ -846,6 +848,7 @@ not one of the @forall@'d variables. validRuleLhs foralls lhs = check lhs where + check (OpApp _ op _ _) = check op check (HsApp e1 e2) = check e1 check (HsVar v) | v `notElem` foralls = True check other = False @@ -866,11 +869,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 @@ -881,7 +882,7 @@ forAllWarn doc ty tyvar sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ - (ptext SLIT("In") <+> doc) + doc ) } @@ -892,21 +893,20 @@ badRuleLhsErr name lhs ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") badRuleVar name var - = sep [ptext SLIT("Rule") <+> ptext name <> colon, + = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon, ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> ptext SLIT("does not appear on left hand side")] -badExtName :: ExtName -> Message -badExtName ext_nm - = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")] - dupClassAssertWarn ctxt (assertion : dups) = sep [hsep [ptext SLIT("Duplicate class assertion"), quotes (ppr assertion), 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")] +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code}