[commit: ghc] master: Check for mismatched class methods during typechecking (1879d9d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1879d9d2c95239f6705af0cbac5fed7d9b220f28/ghc

>---------------------------------------------------------------

commit 1879d9d2c95239f6705af0cbac5fed7d9b220f28
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Thu May 24 10:31:28 2018 -0400

    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


>---------------------------------------------------------------

1879d9d2c95239f6705af0cbac5fed7d9b220f28
 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(-)

diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index e23b096..fe22fb3 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 5873c6f..6d94029 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 c319378..7b869fd 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 35e6a95..ab31e2e 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 0000000..550fc99
--- /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 0000000..81c2eef
--- /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 4fcf700..e103184 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'])