diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-07-30 08:47:39 -0400 |
---|---|---|
committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-07-30 08:47:39 -0400 |
commit | 9d388eb83e797fd28e14868009c4786f3f1a8aa6 (patch) | |
tree | 6f0bcc4637c6b9cb565f093b43c88dede3e29acb | |
parent | 11de4380c2f16f374c6e8fbacf8dce00376e7efb (diff) | |
download | haskell-9d388eb83e797fd28e14868009c4786f3f1a8aa6.tar.gz |
Fix #15385 by using addDictsDs in matchGuards
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
-rw-r--r-- | compiler/deSugar/Check.hs | 2 | ||||
-rw-r--r-- | compiler/deSugar/DsGRHSs.hs | 49 | ||||
-rw-r--r-- | compiler/deSugar/DsUtils.hs | 32 | ||||
-rw-r--r-- | compiler/deSugar/Match.hs-boot | 4 | ||||
-rw-r--r-- | compiler/hsSyn/HsPat.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/T15385.hs | 21 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/all.T | 10 |
7 files changed, 76 insertions, 44 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 201ed12571..8acb38b8d4 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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 diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 0fe4828dc3..00658539d3 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -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} diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index f74be0b092..897e9eba37 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -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 diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot index bd23e1a795..e77ad548b6 100644 --- a/compiler/deSugar/Match.hs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -28,8 +28,8 @@ matchSimply -> CoreExpr -> DsM CoreExpr -matchSinglePat - :: CoreExpr +matchSinglePatVar + :: Id -> HsMatchContext Name -> LPat GhcTc -> Type diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index faefb84203..6f65487411 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -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 index 0000000000..dedf6c1553 --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T15385.hs @@ -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 -> () diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index e382e3fda4..4030b0609a 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -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, |