From 36546a43e490ea6f989e6cad369d1a251c94a42b Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 8 Mar 2019 19:02:44 -0500
Subject: [PATCH] Fix #16411 by making dataConCannotMatch aware of (~~)
The `dataConCannotMatch` function (which powers the
`-Wpartial-fields` warning, among other things) had special reasoning
for explicit equality constraints of the form `a ~ b`, but it did
not extend that reasoning to `a ~~ b` constraints, leading to #16411.
Easily fixed.
---
compiler/basicTypes/DataCon.hs | 11 +++++++----
testsuite/tests/typecheck/should_compile/T16411.hs | 14 ++++++++++++++
testsuite/tests/typecheck/should_compile/all.T | 1 +
3 files changed, 22 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_compile/T16411.hs
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 8baf43c7d3cf..690ed6854f61 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -1403,10 +1403,13 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of
- EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
- ClassPred eq [_, ty1, ty2]
- | eq `hasKey` eqTyConKey -> [(ty1, ty2)]
- _ -> []
+ EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
+ ClassPred eq args
+ | eq `hasKey` eqTyConKey
+ , [_, ty1, ty2] <- args -> [(ty1, ty2)]
+ | eq `hasKey` heqTyConKey
+ , [_, _, ty1, ty2] <- args -> [(ty1, ty2)]
+ _ -> []
-- | Were the type variables of the data con written in a different order
-- than the regular order (universal tyvars followed by existential tyvars)?
diff --git a/testsuite/tests/typecheck/should_compile/T16411.hs b/testsuite/tests/typecheck/should_compile/T16411.hs
new file mode 100644
index 000000000000..5cbd255086a8
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T16411.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wpartial-fields #-}
+module T16411 where
+
+import Data.Type.Equality
+
+data T1 z where
+ MkT1a :: { rec1 :: () } -> T1 Int
+ MkT1b :: (z ~ Bool) => T1 z
+
+data T2 z where
+ MkT2a :: { rec2 :: () } -> T2 Int
+ MkT2b :: (z ~~ Bool) => T2 z
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index b94f0210585e..81a63c594fcc 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -670,3 +670,4 @@ test('T16204a', normal, compile, [''])
test('T16204b', normal, compile, [''])
test('T16225', normal, compile, [''])
test('T13951', normal, compile, [''])
+test('T16411', normal, compile, [''])
--
GitLab