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

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 1692904..4042a9c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}