X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=a9433441e81ed4c7f0c8e53758efb6ca765a8ff1;hp=7d806ed174a173f9cc82fb6ab87f7d09a700d48e;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 7d806ed..a943344 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -40,8 +40,7 @@ module RdrHsSyn ( checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] - checkDo, -- [Stmt] -> P [Stmt] - checkMDo, -- [Stmt] -> P [Stmt] + checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -54,8 +53,9 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..) ) + InlinePragma(..), InlineSpec(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -127,7 +127,6 @@ 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 HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables @@ -152,8 +151,7 @@ extractGenericPatTyVars binds get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms get _ acc = acc - get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m _ acc = acc + get_m _ acc = acc \end{code} @@ -611,34 +609,6 @@ checkPred (L spn ty) check loc _ _ = parseErrorSDoc loc (text "malformed class assertion:" <+> ppr ty) ---------------------------------------------------------------------------- --- Checking statements in a do-expression --- We parse do { e1 ; e2 ; } --- as [ExprStmt e1, ExprStmt e2] --- checkDo (a) checks that the last thing is an ExprStmt --- (b) returns it separately --- same comments apply for mdo as well - -checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) - -checkDo = checkDoMDo "a " "'do'" -checkMDo = checkDoMDo "an " "'mdo'" - -checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -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 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') - -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -707,7 +677,7 @@ checkAPat dynflags loc e0 = case e0 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 @@ -732,8 +702,6 @@ checkAPat dynflags loc e0 = case e0 of -> do fs <- mapM checkPatField fs return (ConPatIn c (RecCon (HsRecFields fs dd))) HsQuasiQuoteE q -> return (QuasiQuotePat q) --- Generics - HsType ty -> return (TypePat ty) _ -> patFail loc e0 placeHolderPunRhs :: LHsExpr RdrName @@ -812,17 +780,20 @@ checkValSig lhs@(L l _) ty ppr lhs <+> text "::" <+> ppr ty) $$ text hint) where - hint = if looks_like_foreign lhs + hint = if foreign_RDR `looks_like` lhs then "Perhaps you meant to use -XForeignFunctionInterface?" - else "Should be of form :: " + else if default_RDR `looks_like` lhs + then "Perhaps you meant to use -XDefaultSignatures?" + else "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR - looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs - looks_like_foreign _ = False + looks_like s (L _ (HsVar v)) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") checkDoAndIfThenElse :: LHsExpr RdrName -> Bool @@ -833,7 +804,7 @@ checkDoAndIfThenElse :: LHsExpr RdrName checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do pState <- getPState - unless (dopt Opt_DoAndIfThenElse (dflags pState)) $ do + unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do parseErrorSDoc (combineLocs guardExpr elseExpr) (text "Unexpected semi-colons in conditional:" $$ nest 4 expr @@ -912,6 +883,20 @@ isFunLhs e = go e [] _ -> return Nothing } go _ _ = return Nothing + +--------------------------------------------------------------------------- +-- Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a `MonadComp' context, +-- otherwise use the usual `ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + --------------------------------------------------------------------------- -- Miscellaneous utilities @@ -937,9 +922,9 @@ 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 @@ -947,11 +932,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