[commit: ghc] : Refine incomplete-pattern checks (Trac #4905) (a0f6d30)
Simon Marlow
marlowsd at gmail.com
Fri Jan 28 21:21:51 CET 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch :
http://hackage.haskell.org/trac/ghc/changeset/a0f6d307b097bd788e181434a4d9b7fdd56a6c6b
>---------------------------------------------------------------
commit a0f6d307b097bd788e181434a4d9b7fdd56a6c6b
Author: simonpj at microsoft.com <unknown>
Date: Thu Jan 27 13:13:04 2011 +0000
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
>---------------------------------------------------------------
compiler/deSugar/DsGRHSs.lhs | 6 ++--
compiler/deSugar/Match.lhs | 72 ++++++++++++++++++++++-------------------
compiler/hsSyn/HsExpr.lhs | 9 +++--
compiler/main/DynFlags.hs | 16 ++++++---
docs/users_guide/flags.xml | 7 ++++
docs/users_guide/using.xml | 35 ++++++++++++++------
6 files changed, 90 insertions(+), 55 deletions(-)
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 @@
</row>
<row>
+ <entry><option>-fwarn-incomplete-uni-patterns</option></entry>
+ <entry>warn when a pattern match in a lambda expression or pattern binding could fail</entry>
+ <entry>dynamic</entry>
+ <entry><option>-fno-warn-incomplete-uni-patterns</option></entry>
+ </row>
+
+ <row>
<entry><option>-fwarn-incomplete-record-updates</option></entry>
<entry>warn when a record update could fail</entry>
<entry>dynamic</entry>
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</screen>
<emphasis>not</emphasis> enabled by <option>-Wall</option>
are
<option>-fwarn-tabs</option>,
+ <option>-fwarn-incomplete-uni-patterns</option>,
<option>-fwarn-incomplete-record-updates</option>,
<option>-fwarn-monomorphism-restriction</option>,
- <option>-fwarn-unused-do-bind</option>, and
+ <option>-fwarn-unrecognised-pragmas</option>,
+ <option>-fwarn-auto-orphans</option>,
<option>-fwarn-implicit-prelude</option>.</para>
</listitem>
</varlistentry>
@@ -1215,27 +1217,40 @@ foreign import "&f" f :: FunPtr t
</varlistentry>
<varlistentry>
- <term><option>-fwarn-incomplete-patterns</option>:</term>
+ <term><option>-fwarn-incomplete-patterns</option>,
+ <option>-fwarn-incomplete-uni-patterns</option>,
<listitem>
<indexterm><primary><option>-fwarn-incomplete-patterns</option></primary></indexterm>
+ <indexterm><primary><option>-fwarn-incomplete-uni-patterns</option></primary></indexterm>
<indexterm><primary>incomplete patterns, warning</primary></indexterm>
<indexterm><primary>patterns, incomplete</primary></indexterm>
- <para>Similarly for incomplete patterns, the functions
- <function>g</function> and <function>h</function> below will fail when applied to
+ <para>The option <option>-fwarn-incomplete-patterns</option> warns
+ about places where
+ a pattern-match might fail at runtime.
+ The function
+ <function>g</function> below will fail when applied to
non-empty lists, so the compiler will emit a warning about
this when <option>-fwarn-incomplete-patterns</option> is
- enabled.</para>
-
+ enabled.
<programlisting>
g [] = 2
-h = \[] -> 2
</programlisting>
-
- <para>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.</para>
+ to cover all the cases in your functions, and it is switched
+ on by <option>-W</option>.</para>
+
+ <para>The flag <option>-fwarn-incomplete-uni-patterns</option> is
+ similar, except that it
+ applies only to lambda-expressions and pattern bindings, constructs
+ that only allow a single pattern:
+<programlisting>
+h = \[] -> 2
+Just k = f y
+</programlisting>
+ </para>
</listitem>
</varlistentry>
More information about the Cvs-ghc
mailing list