diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-01-15 08:08:43 -0500 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-01-15 08:08:43 -0500 |
| commit | 83a22066fbe136e4a984e8c90c1d3fd72b6ec4b9 (patch) | |
| tree | abd9df501e567f4b8c11318604828ff692437983 /compiler/rename | |
| parent | 69947d58c29cc0b047cc34fb4873e12f47e9674c (diff) | |
| download | haskell-83a22066fbe136e4a984e8c90c1d3fd72b6ec4b9.tar.gz | |
Fix #16114 by adding a validity check to rnClsInstDecl
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnSource.hs | 26 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 7 |
2 files changed, 20 insertions, 13 deletions
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index ca35e941fb..e5fe3a3a31 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -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 diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index f66c1bd29f..3703f1ac63 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -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 |