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 )
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 )
= 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
| 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
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))
| 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)
-- 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)
_ -> 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)
-> 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
-> 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
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
-- 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}