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 (file)
--- 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))
 
 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}
 
 
 \end{code}
 
 

@@ -87,7 +87,7 @@ dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
 
 \begin{code}
 matchGuards :: [Stmt Id]               -- Guard
 
 \begin{code}
 matchGuards :: [Stmt Id]               -- Guard

-            -> HsMatchContext Name     -- Context
+            -> HsStmtContext Name      -- Context

            -> LHsExpr Id               -- RHS
            -> Type                     -- Type of RHS of guard
            -> DsM MatchResult
            -> 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
 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)
 
 
 isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
 

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 9d7e124..5c6b224 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -38,6 +38,7 @@ import Name
 import Outputable
 import FastString
 
 import Outputable
 import FastString
 

+import Control.Monad( when )

 import qualified Data.Map as Map
 \end{code}
 
 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!
 
             -> [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
 
 matchCheck_really :: DynFlags
                   -> DsMatchContext

@@ -65,28 +66,31 @@ matchCheck_really :: DynFlags
                   -> Type
                   -> [EquationInfo]
                   -> DsM MatchResult
                   -> 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.
 \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
 
     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 :: 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}
 
 
 \end{code}
 
 

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 5f1f776..06616f1 100644 (file)
--- 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
   | 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]
   | 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)
 
   | 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 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -181,6 +181,7 @@ data DynFlag
    | Opt_WarnHiShadows
    | Opt_WarnImplicitPrelude
    | Opt_WarnIncompletePatterns
    | Opt_WarnHiShadows
    | Opt_WarnImplicitPrelude
    | Opt_WarnIncompletePatterns

+   | Opt_WarnIncompleteUniPatterns

    | Opt_WarnIncompletePatternsRecUpd
    | Opt_WarnMissingFields
    | Opt_WarnMissingImportList
    | 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-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 ),
   ( "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]
       ]
 
 minusWOpts :: [DynFlag]

+-- Things you get with -W

 minusWOpts
     = standardWarnings ++
       [ Opt_WarnUnusedBinds,
 minusWOpts
     = standardWarnings ++
       [ Opt_WarnUnusedBinds,

@@ -1753,6 +1756,7 @@ minusWOpts
       ]
 
 minusWallOpts :: [DynFlag]
       ]
 
 minusWallOpts :: [DynFlag]

+-- Things you get with -Wall

 minusWallOpts
     = minusWOpts ++
       [ Opt_WarnTypeDefaults,
 minusWallOpts
     = minusWOpts ++
       [ Opt_WarnTypeDefaults,

@@ -1760,21 +1764,21 @@ minusWallOpts
         Opt_WarnMissingSigs,
         Opt_WarnHiShadows,
         Opt_WarnOrphans,
         Opt_WarnMissingSigs,
         Opt_WarnHiShadows,
         Opt_WarnOrphans,

-        Opt_WarnUnusedDoBind,
-        Opt_WarnIdentities
+        Opt_WarnUnusedDoBind

       ]
 
       ]
 

--- minuswRemovesOpts should be every warning option

 minuswRemovesOpts :: [DynFlag]
 minuswRemovesOpts :: [DynFlag]

+-- minuswRemovesOpts should be every warning option 

 minuswRemovesOpts
     = minusWallOpts ++
 minuswRemovesOpts
     = minusWallOpts ++

-      [Opt_WarnImplicitPrelude,
+      [Opt_WarnTabs,

        Opt_WarnIncompletePatternsRecUpd,
        Opt_WarnIncompletePatternsRecUpd,

+       Opt_WarnIncompleteUniPatterns,

        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,
        Opt_WarnAutoOrphans,
        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,
        Opt_WarnAutoOrphans,

-       Opt_WarnTabs
-      ]
+       Opt_WarnImplicitPrelude
+     ]       

 
 enableGlasgowExts :: DynP ()
 enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls
 
 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 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1137,6 +1137,13 @@
          </row>
 
          <row>
          </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>
            <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 (file)
--- 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>,
          <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-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>
             <option>-fwarn-implicit-prelude</option>.</para>
        </listitem>
       </varlistentry>

@@ -1215,27 +1217,40 @@ foreign import "&amp;f" f :: FunPtr t
       </varlistentry>
 
       <varlistentry>
       </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>
        <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>
 
          <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
           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
 <programlisting>
 g [] = 2

-h = \[] -> 2

 </programlisting>
 </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
           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>
 
        </listitem>
       </varlistentry>