From 1887441a84e3adde7db48d6459db9a47fc6cc8e2 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sun, 25 Mar 2018 15:34:05 -0400
Subject: [PATCH] Fix #14916 with an additional validity check in deriveTyData
Manually-written instances and standalone-derived instances
have the benefit of having the `checkValidInstHead` function run over
them, which catches manual instances of built-in types like `(~)` and
`Coercible`. However, instances generated from `deriving` clauses
weren't being passed through `checkValidInstHead`, leading to
confusing results as in #14916.
`checkValidInstHead` also has additional validity checks for language
extensions like `FlexibleInstances` and `MultiParamTypeClasses`. Up
until now, GHC has never required these language extensions for
`deriving` clause, so to avoid unnecessary breakage, I opted to
suppress these language extension checks for `deriving` clauses, just
like we currently suppress them for `SPECIALIZE instance` pragmas.
Test Plan: make test TEST=T14916
Reviewers: goldfire, bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie, carter
GHC Trac Issues: #14916
Differential Revision: https://phabricator.haskell.org/D4501
(cherry picked from commit 20f14b4fd4eaf2c3ab375b8fc6d40ee9e6db94fd)
---
compiler/typecheck/TcDeriv.hs | 9 ++++++++-
compiler/typecheck/TcType.hs | 2 ++
compiler/typecheck/TcValidity.hs | 8 +++++---
testsuite/tests/deriving/should_fail/T14916.hs | 8 ++++++++
testsuite/tests/deriving/should_fail/T14916.stderr | 10 ++++++++++
testsuite/tests/deriving/should_fail/all.T | 1 +
6 files changed, 34 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/deriving/should_fail/T14916.hs
create mode 100644 testsuite/tests/deriving/should_fail/T14916.stderr
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index a93712c8b232..f15c00324e8b 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -26,6 +26,7 @@ import TcValidity( allDistinctTyVars )
import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
import TcEnv
import TcGenDeriv -- Deriv stuff
+import TcValidity
import InstEnv
import Inst
import FamInstEnv
@@ -742,8 +743,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
; traceTc "derivTyData2" (vcat [ ppr tkvs ])
+ ; let final_tc_app = mkTyConApp tc final_tc_args
; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop) -- (a, b, c)
- (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
+ (derivingEtaErr cls final_cls_tys final_tc_app)
-- Check that
-- (a) The args to drop are all type variables; eg reject:
-- data instance T a Int = .... deriving( Monad )
@@ -759,6 +761,11 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
-- expand any type synonyms.
-- See Note [Eta-reducing type synonyms]
+ ; checkValidInstHead DerivClauseCtxt cls $
+ final_cls_tys ++ [final_tc_app]
+ -- Check that we aren't deriving an instance of a magical
+ -- type like (~) or Coercible (#14916).
+
; spec <- mkEqnHelp Nothing tkvs
cls final_cls_tys tc final_tc_args
Nothing deriv_strat
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index ba3cd6f53e34..f6343da6fd11 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -617,6 +617,7 @@ data UserTypeCtxt
-- f :: <S> => a -> a
| DataTyCtxt Name -- The "stupid theta" part of a data decl
-- data <S> => T a = MkT a
+ | DerivClauseCtxt -- A 'deriving' clause
{-
-- Notes re TySynCtxt
@@ -652,6 +653,7 @@ pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes
pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc)
pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n)
+pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n _) = Just n
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 8c01460f2e43..6b3b24d373de 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -9,7 +9,7 @@ module TcValidity (
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
ContextKind(..), expectedKindInCtxt,
checkValidTheta, checkValidFamPats,
- checkValidInstance, validDerivPred,
+ checkValidInstance, checkValidInstHead, validDerivPred,
checkInstTermination, checkTySynRhs,
ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,
checkValidTyFamEqn,
@@ -915,6 +915,7 @@ okIPCtxt (InstDeclCtxt {}) = False
okIPCtxt (SpecInstCtxt {}) = False
okIPCtxt (RuleSigCtxt {}) = False
okIPCtxt DefaultDeclCtxt = False
+okIPCtxt DerivClauseCtxt = False
{-
Note [Kind polymorphic type classes]
@@ -1044,9 +1045,9 @@ checkValidInstHead ctxt clas cls_args
checkHasFieldInst clas cls_args
-- Check language restrictions;
- -- but not for SPECIALISE instance pragmas
+ -- but not for SPECIALISE instance pragmas or deriving clauses
; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
- ; unless spec_inst_prag $
+ ; unless (spec_inst_prag || deriv_clause) $
do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
all tcInstHeadTyNotSynonym ty_args)
(instTypeErr clas cls_args head_type_synonym_msg)
@@ -1062,6 +1063,7 @@ checkValidInstHead ctxt clas cls_args
; mapM_ checkValidTypePat ty_args }
where
spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
+ deriv_clause = case ctxt of { DerivClauseCtxt -> True; _ -> False }
head_type_synonym_msg = parens (
text "All instance types must be of the form (T t1 ... tn)" $$
diff --git a/testsuite/tests/deriving/should_fail/T14916.hs b/testsuite/tests/deriving/should_fail/T14916.hs
new file mode 100644
index 000000000000..19b323fc6dd5
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T14916.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module T14916 where
+
+import Data.Coerce
+import Data.Typeable
+
+data A = MkA deriving ((~) A)
+data B = MkB deriving (Coercible B)
diff --git a/testsuite/tests/deriving/should_fail/T14916.stderr b/testsuite/tests/deriving/should_fail/T14916.stderr
new file mode 100644
index 000000000000..2a6cca187d72
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T14916.stderr
@@ -0,0 +1,10 @@
+
+T14916.hs:7:24: error:
+ • Illegal instance declaration for ‘A ~ A’
+ Manual instances of this class are not permitted.
+ • In the data declaration for ‘A’
+
+T14916.hs:8:24: error:
+ • Illegal instance declaration for ‘Coercible B B’
+ Manual instances of this class are not permitted.
+ • In the data declaration for ‘B’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index acd348691877..8dc5b780afa8 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -71,3 +71,4 @@ test('T14365', [extra_files(['T14365B.hs','T14365B.hs-boot'])],
multimod_compile_fail, ['T14365A',''])
test('T14728a', normal, compile_fail, [''])
test('T14728b', normal, compile_fail, [''])
+test('T14916', normal, compile_fail, [''])
--
GitLab