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
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, 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 cls = case hsTyGetAppHead_maybe head_ty' of
Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
Just (dL->L _ cls) -> cls
-- rnLHsInstType has added an error message
-- if hsTyGetAppHead_maybe fails
; cls <-
case hsTyGetAppHead_maybe head_ty' of
Just (dL->L _ cls) -> pure cls
Nothing -> do
-- 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
-- The typechecker (not the renamer) checks that all
......
......@@ -15,7 +15,6 @@ module RnTypes (
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType,
HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
......@@ -374,12 +373,6 @@ rnImplicitBndrs bind_free_tvs
, text "Suggested fix: add" <+>
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
......
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:
• Expecting one more argument to ‘A’
Expected a constraint, but ‘A’ has kind ‘* -> Constraint’
• In the instance declaration for ‘B => C’
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’
Illegal class instance: ‘A => B => C’
Class instances must be of the form
context => C ty_1 ... ty_n
where ‘C’ is a class
......@@ -143,5 +143,5 @@ test('T15611a', normal, compile_fail, [''])
test('T15611b', normal, ghci_script, ['T15611b.script'])
test('T15828', normal, compile_fail, [''])
test('T16002', normal, compile_fail, [''])
test('T16114', 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