X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=64de0f5fe37d8e3cfc4bf5b39222990e9c0aa367;hb=e4db45612e3efa59251239e1e0b8a0440783b966;hp=2fb494ed339b1ddfd3b092cd6b3047d4d07fcf2b;hpb=43a0864f6edd5d2b626dbeb592d1449b066ca90d;p=ghc-hetmet.git

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 2fb494e..64de0f5 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -58,8 +58,6 @@ module RdrHsSyn (
 	parseError,	      -- String -> Pa
     ) where
 
-#include "HsVersions.h"
-
 import HsSyn		-- Lots of it
 import Class            ( FunDep )
 import TypeRep          ( Kind )
@@ -73,6 +71,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 +400,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
@@ -515,7 +519,9 @@ checkTyClHdr (L l cxt) ty
 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))
@@ -712,12 +718,12 @@ checkAPat loc e = case e of
                                _ -> 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)
-   ExplicitPArr _ es  -> do ps <- mapM (\e -> checkLPat e) es
+   ExplicitPArr _ es  -> do ps <- mapM checkLPat es
                             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)
@@ -729,8 +735,8 @@ checkAPat loc e = case e of
    _                  -> patFail loc
 
 plus_RDR, bang_RDR :: RdrName
-plus_RDR = mkUnqual varName FSLIT("+")	-- Hack
-bang_RDR = mkUnqual varName FSLIT("!")	-- Hack
+plus_RDR = mkUnqual varName (fsLit "+")	-- Hack
+bang_RDR = mkUnqual varName (fsLit "!")	-- Hack
 
 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 checkPatField fld = do	{ p <- checkLPat (hsRecFieldArg fld)
@@ -768,8 +774,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
@@ -951,9 +957,9 @@ parseCImport :: Located FastString
 	     -> P ForeignImport
 parseCImport (L loc entity) cconv safety v
   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
-  | entity == FSLIT ("dynamic") = 
+  | entity == fsLit "dynamic" = 
     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
-  | entity == FSLIT ("wrapper") =
+  | entity == fsLit "wrapper" =
     return $ CImport cconv safety nilFS nilFS CWrapper
   | otherwise		       = parse0 (unpackFS entity)
     where
@@ -1021,6 +1027,7 @@ parseDImport (L loc entity) = parse0 comps
   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
@@ -1067,5 +1074,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}