From 1879d9d2c95239f6705af0cbac5fed7d9b220f28 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Thu, 24 May 2018 10:31:28 -0400
Subject: [PATCH] Check for mismatched class methods during typechecking
Summary:
Template Haskell provides a wormhole through which you can
sneak methods that don't belong to a class into an instance for that
class, bypassing the renamer's validity checks. The solution adopted
here is to mirror the treatment for associated type family instances,
which have an additional check in the typechecker which catch
mismatched associated type families that were snuck through using
Template Haskell. I've put a similar check for class methods into
`tcMethods`.
Test Plan: make test TEST=T12387
Reviewers: bgamari, simonpj
Reviewed By: bgamari, simonpj
Subscribers: simonpj, rwbarton, thomie, carter
GHC Trac Issues: #12387
Differential Revision: https://phabricator.haskell.org/D4710
---
compiler/hsSyn/HsUtils.hs | 2 +-
compiler/rename/RnEnv.hs | 6 ++++--
compiler/typecheck/TcInstDcls.hs | 37 ++++++++++++++++++++++++++++++++
compiler/typecheck/TcValidity.hs | 2 ++
testsuite/tests/th/T12387.hs | 10 +++++++++
testsuite/tests/th/T12387.stderr | 4 ++++
testsuite/tests/th/all.T | 1 +
7 files changed, 59 insertions(+), 3 deletions(-)
create mode 100644 testsuite/tests/th/T12387.hs
create mode 100644 testsuite/tests/th/T12387.stderr
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index e23b0960b0e3..fe22fb3f288e 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -997,7 +997,7 @@ collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc
-collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
+collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
where
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 5873c6ff16a0..6d940299e4d1 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -651,8 +651,10 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
FoundName _p n -> return (Right n)
FoundFL fl -> return (Right (flSelector fl))
- IncorrectParent {} -> return $ Left (unknownSubordinateErr doc rdr_name)
-
+ IncorrectParent {}
+ -- See [Mismatched class methods and associated type families]
+ -- in TcInstDecls.
+ -> return $ Left (unknownSubordinateErr doc rdr_name)
{-
Note [Family instance binders]
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index c3193789b11c..7b869fd88613 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -60,6 +60,7 @@ import DynFlags
import ErrUtils
import FastString
import Id
+import ListSetOps
import MkId
import Name
import NameSet
@@ -1306,6 +1307,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-- The lexical_tvs scope over the 'where' part
do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
; checkMinimalDefinition
+ ; checkMethBindMembership
; (ids, binds, mb_implics) <- set_exts exts $
mapAndUnzip3M tc_item op_items
; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
@@ -1368,6 +1370,41 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
methodExists meth = isJust (findMethodBind meth binds prag_fn)
+ ----------------------
+ -- Check if any method bindings do not correspond to the class.
+ -- See Note [Mismatched class methods and associated type families].
+ checkMethBindMembership
+ = let bind_nms = map unLoc $ collectMethodBinders binds
+ cls_meth_nms = map (idName . fst) op_items
+ mismatched_meths = bind_nms `minusList` cls_meth_nms
+ in forM_ mismatched_meths $ \mismatched_meth ->
+ addErrTc $ hsep
+ [ text "Class", quotes (ppr (className clas))
+ , text "does not have a method", quotes (ppr mismatched_meth)]
+
+{-
+Note [Mismatched class methods and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's entirely possible for someone to put methods or associated type family
+instances inside of a class in which it doesn't belong. For instance, we'd
+want to fail if someone wrote this:
+
+ instance Eq () where
+ type Rep () = Maybe
+ compare = undefined
+
+Since neither the type family `Rep` nor the method `compare` belong to the
+class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
+since that would discover that the parent class `Eq` is incorrect.
+
+However, there is a scenario in which the renamer could fail to catch this:
+if the instance was generated through Template Haskell, as in #12387. In that
+case, Template Haskell will provide fully resolved names (e.g.,
+`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
+on. For this reason, we also put an extra validity check for this in the
+typechecker as a last resort.
+-}
+
------------------------
tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds -> Bool
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 35e6a956f306..ab31e2ef7f55 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1590,6 +1590,8 @@ checkConsistentFamInst
checkConsistentFamInst Nothing _ _ _ = return ()
checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc at_tys pp_hs_pats
= do { -- Check that the associated type indeed comes from this class
+ -- See [Mismatched class methods and associated type families]
+ -- in TcInstDecls.
checkTc (Just clas == tyConAssoc_maybe fam_tc)
(badATErr (className clas) (tyConName fam_tc))
diff --git a/testsuite/tests/th/T12387.hs b/testsuite/tests/th/T12387.hs
new file mode 100644
index 000000000000..550fc9930145
--- /dev/null
+++ b/testsuite/tests/th/T12387.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T12387 where
+
+import Language.Haskell.TH.Lib
+
+data Foo = Foo
+
+$(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)
+ [funD 'compare [clause [] (normalB $ varE 'undefined) []]]
+ return [d])
diff --git a/testsuite/tests/th/T12387.stderr b/testsuite/tests/th/T12387.stderr
new file mode 100644
index 000000000000..81c2eef5f75f
--- /dev/null
+++ b/testsuite/tests/th/T12387.stderr
@@ -0,0 +1,4 @@
+
+T12387.hs:8:3: error:
+ • Class ‘Eq’ does not have a method ‘compare’
+ • In the instance declaration for ‘Eq Foo’
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 4fcf70098781..e103184283de 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -360,6 +360,7 @@ test('T11629', normal, compile, ['-v0'])
test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T12130', [], multimod_compile,
['T12130', '-v0 ' + config.ghc_th_way_flags])
+test('T12387', normal, compile_fail, ['-v0'])
test('T12403', omit_ways(['ghci']),
compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T12407', omit_ways(['ghci']), compile, ['-v0'])
--
GitLab