Commit 9d388eb8 authored by Ryan Scott's avatar Ryan Scott

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
parent 11de4380
......@@ -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
......
......@@ -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}
......
......@@ -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
......@@ -28,8 +28,8 @@ matchSimply
-> CoreExpr
-> DsM CoreExpr
matchSinglePat
:: CoreExpr
matchSinglePatVar
:: Id
-> HsMatchContext Name
-> LPat GhcTc
-> Type
......
......@@ -34,7 +34,7 @@ module HsPat (
patNeedsParens, parenthesizePat,
isIrrefutableHsPat,
collectEvVarsPats,
collectEvVarsPat, collectEvVarsPats,
pprParendLPat, pprConArgs
) where
......
{-# 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 -> ()
......@@ -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,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment