Check for mismatched class methods during typechecking
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 24 May 2018 14:31:28 +0000 (10:31 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 24 May 2018 14:31:28 +0000 (10:31 -0400)
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
compiler/rename/RnEnv.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcValidity.hs
testsuite/tests/th/T12387.hs [new file with mode: 0644]
testsuite/tests/th/T12387.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index e23b096..fe22fb3 100644 (file)
@@ -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
index 5873c6f..6d94029 100644 (file)
@@ -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]
index c319378..7b869fd 100644 (file)
@@ -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
index 35e6a95..ab31e2e 100644 (file)
@@ -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 (file)
index 0000000..550fc99
--- /dev/null
@@ -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 (file)
index 0000000..81c2eef
--- /dev/null
@@ -0,0 +1,4 @@
+
+T12387.hs:8:3: error:
+    • Class ‘Eq’ does not have a method ‘compare’
+    • In the instance declaration for ‘Eq Foo’
index 4fcf700..e103184 100644 (file)
@@ -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'])