projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trac #2114: error reporting for 'forall' without appropriate flags
[ghc-hetmet.git]
/
compiler
/
parser
/
RdrHsSyn.lhs
diff --git
a/compiler/parser/RdrHsSyn.lhs
b/compiler/parser/RdrHsSyn.lhs
index
2fb494e
..
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
@@
-515,7
+521,9
@@
checkTyClHdr (L l cxt) ty
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
extractTyVars tvs = collects tvs []
where
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
extractTyVars tvs = collects tvs []
where
- -- Collect all variables (1st arg serves as an accumulator)
+ -- Collect all variables (2nd arg serves as an accumulator)
+ collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
+ -> P [LHsTyVarBndr RdrName]
collect (L l (HsForAllTy _ _ _ _)) =
const $ parseError l "Forall type not allowed as type parameter"
collect (L l (HsTyVar tv))
collect (L l (HsForAllTy _ _ _ _)) =
const $ parseError l "Forall type not allowed as type parameter"
collect (L l (HsTyVar tv))
@@
-712,12
+720,12
@@
checkAPat loc e = case e of
_ -> patFail loc
HsPar e -> checkLPat e >>= (return . ParPat)
_ -> patFail loc
HsPar e -> checkLPat e >>= (return . ParPat)
- ExplicitList _ es -> do ps <- mapM (\e -> checkLPat e) es
+ ExplicitList _ es -> do ps <- mapM checkLPat es
return (ListPat ps placeHolderType)
return (ListPat ps placeHolderType)
- ExplicitPArr _ es -> do ps <- mapM (\e -> checkLPat e) es
+ ExplicitPArr _ es -> do ps <- mapM checkLPat es
return (PArrPat ps placeHolderType)
return (PArrPat ps placeHolderType)
- ExplicitTuple es b -> do ps <- mapM (\e -> checkLPat e) es
+ ExplicitTuple es b -> do ps <- mapM checkLPat es
return (TuplePat ps b placeHolderType)
RecordCon c _ (HsRecFields fs dd)
return (TuplePat ps b placeHolderType)
RecordCon c _ (HsRecFields fs dd)
@@
-768,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
@@
-1021,6
+1029,7
@@
parseDImport (L loc entity) = parse0 comps
parse2 _ _ [] = d'oh
parse2 isStatic kind (('[':x):xs) =
case x of
parse2 _ _ [] = d'oh
parse2 isStatic kind (('[':x):xs) =
case x of
+ [] -> d'oh
vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
_ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
_ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
@@
-1067,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}