From d19a72ea089deab3aa4bb584e69c102daebb1cb4 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 22 Feb 2008 18:26:46 +0000 Subject: [PATCH] Fix Trac #2114: error reporting for 'forall' without appropriate flags --- compiler/parser/Lexer.x | 4 ++-- compiler/parser/RdrHsSyn.lhs | 17 +++++++++++++---- compiler/prelude/PrelNames.lhs | 10 +++++++--- compiler/rename/RnEnv.lhs | 16 +++++++++++----- compiler/rename/RnTypes.lhs | 37 ++++++++++++++++++++++--------------- 5 files changed, 55 insertions(+), 29 deletions(-) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 1692904..4042a9c 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1435,8 +1435,8 @@ failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg) failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str) -failSpanMsgP :: SrcSpan -> String -> P a -failSpanMsgP span msg = P $ \_ -> PFailed span (text msg) +failSpanMsgP :: SrcSpan -> SDoc -> P a +failSpanMsgP span msg = P $ \_ -> PFailed span msg extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 3697819..e3bb369 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -73,6 +73,7 @@ import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) +import PrelNames ( forall_tv_RDR ) import SrcLoc import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) @@ -401,7 +402,12 @@ tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + = parseErrorSDoc loc (msg $$ extra) + where + msg = text "Not a data constructor:" <+> quotes (ppr tc) + extra | tc == forall_tv_RDR + = text "Perhaps you intended to use -XExistentialQuantification" + | otherwise = empty ---------------------------------------------------------------------------- -- Various Syntactic Checks @@ -770,8 +776,8 @@ checkFunBind :: SrcSpan -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) | isQual (unLoc fun) - = parseError (getLoc fun) ("Qualified name in function definition: " ++ - showRdrName (unLoc fun)) + = parseErrorSDoc (getLoc fun) + (ptext SLIT("Qualified name in function definition:") <+> ppr (unLoc fun)) | otherwise = do ps <- checkPatterns pats let match_span = combineSrcSpans lhs_loc rhs_span @@ -1070,5 +1076,8 @@ showRdrName :: RdrName -> String showRdrName r = showSDoc (ppr r) parseError :: SrcSpan -> String -> P a -parseError span s = failSpanMsgP span s +parseError span s = parseErrorSDoc span (text s) + +parseErrorSDoc :: SrcSpan -> SDoc -> P a +parseErrorSDoc span s = failSpanMsgP span s \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index bffd07c..8f06f50 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -57,8 +57,8 @@ module PrelNames ( #include "HsVersions.h" import Module -import OccName ( dataName, tcName, clsName, varName, mkOccNameFS, - mkVarOccFS ) +import OccName ( dataName, tcName, clsName, varName, tvName, + mkOccNameFS, mkVarOccFS ) import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, @@ -322,10 +322,14 @@ mkTupleModule Unboxed _ = gHC_PRIM %************************************************************************ \begin{code} -main_RDR_Unqual = mkUnqual varName FSLIT("main") +main_RDR_Unqual = mkUnqual varName FSLIT("main") -- We definitely don't want an Orig RdrName, because -- main might, in principle, be imported into module Main +forall_tv_RDR, dot_tv_RDR :: RdrName +forall_tv_RDR = mkUnqual tvName FSLIT("forall") +dot_tv_RDR = mkUnqual tvName FSLIT(".") + eq_RDR = nameRdrName eqName ge_RDR = nameRdrName geName ne_RDR = varQual_RDR gHC_BASE FSLIT("/=") diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 47595e2..59451fc 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -36,7 +36,7 @@ module RnEnv ( mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, + dataTcOccs, unknownNameErr ) where #include "HsVersions.h" @@ -60,7 +60,8 @@ import DataCon ( dataConFieldLabels ) import OccName ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused, occNameFS ) import Module ( Module, ModuleName ) -import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, + consDataConKey, hasKey, forall_tv_RDR ) import UniqSupply import BasicTypes ( IPName, mapIPName, Fixity ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, @@ -1018,9 +1019,14 @@ shadowedNameWarn doc occ shadowed_locs $$ doc unknownNameErr rdr_name - = sep [ptext SLIT("Not in scope:"), - nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)] + = vcat [ hang (ptext SLIT("Not in scope:")) + 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)) + , extra ] + where + extra | rdr_name == forall_tv_RDR + = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag") + | otherwise = empty unknownSubordinateErr doc op -- Doc is "method of class" or -- "field of constructor" diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index dd1851d..e6d2ffc 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -28,18 +28,11 @@ import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, listTyCon_name ) import RnHsDoc ( rnLHsDoc ) -import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, - lookupLocatedOccRn, lookupLocatedBndrRn, - lookupLocatedGlobalOccRn, bindTyVarsRn, - lookupFixityRn, lookupTyFixityRn, lookupConstructorFields, - lookupRecordBndr, mapFvRn, - newIPNameRn, bindPatSigTyVarsFV) +import RnEnv import TcRnMonad +import ErrUtils import RdrName -import PrelNames ( eqClassName, integralClassName, geName, eqName, - negateName, minusName, lengthPName, indexPName, - plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName, fromStringName ) +import PrelNames import TypeRep ( funTyCon ) import Constants ( mAX_TUPLE_SIZE ) import Name @@ -121,11 +114,16 @@ rnHsType doc (HsTyVar tyvar) = do tyvar' <- lookupOccRn tyvar return (HsTyVar tyvar') +-- If we see (forall a . ty), without foralls on, the forall will give +-- a sensible error message, but we don't want to complain about the dot too +-- Hence the jiggery pokery with ty1 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) = setSrcSpan loc $ - do { ty_ops_ok <- doptM Opt_TypeOperators - ; checkErr ty_ops_ok (opTyErr op ty) - ; op' <- lookupOccRn op + do { ops_ok <- doptM Opt_TypeOperators + ; op' <- if ops_ok + then lookupOccRn op + else do { addErr (opTyErr op ty) + ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' ; ty1' <- rnLHsType doc ty1 @@ -532,7 +530,16 @@ forAllWarn doc ty (L loc tyvar) $$ doc) -opTyErr op ty +opTyErr op ty@(HsOpTy ty1 _ ty2) = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty)) - 2 (parens (ptext SLIT("Use -XTypeOperators to allow operators in types"))) + 2 extra + where + extra | op == dot_tv_RDR && forall_head ty1 + = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag") + | otherwise + = ptext SLIT("Use -XTypeOperators to allow operators in types") + + forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR + forall_head (L _ (HsAppTy ty _)) = forall_head ty + forall_head _other = False \end{code} -- 1.7.10.4