Check generic-default method for ambiguity

Fixes Trac #7497 and #12151.   In some earlier upheaval I introduced
a bug in the ambiguity check for genreric-default method.

This patch fixes it.  But in fixing it I realised that the
sourc-location of any such error message was bogus, so I fixed
that too, which involved a slightly wider change; see the
comments with TcMethInfo.

7 files changed, 74 insertions, 39 deletions

diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index f23bbb3794..c26f0c20b3 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -32,7 +32,7 @@ import Type
 import Id
 import TcType
 
-import SrcLoc( noSrcSpan )
+import SrcLoc( SrcSpan, noSrcSpan )
 import DynFlags
 import TcRnMonad
 import UniqSupply
@@ -274,9 +274,23 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
                        (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
 
 ------------------------------------------------------
-type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-        -- A temporary intermediate, to communicate between
-        -- tcClassSigs and buildClass.
+type TcMethInfo     -- A temporary intermediate, to communicate
+                    -- between tcClassSigs and buildClass.
+  = ( Name   -- Name of the class op
+    , Type   -- Type of the class op
+    , Maybe (DefMethSpec (SrcSpan, Type)))
+         -- Nothing                    => no default method
+         --
+         -- Just VanillaDM             => There is an ordinary
+         --                               polymorphic default method
+         --
+         -- Just (GenericDM (loc, ty)) => There is a generic default metho
+         --                               Here is its type, and the location
+         --                               of the type signature
+         --    We need that location /only/ to attach it to the
+         --    generic default method's Name; and we need /that/
+         --    only to give the right location of an ambiguity error
+         --    for the generic default method, spat out by checkValidClass
 
 buildClass :: Name  -- Name of the class/tycon (they have the same Name)
            -> [TyConBinder]                -- Of the tycon
@@ -376,12 +390,20 @@ buildClass tycon_name binders roles sc_theta
 
     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
     mk_op_item rec_clas (op_name, _, dm_spec)
-      = do { dm_info <- case dm_spec of
-                          Nothing   -> return Nothing
-                          Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
-                                          ; return (Just (dm_name, spec)) }
+      = do { dm_info <- mk_dm_info op_name dm_spec
            ; return (mkDictSelId op_name rec_clas, dm_info) }
 
+    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
+               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
+    mk_dm_info _ Nothing
+      = return Nothing
+    mk_dm_info op_name (Just VanillaDM)
+      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+           ; return (Just (dm_name, VanillaDM)) }
+    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
+      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
+           ; return (Just (dm_name, GenericDM dm_ty)) }
+
 {-
 Note [Class newtypes and equality predicates]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -407,6 +429,14 @@ newImplicitBinder :: Name                       -- Base name
 -- For source type/class decls, this is the first occurrence
 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 newImplicitBinder base_name mk_sys_occ
+  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
+
+newImplicitBinderLoc :: Name                       -- Base name
+                     -> (OccName -> OccName)       -- Occurrence name modifier
+                     -> SrcSpan
+                     -> TcRnIf m n Name            -- Implicit name
+-- Just the same, but lets you specify the SrcSpan
+newImplicitBinderLoc base_name mk_sys_occ loc
   | Just mod <- nameModule_maybe base_name
   = newGlobalBinder mod occ loc
   | otherwise           -- When typechecking a [d| decl bracket |],
@@ -416,7 +446,6 @@ newImplicitBinder base_name mk_sys_occ
         ; return (mkInternalName uniq occ loc) }
   where
     occ = mk_sys_occ (nameOccName base_name)
-    loc = nameSrcSpan base_name
 
 -- | Make the 'TyConRepName' for this 'TyCon'
 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 5ffef1acfe..1f83221725 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -437,13 +437,13 @@ tc_iface_decl _parent ignore_prags
 
    tc_dm :: SDoc
          -> Maybe (DefMethSpec IfaceType)
-         -> IfL (Maybe (DefMethSpec Type))
+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
    tc_dm _   Nothing               = return Nothing
    tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)
    tc_dm doc (Just (GenericDM ty))
         = do { -- Must be done lazily to avoid sucking in types
              ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
-             ; return (Just (GenericDM ty')) }
+             ; return (Just (GenericDM (noSrcSpan, ty'))) }
 
    tc_at cls (IfaceAT tc_decl if_def)
      = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 6e112a229e..bc26055d45 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -103,7 +103,7 @@ tcClassSigs clas sigs def_methods
   = do { traceTc "tcClassSigs 1" (ppr clas)
 
        ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
-       ; let gen_dm_env :: NameEnv Type
+       ; let gen_dm_env :: NameEnv (SrcSpan, Type)
              gen_dm_env = mkNameEnv gen_dm_prs
 
        ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
@@ -125,7 +125,7 @@ tcClassSigs clas sigs def_methods
     dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
-    tc_sig :: NameEnv Type -> ([Located Name], LHsSigType Name)
+    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name)
            -> TcM [TcMethInfo]
     tc_sig gen_dm_env (op_names, op_hs_ty)
       = do { traceTc "ClsSig 1" (ppr op_names)
@@ -133,13 +133,13 @@ tcClassSigs clas sigs def_methods
            ; traceTc "ClsSig 2" (ppr op_names)
            ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
            where
-             f nm | Just ty <- lookupNameEnv gen_dm_env nm = Just (GenericDM ty)
+             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
                   | nm `elem` dm_bind_names                = Just VanillaDM
                   | otherwise                              = Nothing
 
     tc_gen_sig (op_names, gen_hs_ty)
       = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
-           ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
+           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index fe3c713662..04da5f21e7 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2415,7 +2415,7 @@ checkValidClass cls
         ; unless constrained_class_methods $
           mapM_ check_constraint (tail (theta1 ++ theta2))
 
-        ; check_dm ctxt dm
+        ; check_dm ctxt sel_id dm
         }
         where
           ctxt    = FunSigCtxt op_name True -- Report redundant class constraints
@@ -2447,17 +2447,21 @@ checkValidClass cls
         where
           fam_tvs = tyConTyVars fam_tc
 
-    check_dm :: UserTypeCtxt -> DefMethInfo -> TcM ()
+    check_dm :: UserTypeCtxt -> Id -> DefMethInfo -> TcM ()
     -- Check validity of the /top-level/ generic-default type
     -- E.g for   class C a where
     --             default op :: forall b. (a~b) => blah
     -- we do not want to do an ambiguity check on a type with
     -- a free TyVar 'a' (Trac #11608).  See TcType
     -- Note [TyVars and TcTyVars during type checking]
-    -- Hence the mkSpecForAllTys to close the type.
-    check_dm ctxt (Just (_, GenericDM ty))
-      = checkValidType ctxt (mkSpecForAllTys tyvars ty)
-    check_dm _ _ = return ()
+    -- Hence the mkDefaultMethodType to close the type.
+    check_dm ctxt sel_id (Just (dm_name, dm_spec@(GenericDM {})))
+      = setSrcSpan (getSrcSpan dm_name) $
+            -- We have carefully set the SrcSpan on the generic
+            -- default-method Name to be that of the generic
+            -- default type signature
+        checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)
+    check_dm _ _ _ = return ()
 
 checkFamFlag :: Name -> TcM ()
 -- Check that we don't use families without -XTypeFamilies
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 6070227d72..67361f86db 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -18,7 +18,7 @@ module TcTyDecls(
         checkClassCycles,
 
         -- * Implicits
-        tcAddImplicits,
+        tcAddImplicits, mkDefaultMethodType,
 
         -- * Record selectors
         mkRecSelBinds, mkOneRecordSelector
@@ -647,17 +647,18 @@ mkDefaultMethodIds :: [TyCon] -> [Id]
 -- the filled-in default methods of each instance declaration
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds tycons
-  = [ mkExportedVanillaId dm_name (mk_dm_ty cls sel_id dm_spec)
+  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)
     | tc <- tycons
     , Just cls <- [tyConClass_maybe tc]
     , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
-  where
-    mk_dm_ty :: Class -> Id -> DefMethSpec Type -> Type
-    mk_dm_ty _ sel_id VanillaDM        = idType sel_id
-    mk_dm_ty cls _   (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty
-       where
-         cls_tvs = classTyVars cls
-         pred    = mkClassPred cls (mkTyVarTys cls_tvs)
+
+mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
+-- Returns the top-level type of the default method
+mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id
+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty
+   where
+     cls_tvs = classTyVars cls
+     pred    = mkClassPred cls (mkTyVarTys cls_tvs)
 
 {-
 ************************************************************************
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs
index a8626db407..169f91d3ba 100644
--- a/compiler/types/Class.hs
+++ b/compiler/types/Class.hs
@@ -10,7 +10,7 @@ module Class (
         ClassOpItem,
         ClassATItem(..),
         ClassMinimalDef,
-        DefMethInfo, pprDefMethInfo, defMethSpecOfDefMeth,
+        DefMethInfo, pprDefMethInfo,
 
         FunDep, pprFundeps, pprFunDep,
 
@@ -110,14 +110,6 @@ data ClassATItem
 
 type ClassMinimalDef = BooleanFormula Name -- Required methods
 
--- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
---   the `DefMeth` constructor of the `DefMeth`.
-defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec Type)
-defMethSpecOfDefMeth meth
- = case meth of
-     Nothing        -> Nothing
-     Just (_, spec) -> Just spec
-
 {-
 Note [Associated type defaults]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index a75391eca5..7aa79215d5 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -13,6 +13,8 @@ import Type
 import TyCon
 import DataCon
 import DynFlags
+import BasicTypes( DefMethSpec(..) )
+import SrcLoc( SrcSpan, noSrcSpan )
 import Var
 import Name
 import Outputable
@@ -124,6 +126,13 @@ vectMethod id defMeth ty
       ; return  (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
       }
 
+-- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
+--   the `DefMeth` constructor of the `DefMeth`.
+defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type))
+defMethSpecOfDefMeth Nothing = Nothing
+defMethSpecOfDefMeth (Just (_, VanillaDM))    = Just VanillaDM
+defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty))
+
 -- |Vectorise the RHS of an algebraic type.
 --
 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs