Commit 83a22066 authored by Ryan Scott's avatar Ryan Scott

Fix #16114 by adding a validity check to rnClsInstDecl

parent 69947d58
...@@ -648,13 +648,27 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ...@@ -648,13 +648,27 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats , cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag , cid_overlap_mode = oflag
, cid_datafam_insts = adts }) , cid_datafam_insts = adts })
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty = do { (inst_ty', inst_fvs)
<- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
; let cls = case hsTyGetAppHead_maybe head_ty' of ; cls <-
Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) case hsTyGetAppHead_maybe head_ty' of
Just (dL->L _ cls) -> cls Just (dL->L _ cls) -> pure cls
-- rnLHsInstType has added an error message Nothing -> do
-- if hsTyGetAppHead_maybe fails -- The instance is malformed. We'd still like
-- to make *some* progress (rather than failing outright), so
-- we report an error and continue for as long as we can.
-- Importantly, this error should be thrown before we reach the
-- typechecker, lest we encounter different errors that are
-- hopelessly confusing (such as the one in Trac #16114).
addErrAt (getLoc (hsSigType inst_ty)) $
hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))
2 (vcat [ text "Class instances must be of the form"
, nest 2 $ text "context => C ty_1 ... ty_n"
, text "where" <+> quotes (char 'C')
<+> text "is a class"
])
pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
-- Rename the bindings -- Rename the bindings
-- The typechecker (not the renamer) checks that all -- The typechecker (not the renamer) checks that all
......
...@@ -15,7 +15,6 @@ module RnTypes ( ...@@ -15,7 +15,6 @@ module RnTypes (
rnHsKind, rnLHsKind, rnLHsTypeArgs, rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType, rnHsSigType, rnHsWcType,
HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
newTyVarNameRn, newTyVarNameRn,
rnConDeclFields, rnConDeclFields,
rnLTyVar, rnLTyVar,
...@@ -374,12 +373,6 @@ rnImplicitBndrs bind_free_tvs ...@@ -374,12 +373,6 @@ rnImplicitBndrs bind_free_tvs
, text "Suggested fix: add" <+> , text "Suggested fix: add" <+>
quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ] quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
-- Rename the type in an instance.
-- The 'doc_str' is "an instance declaration".
-- Do not try to decompose the inst_ty in case it is malformed
rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
{- ****************************************************** {- ******************************************************
* * * *
LHsType and HsType LHsType and HsType
......
module T16114 where
data T a
instance Eq a => Eq a => Eq (T a) where (==) = undefined
T16114.hs:4:10: error:
Illegal class instance: ‘Eq a => Eq a => Eq (T a)’
Class instances must be of the form
context => C ty_1 ... ty_n
where ‘C’ is a class
T5951.hs:8:8: error: T5951.hs:8:8: error:
• Expecting one more argument to ‘A’ Illegal class instance: ‘A => B => C’
Expected a constraint, but ‘A’ has kind ‘* -> Constraint’ Class instances must be of the form
• In the instance declaration for ‘B => C’ context => C ty_1 ... ty_n
where ‘C’ is a class
T5951.hs:9:8: error:
• Expecting one more argument to ‘B’
Expected a constraint, but ‘B’ has kind ‘* -> Constraint’
• In the instance declaration for ‘B => C’
T5951.hs:10:8: error:
• Expecting one more argument to ‘C’
Expected a constraint, but ‘C’ has kind ‘* -> Constraint’
• In the instance declaration for ‘B => C’
...@@ -143,5 +143,5 @@ test('T15611a', normal, compile_fail, ['']) ...@@ -143,5 +143,5 @@ test('T15611a', normal, compile_fail, [''])
test('T15611b', normal, ghci_script, ['T15611b.script']) test('T15611b', normal, ghci_script, ['T15611b.script'])
test('T15828', normal, compile_fail, ['']) test('T15828', normal, compile_fail, [''])
test('T16002', normal, compile_fail, ['']) test('T16002', normal, compile_fail, [''])
test('T16114', normal, compile_fail, [''])
test('ExplicitForAllRules2', normal, compile_fail, ['']) test('ExplicitForAllRules2', 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