X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=47abf232e23181fe556aa754bd1052d9dc5b8862;hp=4c1da58d8f7af458c28425fa73493e778f969479;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=4186a2d5ae04d985fe141a8701fd75d05760f7f7 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 4c1da58..47abf23 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -44,6 +44,7 @@ module RdrHsSyn ( checkMDo, -- [Stmt] -> P [Stmt] checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkDoAndIfThenElse, parseError, parseErrorSDoc, ) where @@ -54,7 +55,7 @@ import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..) ) + InlinePragma(..), InlineSpec(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -126,7 +127,8 @@ extract_lty (L loc ty) acc HsPredTy p -> extract_pred p acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc - HsNumTy _ -> acc + HsNumTy {} -> acc + HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc @@ -362,7 +364,7 @@ splitCon ty split (L _ (HsAppTy t u)) ts = split t (u : ts) split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc return (data_con, mk_rest ts) - split (L l _) _ = parseError l "parse error in data/newtype declaration" + split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts @@ -479,7 +481,7 @@ checkDictTy (L spn ty) = check ty [] check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args - check _ _ = parseError spn "Malformed instance header" + check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty) done tc args = return (L spn (HsPredTy (HsClassP tc args))) @@ -522,15 +524,19 @@ checkTyVars tparms = mapM chk tparms | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) - chk (L l _) = - parseError l "Type found where type variable expected" + chk t@(L l _) = + parseErrorSDoc l (text "Type found:" <+> ppr t + $$ text "where type variable expected, in:" <+> + sep (map (pprParendHsType . unLoc) tparms)) checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () checkDatatypeContext Nothing = return () -checkDatatypeContext (Just (L loc _)) +checkDatatypeContext (Just (L loc c)) = do allowed <- extension datatypeContextsEnabled unless allowed $ - parseError loc "Illegal datatype context (use -XDatatypeContexts)" + parseErrorSDoc loc + (text "Illegal datatype context (use -XDatatypeContexts):" <+> + pprHsContext c) checkTyClHdr :: LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) @@ -551,7 +557,7 @@ checkTyClHdr ty | isRdrTc tc = return (ltc, t1:t2:acc) go _ (HsParTy ty) acc = goL ty acc go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) - go l _ _ = parseError l "Malformed head of type or class declaration" + go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -- Check that associated type declarations of a class are all kind signatures. -- @@ -562,7 +568,7 @@ checkKindSigs = mapM_ check | isFamilyDecl tydecl || isSynDecl tydecl = return () | otherwise = - parseError l "Type declaration in a class must be a kind signature or synonym default" + parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl) checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l t) @@ -602,8 +608,8 @@ checkPred (L spn ty) check _loc (HsAppTy l r) args = checkl l (r:args) check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args) check _loc (HsParTy t) args = checkl t args - check loc _ _ = parseError loc - "malformed class assertion" + check loc _ _ = parseErrorSDoc loc + (text "malformed class assertion:" <+> ppr ty) --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -619,14 +625,16 @@ checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") +checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) checkDoMDo pre nm _ ss = do check ss where check [] = panic "RdrHsSyn:checkDoMDo" check [L _ (ExprStmt e _ _)] = return ([], e) - check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression") + check [L l e] = parseErrorSDoc l + (text ("The last statement in " ++ pre ++ nm ++ + " construct must be an expression:") + $$ ppr e) check (s:ss) = do (ss',e') <- check ss return ((s:ss'),e') @@ -661,11 +669,11 @@ checkPat loc (L _ e) [] = do { pState <- getPState ; p <- checkAPat (dflags pState) loc e ; return (L loc p) } -checkPat loc _ _ - = patFail loc +checkPat loc e _ + = patFail loc (unLoc e) checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) -checkAPat dynflags loc e = case e of +checkAPat dynflags loc e0 = case e0 of EWildPat -> return (WildPat placeHolderType) HsVar x -> return (VarPat x) HsLit l -> return (LitPat l) @@ -681,7 +689,7 @@ checkAPat dynflags 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 -XBangPatterns)" } + else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) } ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) @@ -699,7 +707,7 @@ checkAPat dynflags loc e = case e of -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) + | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) lit) OpApp l op _fix r -> do l <- checkLPat l @@ -707,7 +715,7 @@ checkAPat dynflags loc e = case e of case op of L cl (HsVar c) | isDataOcc (rdrNameOcc c) -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail loc + _ -> patFail loc e0 HsPar e -> checkLPat e >>= (return . ParPat) ExplicitList _ es -> do ps <- mapM checkLPat es @@ -718,7 +726,7 @@ checkAPat dynflags loc e = case e of ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es] return (TuplePat ps b placeHolderType) - | otherwise -> parseError loc "Illegal tuple section in pattern" + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) RecordCon c _ (HsRecFields fs dd) -> do fs <- mapM checkPatField fs @@ -726,7 +734,7 @@ checkAPat dynflags loc e = case e of HsQuasiQuoteE q -> return (QuasiQuotePat q) -- Generics HsType ty -> return (TypePat ty) - _ -> patFail loc + _ -> patFail loc e0 placeHolderPunRhs :: LHsExpr RdrName -- The RHS of a punned record field will be filled in by the renamer @@ -742,8 +750,8 @@ checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName ( checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = p }) } -patFail :: SrcSpan -> P a -patFail loc = parseError loc "Parse error in pattern" +patFail :: SrcSpan -> HsExpr RdrName -> P a +patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e) --------------------------------------------------------------------------- @@ -815,6 +823,27 @@ checkValSig lhs@(L l _) ty looks_like_foreign _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") + +checkDoAndIfThenElse :: LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> P () +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse + = do pState <- getPState + unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do + parseErrorSDoc (combineLocs guardExpr elseExpr) + (text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use -XDoAndIfThenElse?") + | otherwise = return () + where pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> + text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + text "else" <+> ppr elseExpr \end{code} @@ -889,7 +918,8 @@ isFunLhs e = go e [] checkPrecP :: Located Int -> P Int checkPrecP (L l i) | 0 <= i && i <= maxPrecedence = return i - | otherwise = parseError l "Precedence out of range" + | otherwise + = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) mkRecConstrOrUpdate :: LHsExpr RdrName @@ -900,16 +930,16 @@ mkRecConstrOrUpdate mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp loc (fs,dd) - | null fs = parseError loc "Empty record update" + | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp) | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma +mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma -- The Maybe is because the user can omit the activation spec (and usually does) -mkInlinePragma mb_act match_info inl +mkInlinePragma (inl, match_info) mb_act = InlinePragma { inl_inline = inl , inl_sat = Nothing , inl_act = act @@ -917,11 +947,10 @@ mkInlinePragma mb_act match_info inl where act = case mb_act of Just act -> act - Nothing | inl -> AlwaysActive - | otherwise -> NeverActive - -- If no specific phase is given then: - -- NOINLINE => NeverActive - -- INLINE => Active + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -940,7 +969,7 @@ mkImport cconv safety (L loc entity, v, ty) | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of - Nothing -> parseError loc "Malformed entity string" + Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> return (ForD (ForeignImport v ty importSpec)) -- the string "foo" is ambigous: either a header or a C identifier. The