Fix Trac #2114: error reporting for 'forall' without appropriate flags

5 files changed, 55 insertions, 29 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 1692904223..4042a9c518 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 3697819afb..e3bb3696bb 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 bffd07c7d4..8f06f504a5 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 47595e2a89..59451fc535 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 dd1851da76..e6d2ffc873 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}