X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=e875bf5bf53dc4f1bfad5603f87d2fd2dc4a4dff;hb=058f3b6f29e9f5f5f42d9ee28ec6326e8f8e74a5;hp=2fb494ed339b1ddfd3b092cd6b3047d4d07fcf2b;hpb=43a0864f6edd5d2b626dbeb592d1449b066ca90d;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 2fb494e..e875bf5 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -58,14 +58,12 @@ module RdrHsSyn ( parseError, -- String -> Pa ) where -#include "HsVersions.h" - import HsSyn -- Lots of it import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) + setRdrNameSpace, showRdrName ) import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) import TysWiredIn ( unitTyCon ) @@ -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 ) @@ -348,8 +347,8 @@ add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds = addl (gp { hs_defds = L l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds - = addl (gp { hs_depds = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds @@ -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)) @@ -683,7 +689,7 @@ checkAPat loc e = case e of | bang == bang_RDR -> do { bang_on <- extension bangPatEnabled ; if bang_on then checkLPat e >>= (return . BangPat) - else parseError loc "Illegal bang-pattern (use -fbang-patterns)" } + else parseError loc "Illegal bang-pattern (use -XBangPatterns)" } ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) @@ -700,7 +706,7 @@ checkAPat loc e = case e of -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ - (L _ (HsOverLit lit@(HsIntegral _ _ _))) + (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | plus == plus_RDR -> return (mkNPlusKPat (L nloc n) lit) @@ -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 @@ -1063,9 +1070,9 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -- Misc utils \begin{code} -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}