Fix #15385 by using addDictsDs in matchGuards
authorRyan Scott <ryan.gl.scott@gmail.com>
Mon, 30 Jul 2018 12:47:39 +0000 (08:47 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Mon, 30 Jul 2018 12:47:39 +0000 (08:47 -0400)
Summary:
When coverage checking pattern-matches, we rely on the call
sites in the desugarer to populate the local dictionaries and term
evidence in scope using `addDictsDs` and `addTmCsDs`. But it turns
out that only the call site for desugaring `case` expressions was
actually doing this properly. In another part of the desugarer,
`matchGuards` (which handles pattern guards), it did not update the
local dictionaries in scope at all, leading to #15385.

Fixing this is relatively straightforward: just augment the
`BindStmt` case of `matchGuards` to use `addDictsDs` and `addTmCsDs`.
Accomplishing this took a little bit of import/export tweaking:

* We now need to export `collectEvVarsPat` from `HsPat.hs`.
* To avoid an import cycle with `Check.hs`, I moved `isTrueLHsExpr`
  from `DsGRHSs.hs` to `DsUtils.hs`, which resides lower on the
  import chain.

Test Plan: make test TEST=T15385

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15385

Differential Revision: https://phabricator.haskell.org/D4968

compiler/deSugar/Check.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs-boot
compiler/hsSyn/HsPat.hs
testsuite/tests/pmcheck/should_compile/T15385.hs [new file with mode: 0644]
testsuite/tests/pmcheck/should_compile/all.T

index 201ed12..8acb38b 100644 (file)
@@ -51,7 +51,7 @@ import Var           (EvVar)
 import TyCoRep
 import Type
 import UniqSupply
-import DsGRHSs       (isTrueLHsExpr)
+import DsUtils       (isTrueLHsExpr)
 import Maybes        (expectJust)
 import qualified GHC.LanguageExtensions as LangExt
 
index 0fe4828..0065853 100644 (file)
@@ -15,18 +15,17 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
 import GhcPrelude
 
 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
-import {-# SOURCE #-} Match   ( matchSinglePat )
+import {-# SOURCE #-} Match   ( matchSinglePatVar )
 
 import HsSyn
 import MkCore
 import CoreSyn
+import CoreUtils (bindNonRec)
 
+import Check (genCaseTmCs2)
 import DsMonad
 import DsUtils
-import TysWiredIn
-import PrelNames
 import Type   ( Type )
-import Module
 import Name
 import Util
 import SrcLoc
@@ -118,9 +117,18 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
         --         body expression in hand
 
 matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx rhs rhs_ty
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
+    match_result <- addDictsDs dicts $
+                    addTmCsDs tm_cs  $
+                      -- See Note [Type and Term Equality Propagation] in Check
+                    matchGuards stmts ctx rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
-    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
 
 matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
 matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
@@ -131,35 +139,6 @@ matchGuards (ApplicativeStmt {} : _) _ _ _ =
 matchGuards (XStmtLR {} : _) _ _ _ =
   panic "matchGuards XStmtLR"
 
-isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-
--- Returns Just {..} if we're sure that the expression is True
--- I.e.   * 'True' datacon
---        * 'otherwise' Id
---        * Trivial wappings of these
--- The arguments to Just are any HsTicks that we have found,
--- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
-                                      || v `hasKey` getUnique trueDataConId
-                                              = Just return
-        -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut _ con))
-  | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick _ tickish e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do wrapped <- ticks x
-                     return (Tick tickish wrapped))
-   -- This encodes that the result is constant True for Hpc tick purposes;
-   -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do e <- ticks x
-                     this_mod <- getModule
-                     return (Tick (HpcTick this_mod ixT) e))
-
-isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
-isTrueLHsExpr _                       = Nothing
-
 {-
 Should {\em fail} if @e@ returns @D@
 \begin{verbatim}
index f74be0b..897e9eb 100644 (file)
@@ -37,7 +37,8 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
     ) where
 
 #include "HsVersions.h"
@@ -966,3 +967,32 @@ addBang = go
                                   -- Should we bring the extension value over?
            BangPat _ _   -> lp
            _             -> L l (BangPat noExt lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
+                                      || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
+isTrueLHsExpr _                       = Nothing
index bd23e1a..e77ad54 100644 (file)
@@ -28,8 +28,8 @@ matchSimply
         -> CoreExpr
         -> DsM CoreExpr
 
-matchSinglePat
-        :: CoreExpr
+matchSinglePatVar
+        :: Id
         -> HsMatchContext Name
         -> LPat GhcTc
         -> Type
index faefb84..6f65487 100644 (file)
@@ -34,7 +34,7 @@ module HsPat (
         patNeedsParens, parenthesizePat,
         isIrrefutableHsPat,
 
-        collectEvVarsPats,
+        collectEvVarsPat, collectEvVarsPats,
 
         pprParendLPat, pprConArgs
     ) where
diff --git a/testsuite/tests/pmcheck/should_compile/T15385.hs b/testsuite/tests/pmcheck/should_compile/T15385.hs
new file mode 100644 (file)
index 0000000..dedf6c1
--- /dev/null
@@ -0,0 +1,21 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+module T15385 where
+
+import Data.Type.Equality
+
+data T a where
+  TInt  :: T Int
+  TBool :: T Bool
+
+f1, f2 :: a :~: Int -> T a -> ()
+f1 eq t
+  | Refl <- eq
+  = case t of
+      TInt -> ()
+f2 eq t
+  = if |  Refl <- eq
+       -> case t of
+            TInt -> ()
index e382e3f..4030b06 100644 (file)
@@ -44,25 +44,27 @@ test('T11276', compiler_stats_num_field('bytes allocated',
 
 test('T11303b', compiler_stats_num_field('bytes allocated',
   [(wordsize(64), 54373936, 10)]
-    # 2018-07-14: 54373936    INITIAL    
+    # 2018-07-14: 54373936    INITIAL
   ), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
-  
+
 test('T11374', compiler_stats_num_field('bytes allocated',
   [(wordsize(64), 280144864, 10)]
     # 2018-07-14: 280144864   INITIAL
   ), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
-  
+
 test('T11195', compiler_stats_num_field('bytes allocated',
   [(wordsize(64), 7852567480, 10)]
     # 2018-07-14: 7852567480   INITIAL
   ), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS'])
-  
+
 test('T11984', normal, compile,
     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T14086', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T14098', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T15385', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 
 # Other tests
 test('pmc001', [], compile,