From: simonpj@microsoft.com Date: Thu, 27 Jan 2011 13:13:04 +0000 (+0000) Subject: Refine incomplete-pattern checks (Trac #4905) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a0f6d307b097bd788e181434a4d9b7fdd56a6c6b Refine incomplete-pattern checks (Trac #4905) The changes are: * New flag -fwarn-incomplete-uni-patterns, which checks for incomplete patterns in (a) lambdas, (b) pattern bindings * New flag is not implied by -W or -Wall (too noisy; and many libraries use incomplete pattern bindings) * Actually do the incomplete-pattern check for pattern bindings (previously simply omitted) * Documentation for new flag --- diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index be697fa..a7260e2 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -75,7 +75,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) - = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty + = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty \end{code} @@ -87,7 +87,7 @@ dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) \begin{code} matchGuards :: [Stmt Id] -- Guard - -> HsMatchContext Name -- Context + -> HsStmtContext Name -- Context -> LHsExpr Id -- RHS -> Type -- Type of RHS of guard -> DsM MatchResult @@ -126,7 +126,7 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs - matchSinglePat core_rhs ctx pat rhs_ty match_result + matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 9d7e124..5c6b224 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -38,6 +38,7 @@ import Name import Outputable import FastString +import Control.Monad( when ) import qualified Data.Map as Map \end{code} @@ -55,9 +56,9 @@ matchCheck :: DsMatchContext -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchCheck ctx vars ty qs = do - dflags <- getDOptsDs - matchCheck_really dflags ctx vars ty qs +matchCheck ctx vars ty qs + = do { dflags <- getDOptsDs + ; matchCheck_really dflags ctx vars ty qs } matchCheck_really :: DynFlags -> DsMatchContext @@ -65,28 +66,31 @@ matchCheck_really :: DynFlags -> Type -> [EquationInfo] -> DsM MatchResult -matchCheck_really dflags ctx vars ty qs - | incomplete && shadow = do - dsShadowWarn ctx eqns_shadow - dsIncompleteWarn ctx pats - match vars ty qs - | incomplete = do - dsIncompleteWarn ctx pats - match vars ty qs - | shadow = do - dsShadowWarn ctx eqns_shadow - match vars ty qs - | otherwise = - match vars ty qs - where (pats, eqns_shadow) = check qs - incomplete = want_incomplete && (notNull pats) - want_incomplete = case ctx of - DsMatchContext RecUpd _ -> - dopt Opt_WarnIncompletePatternsRecUpd dflags - _ -> - dopt Opt_WarnIncompletePatterns dflags - shadow = dopt Opt_WarnOverlappingPatterns dflags - && not (null eqns_shadow) +matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs + = do { when shadow (dsShadowWarn ctx eqns_shadow) + ; when incomplete (dsIncompleteWarn ctx pats) + ; match vars ty qs } + where + (pats, eqns_shadow) = check qs + incomplete = incomplete_flag hs_ctx && (notNull pats) + shadow = dopt Opt_WarnOverlappingPatterns dflags + && notNull eqns_shadow + + incomplete_flag :: HsMatchContext id -> Bool + incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags + + incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags + + incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags + + incomplete_flag ThPatQuote = False + incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns + -- in list comprehensions, pattern guards + -- etc. They are often *supposed* to be + -- incomplete \end{code} This variable shows the maximum number of lines of output generated for warnings. @@ -735,19 +739,21 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr - matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult -- Do not warn about incomplete patterns -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) _ (L _ pat) ty match_result - = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] - -matchSinglePat scrut hs_ctx pat ty match_result = do - var <- selectSimpleMatchVarL pat - match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result - return (adjustMatchResult (bindNonRec var scrut) match_result') +matchSinglePat (Var var) ctx (L _ pat) ty match_result + = do { locn <- getSrcSpanDs + ; matchCheck (DsMatchContext ctx locn) + [var] ty + [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] } + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL pat + ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result + ; return (adjustMatchResult (bindNonRec var scrut) match_result') } \end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 5f1f776..06616f1 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1161,12 +1161,15 @@ data HsMatchContext id -- Context of a Match | LambdaExpr -- Patterns of a lambda | CaseAlt -- Patterns and guards on a case alternative | ProcExpr -- Patterns of a proc - | PatBindRhs -- A pattern binding, or its guards - -- [x] = e, or x | [y] <- e = e + | PatBindRhs -- A pattern binding eg [y] <- e = e + | RecUpd -- Record update [used only in DsExpr to -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] deriving (Data, Typeable) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 17b8fdb..4a3b8f1 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -181,6 +181,7 @@ data DynFlag | Opt_WarnHiShadows | Opt_WarnImplicitPrelude | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd | Opt_WarnMissingFields | Opt_WarnMissingImportList @@ -1420,6 +1421,7 @@ fFlags = [ ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", Opt_WarnIncompleteUniPatterns, nop ), ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), ( "warn-missing-fields", Opt_WarnMissingFields, nop ), ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), @@ -1742,6 +1744,7 @@ standardWarnings ] minusWOpts :: [DynFlag] +-- Things you get with -W minusWOpts = standardWarnings ++ [ Opt_WarnUnusedBinds, @@ -1753,6 +1756,7 @@ minusWOpts ] minusWallOpts :: [DynFlag] +-- Things you get with -Wall minusWallOpts = minusWOpts ++ [ Opt_WarnTypeDefaults, @@ -1760,21 +1764,21 @@ minusWallOpts Opt_WarnMissingSigs, Opt_WarnHiShadows, Opt_WarnOrphans, - Opt_WarnUnusedDoBind, - Opt_WarnIdentities + Opt_WarnUnusedDoBind ] --- minuswRemovesOpts should be every warning option minuswRemovesOpts :: [DynFlag] +-- minuswRemovesOpts should be every warning option minuswRemovesOpts = minusWallOpts ++ - [Opt_WarnImplicitPrelude, + [Opt_WarnTabs, Opt_WarnIncompletePatternsRecUpd, + Opt_WarnIncompleteUniPatterns, Opt_WarnMonomorphism, Opt_WarnUnrecognisedPragmas, Opt_WarnAutoOrphans, - Opt_WarnTabs - ] + Opt_WarnImplicitPrelude + ] enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index a9c0184..2357673 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1137,6 +1137,13 @@ + + warn when a pattern match in a lambda expression or pattern binding could fail + dynamic + + + + warn when a record update could fail dynamic diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index a80e8d1..18e9622 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -990,9 +990,11 @@ ghc -c Foo.hs not enabled by are , + , , , - , and + , + , . @@ -1215,27 +1217,40 @@ foreign import "&f" f :: FunPtr t - : + , + , + incomplete patterns, warning patterns, incomplete - Similarly for incomplete patterns, the functions - g and h below will fail when applied to + The option warns + about places where + a pattern-match might fail at runtime. + The function + g below will fail when applied to non-empty lists, so the compiler will emit a warning about this when is - enabled. - + enabled. g [] = 2 -h = \[] -> 2 - - This option isn't enabled by default because it can be + This option isn't enabled by default because it can be a bit noisy, and it doesn't always indicate a bug in the program. However, it's generally considered good practice - to cover all the cases in your functions. + to cover all the cases in your functions, and it is switched + on by . + + The flag is + similar, except that it + applies only to lambda-expressions and pattern bindings, constructs + that only allow a single pattern: + +h = \[] -> 2 +Just k = f y + +