Commit 20f14b4f authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 0703c00f
......@@ -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
......@@ -782,8 +783,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 )
......@@ -799,6 +801,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
(InferContext Nothing) deriv_strat
......
......@@ -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
......
......@@ -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,
......@@ -921,6 +921,7 @@ okIPCtxt (InstDeclCtxt {}) = False
okIPCtxt (SpecInstCtxt {}) = False
okIPCtxt (RuleSigCtxt {}) = False
okIPCtxt DefaultDeclCtxt = False
okIPCtxt DerivClauseCtxt = False
{-
Note [Kind polymorphic type classes]
......@@ -1050,9 +1051,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)
......@@ -1068,6 +1069,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)" $$
......
{-# LANGUAGE DeriveAnyClass #-}
module T14916 where
import Data.Coerce
import Data.Typeable
data A = MkA deriving ((~) A)
data B = MkB deriving (Coercible B)
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’
......@@ -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, [''])
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