projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
f59d6c9
)
Fix Trac #2114: error reporting for 'forall' without appropriate flags
author
simonpj@microsoft.com
<unknown>
Fri, 22 Feb 2008 18:26:46 +0000
(18:26 +0000)
committer
simonpj@microsoft.com
<unknown>
Fri, 22 Feb 2008 18:26:46 +0000
(18:26 +0000)
compiler/parser/Lexer.x
patch
|
blob
|
history
compiler/parser/RdrHsSyn.lhs
patch
|
blob
|
history
compiler/prelude/PrelNames.lhs
patch
|
blob
|
history
compiler/rename/RnEnv.lhs
patch
|
blob
|
history
compiler/rename/RnTypes.lhs
patch
|
blob
|
history
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)
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)
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 )
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 )
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
| 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
----------------------------------------------------------------------------
-- 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)
-> 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
| 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
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}
\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
#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,
import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual )
import Unique ( Unique, Uniquable(..), hasKey,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
@@
-322,10
+322,14
@@
mkTupleModule Unboxed _ = gHC_PRIM
%************************************************************************
\begin{code}
%************************************************************************
\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
-- 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("/=")
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,
mapFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, unknownNameErr,
+ dataTcOccs, unknownNameErr
) where
#include "HsVersions.h"
) 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 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,
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
$$ 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"
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 )
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 TcRnMonad
+import ErrUtils
import RdrName
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
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')
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 $
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
; 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)
$$
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))
= 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}
\end{code}