From 75c29aa1c2a38208a46fc2ab2dd9a6c9c1b6ffb9 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Thu, 13 Mar 2025 15:39:13 +0100
Subject: [PATCH] Reject instance with non-class head in renamer
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This commit modifies rnClsInstDecl so that, when renaming, we reject a class
instance declaration in which the head is not a class. Before this change, it
would get rejected in the type-checker, but that meant that the renamer could
emit unhelpful error messages, e.g.:
data Foo m a
instance Foo m where
fmap _ x = case x of
would rather unhelpfully say:
‘fmap’ is not a (visible) method of class ‘Foo’
when of course 'Foo' is not even a class. We now reject the above program
with the following error message:
Illegal instance for data type ‘Foo’.
Instance heads must be of the form
C ty_1 ... ty_n
where ‘C’ is a class.
Fixes #22688
---
compiler/GHC/Rename/Module.hs | 59 +++++++++++++------
compiler/GHC/Tc/Errors/Ppr.hs | 16 ++---
compiler/GHC/Tc/Errors/Types.hs | 15 +++--
compiler/GHC/Tc/Gen/HsType.hs | 6 +-
compiler/GHC/Tc/Validity.hs | 7 ++-
compiler/GHC/Types/Error/Codes.hs | 4 +-
testsuite/tests/rename/should_fail/T22688.hs | 6 ++
.../tests/rename/should_fail/T22688.stderr | 7 +++
testsuite/tests/rename/should_fail/all.T | 1 +
9 files changed, 84 insertions(+), 37 deletions(-)
create mode 100644 testsuite/tests/rename/should_fail/T22688.hs
create mode 100644 testsuite/tests/rename/should_fail/T22688.stderr
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 45d491fb7c6..b1598c9585d 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -9,6 +10,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -56,7 +58,7 @@ import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Types.Basic ( VisArity, TypeOrKind(..), RuleName )
+import GHC.Types.Basic ( VisArity, TyConFlavour(..), TypeOrKind(..), RuleName )
import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)
import GHC.Types.Hint (SigLike(..))
import GHC.Types.Unique.Set
@@ -587,22 +589,45 @@ rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _)
; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
}
- ; let -- Check if there are any nested `forall`s or contexts, which are
- -- illegal in the type of an instance declaration (see
- -- Note [No nested foralls or contexts in instance types] in
- -- GHC.Hs.Type)...
- mb_nested_msg = noNestedForallsContextsErr NFC_InstanceHead head_ty'
- -- ...then check that the instance head is actually headed by a
- -- class type constructor...
- eith_cls = case hsTyGetAppHead_maybe head_ty' of
- Just (L _ cls) -> Right cls
- Nothing ->
- Left
- ( getLocA head_ty'
- , TcRnIllegalInstance $
- IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $
- IllegalInstanceHead $ InstHeadNonClass Nothing
- )
+ ; env <- getGlobalRdrEnv
+ ; let
+ -- Check if there are any nested `forall`s or contexts, which are
+ -- illegal in the type of an instance declaration (see
+ -- Note [No nested foralls or contexts in instance types] in
+ -- GHC.Hs.Type)...
+ mb_nested_msg = noNestedForallsContextsErr NFC_InstanceHead head_ty'
+ -- ...then check if the instance head is actually headed by a
+ -- class type constructor...
+ instance_head :: Either IllegalInstanceHeadReason Name
+ instance_head =
+ case hsTyGetAppHead_maybe head_ty' of
+ Just (L _ nm) ->
+ case lookupGRE_Name env nm of
+ Just (GRE { gre_info = IAmTyCon flav }) ->
+ if
+ | flav == ClassFlavour
+ -> Right nm
+ | flav == AbstractTypeFlavour
+ -> Left $ InstHeadAbstractClass nm
+ | otherwise
+ -> Left $ InstHeadNonClassHead $ InstNonClassTyCon nm flav
+ _ ->
+ -- The head of the instance head is out of scope;
+ -- we'll deal with that later. Continue for now.
+ Right nm
+
+ Nothing ->
+ Left $ InstHeadNonClassHead InstNonTyCon
+ eith_cls =
+ case instance_head of
+ Right cls -> Right cls
+ Left illegal_head_reason ->
+ Left
+ ( getLocA head_ty'
+ , TcRnIllegalInstance $
+ IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $
+ IllegalInstanceHead illegal_head_reason
+ )
-- ...finally, attempt to retrieve the class type constructor, failing
-- with an error message if there isn't one. To avoid excessive
-- amounts of error messages, we will only report one of the errors
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 6bb68b5516d..a5d4eefc0e9 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -6364,10 +6364,10 @@ pprIllegalInstanceHeadReason head_ty = \case
text "and each type variable appears at most once in the instance head."]
InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $
text "Only one type can be given in an instance head."
- InstHeadAbstractClass clas ->
+ InstHeadAbstractClass cls ->
text "Cannot define instance for abstract class" <+>
- quotes (ppr (className clas))
- InstHeadNonClass bad_head ->
+ quotes (ppr cls)
+ InstHeadNonClassHead bad_head ->
vcat [ text "Illegal" <+> what_illegal <> dot
, text "Instance heads must be of the form"
, nest 2 $ text "C ty_1 ... ty_n"
@@ -6375,9 +6375,9 @@ pprIllegalInstanceHeadReason head_ty = \case
]
where
what_illegal = case bad_head of
- Just tc ->
- text "instance for" <+> ppr (tyConFlavour tc) <+> quotes (ppr $ tyConName tc)
- Nothing ->
+ InstNonClassTyCon tc_nm flav ->
+ text "instance for" <+> ppr flav <+> quotes (ppr tc_nm)
+ InstNonTyCon ->
text "head of an instance declaration:" <+> quotes (ppr head_ty)
with_illegal_instance_header :: TypedThing -> SDoc -> SDoc
@@ -6479,7 +6479,7 @@ illegalInstanceHeadHints = \case
[suggestExtension LangExt.MultiParamTypeClasses]
InstHeadAbstractClass {} ->
noHints
- InstHeadNonClass {} ->
+ InstHeadNonClassHead {} ->
noHints
illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason
@@ -6487,7 +6487,7 @@ illegalInstanceHeadReason = \case
-- These are serious
InstHeadAbstractClass {} ->
ErrorWithoutFlag
- InstHeadNonClass {} ->
+ InstHeadNonClassHead {} ->
ErrorWithoutFlag
-- These are less serious (enable an extension)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 9bacf1fad41..d97090459ff 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -147,6 +147,7 @@ module GHC.Tc.Errors.Types (
, InvalidFamInstQTv(..), InvalidFamInstQTvReason(..)
, InvalidAssoc(..), InvalidAssocInstance(..)
, InvalidAssocDefault(..), AssocDefaultBadArgs(..)
+ , InstHeadNonClassHead(..)
-- * Template Haskell errors
, THError(..), THSyntaxError(..), THNameError(..)
@@ -4809,7 +4810,7 @@ data IllegalInstanceHeadReason
-- f :: a
--
-- Test cases: typecheck/should_fail/T13068
- = InstHeadAbstractClass !Class
+ = InstHeadAbstractClass !Name -- ^ name of the abstract 'Class'
-- | An instance whose head is not a class.
--
-- Examples(s):
@@ -4829,10 +4830,7 @@ data IllegalInstanceHeadReason
-- rename/should_fail/T18240a
-- polykinds/T13267
-- deriving/should_fail/T23522
- | InstHeadNonClass
- !(Maybe TyCon) -- ^ the 'TyCon' at the head of the instance head,
- -- or 'Nothing' if the instance head is not even headed
- -- by a 'TyCon'
+ | InstHeadNonClassHead InstHeadNonClassHead
-- | Instance head was headed by a type synonym.
--
@@ -4863,6 +4861,13 @@ data IllegalInstanceHeadReason
deriving Generic
+-- | What was at the head of an instance head, when we expected a class?
+data InstHeadNonClassHead
+ -- | A 'TyCon' that isn't a class was at the head
+ = InstNonClassTyCon Name (TyConFlavour Name)
+ -- | Something else than a 'TyCon' was at the head
+ | InstNonTyCon
+
-- | Why is a (type or data) family instance invalid?
data IllegalFamilyInstanceReason
{-| A top-level family instance for a 'TyCon' that isn't a family 'TyCon'.
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 784defe5dbf..50cd75b26ce 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -675,8 +675,10 @@ tcHsDeriv hs_ty
failWithTc $ TcRnIllegalInstance
$ IllegalClassInstance (TypeThing ty)
$ IllegalInstanceHead
- $ InstHeadNonClass
- $ Just tyCon
+ $ InstHeadNonClassHead
+ $ InstNonClassTyCon
+ (tyConName tyCon)
+ (fmap tyConName $ tyConFlavour tyCon)
Right result -> return result }
-- | Typecheck a deriving strategy. For most deriving strategies, this is a
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 1d1434609fd..12a054a9715 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -1564,7 +1564,7 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
| isAbstractClass clas
, hs_src == HsSrcFile
= fail_with_inst_err $ IllegalInstanceHead
- $ InstHeadAbstractClass clas
+ $ InstHeadAbstractClass (className clas)
-- Complain about hand-written instances of built-in classes
-- Typeable, KnownNat, KnownSymbol, Coercible, HasField.
@@ -2111,9 +2111,10 @@ checkValidInstance ctxt hs_type ty = case tau of
; traceTc "End checkValidInstance }" empty }
| otherwise
-> failWithTc $ mk_err $ IllegalInstanceHead
- $ InstHeadNonClass (Just tc)
+ $ InstHeadNonClassHead
+ $ InstNonClassTyCon (tyConName tc) (fmap tyConName $ tyConFlavour tc)
_ -> failWithTc $ mk_err $ IllegalInstanceHead
- $ InstHeadNonClass Nothing
+ $ InstHeadNonClassHead InstNonTyCon
where
(theta, tau) = splitInstTyForValidity ty
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index f75e90579ee..0f8b2075757 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -809,7 +809,7 @@ type family GhcDiagnosticCode c = n | n -> c where
-- IllegalInstanceHead
GhcDiagnosticCode "InstHeadAbstractClass" = 51758
- GhcDiagnosticCode "InstHeadNonClass" = 53946
+ GhcDiagnosticCode "InstHeadNonClassHead" = 53946
GhcDiagnosticCode "InstHeadTySynArgs" = 93557
GhcDiagnosticCode "InstHeadNonTyVarArgs" = 48406
GhcDiagnosticCode "InstHeadMultiParam" = 91901
@@ -992,7 +992,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222
GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538
- -- The above two are subsumed by InstHeadNonClass [GHC-53946]
+ -- The above two are subsumed by InstHeadNonClassHead [GHC-53946]
GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = Outdated 40027
GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = Outdated 69639
diff --git a/testsuite/tests/rename/should_fail/T22688.hs b/testsuite/tests/rename/should_fail/T22688.hs
new file mode 100644
index 00000000000..92273abbea5
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T22688.hs
@@ -0,0 +1,6 @@
+module T22688a where
+
+data Foo m a
+
+instance Foo m where
+ fmap _ x = case x of
diff --git a/testsuite/tests/rename/should_fail/T22688.stderr b/testsuite/tests/rename/should_fail/T22688.stderr
new file mode 100644
index 00000000000..94b25ba59ac
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T22688.stderr
@@ -0,0 +1,7 @@
+T22688.hs:5:10: error: [GHC-53946]
+ • Illegal instance for data type ‘Foo’.
+ Instance heads must be of the form
+ C ty_1 ... ty_n
+ where ‘C’ is a class.
+ • In the instance declaration for ‘Foo m’
+
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index c13d4b87520..5e0d8c7c0db 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -212,6 +212,7 @@ test('T22478b', normal, compile_fail, [''])
test('T22478d', normal, compile_fail, [''])
test('T22478e', normal, compile_fail, [''])
test('T22478f', normal, compile_fail, [''])
+test('T22688', normal, compile_fail, [''])
test('T23740a', normal, compile_fail, [''])
test('T23740b', normal, compile_fail, [''])
test('T23740c', normal, compile_fail, [''])
--
GitLab