Improve the binding location of class methods (I think)

I've totally forgotten what this patch is fixing, but it's all about
getting the right source location for class methods.  It's fairly
minor, but annoying that I can't connect it with a Trac ticket

4 files changed, 47 insertions, 41 deletions

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 3d89f59f04..de8bd7dae7 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -45,7 +45,7 @@ module Name (
 
 	-- ** Creating 'Name's
 	mkSystemName, mkSystemNameAt,
-        mkInternalName, mkDerivedInternalName, 
+        mkInternalName, mkClonedInternalName, mkDerivedInternalName, 
 	mkSystemVarName, mkSysTvName, 
         mkFCallName,
         mkExternalName, mkWiredInName,
@@ -266,6 +266,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq
         --      * for interface files we tidyCore first, which makes
         --        the OccNames distinct when they need to be
 
+mkClonedInternalName :: Unique -> Name -> Name
+mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
+  = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
+         , n_occ = occ, n_loc = loc }
+
 mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
 mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
   = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 4fa1ec00c9..803cdd886e 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -440,8 +440,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
   | otherwise
   = putSrcSpanDs loc $ 
-    do { let poly_name = idName poly_id
-       ; spec_name <- newLocalName poly_name
+    do { uniq <- newUnique
+       ; let poly_name = idName poly_id
+             spec_name = mkClonedInternalName uniq poly_name
        ; (bndrs, ds_lhs) <- liftM collectBinders
                                   (dsHsWrapper spec_co (Var poly_id))
        ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 209215e8ec..7df818efd2 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -197,10 +197,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
       DefMeth dm_name    -> tc_dm dm_name 
       GenDefMeth dm_name -> tc_dm dm_name 
   where
-    sel_name      = idName sel_id
-    prags         = prag_fn sel_name
-    dm_bind       = findMethodBind sel_name binds_in
-	            `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+    sel_name           = idName sel_id
+    prags              = prag_fn sel_name
+    (dm_bind,bndr_loc) = findMethodBind sel_name binds_in
+	                 `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 
     -- Eg.   class C a where
     --          op :: forall b. Eq b => a -> [b] -> a
@@ -211,11 +211,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
 
     tc_dm dm_name 
       = do { dm_id <- tcLookupId dm_name
-	   ; local_dm_name <- newLocalName sel_name
+	   ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
  	     -- Base the local_dm_name on the selector name, because
  	     -- type errors from tcInstanceMethodBody come from here
 
-
            ; dm_id_w_inline <- addInlinePrags dm_id prags
            ; spec_prags     <- tcSpecPrags dm_id prags
 
@@ -242,17 +241,13 @@ tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
                      meth_id local_meth_sig
 		     specs (L loc bind)
-  = do	{       -- Typecheck the binding, first extending the envt
-		-- so that when tcInstSig looks up the local_meth_id to find
-		-- its signature, we'll find it in the environment
-          let local_meth_id = sig_id local_meth_sig
+  = do	{ let local_meth_id = sig_id local_meth_sig
               lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                              -- Substitute the local_meth_name for the binder
 			     -- NB: the binding is always a FunBind
 	; (ev_binds, (tc_bind, _, _)) 
                <- checkConstraints skol_info tyvars dfun_ev_vars $
-		  tcExtendIdEnv [local_meth_id] $
-	          tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind]
+	          tcPolyCheck NotTopLevel NonRecursive no_prag_fn local_meth_sig [lm_bind]
 
         ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
                            , abe_mono = local_meth_id, abe_prags = specs }
@@ -308,13 +303,15 @@ lookupHsSig = lookupNameEnv
 ---------------------------
 findMethodBind	:: Name  	        -- Selector name
           	-> LHsBinds Name 	-- A group of bindings
-		-> Maybe (LHsBind Name)	-- The binding
+		-> Maybe (LHsBind Name, SrcSpan)
+          	-- Returns the binding, and the binding 
+                -- site of the method binder
 findMethodBind sel_name binds
   = foldlBag mplus Nothing (mapBag f binds)
   where 
-    f bind@(L _ (FunBind { fun_id = L _ op_name }))
+    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
              | op_name == sel_name
-    	     = Just bind
+    	     = Just (bind, bndr_loc)
     f _other = Nothing
 \end{code}
 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 140e1c88a9..7a41869600 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -840,10 +840,9 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] 
           -> [TcType] -> Id -> TcM (TcId, TcSigInfo)
 mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
-  = do  { uniq <- newUnique
-        ; loc <- getSrcSpanM
-        ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
-        ; local_meth_name <- newLocalName sel_name
+  = do  { let sel_occ = nameOccName sel_name
+        ; meth_name <- newName (mkClassOpAuxOcc sel_occ)
+        ; local_meth_name <- newName sel_occ
                   -- Base the local_meth_name on the selector name, becuase
                   -- type errors from tcInstanceMethodBody come from here
 
@@ -853,7 +852,8 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
                      ; instTcTySig hs_ty sig_ty local_meth_name }
 
             Nothing     -- No type signature
-               -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty)
+               -> do { loc <- getSrcSpanM
+                     ; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) }
               -- Absent a type sig, there are no new scoped type variables here
               -- Only the ones from the instance decl itself, which are already
               -- in scope.  Example:
@@ -1067,16 +1067,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
     tc_item sig_fn (sel_id, dm_info)
       = case findMethodBind (idName sel_id) binds of
-            Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind
-            Nothing        -> traceTc "tc_def" (ppr sel_id) >> 
-                              tc_default sig_fn sel_id dm_info
+            Just (user_bind, bndr_loc) 
+                     -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
+            Nothing  -> do { traceTc "tc_def" (ppr sel_id)
+                           ; tc_default sig_fn sel_id dm_info }
 
     ----------------------
-    tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
-    tc_body sig_fn sel_id generated_code rn_bind
+    tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
+            -> SrcSpan -> TcM (TcId, LHsBind Id)
+    tc_body sig_fn sel_id generated_code rn_bind bndr_loc
       = add_meth_ctxt sel_id generated_code rn_bind $
         do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
-           ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $
+           ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
                                           mkMethIds sig_fn clas tyvars dfun_ev_vars
                                                     inst_tys sel_id
            ; let prags = prag_fn (idName sel_id)
@@ -1094,22 +1096,23 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     tc_default sig_fn sel_id (GenDefMeth dm_name)
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
-           ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind }
+           ; tc_body sig_fn sel_id False {- Not generated code? -} 
+                     meth_bind inst_loc }
 
     tc_default sig_fn sel_id NoDefMeth     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
            ; warnMissingMethodOrAT "method" (idName sel_id)
            ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
-                                         inst_tys sel_id
+                                       inst_tys sel_id
            ; dflags <- getDynFlags
            ; return (meth_id, mkVarBind meth_id $
                               mkLHsWrap lam_wrapper (error_rhs dflags)) }
       where
-        error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags)
-        error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
-        error_msg dflags = L loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags))))
+        error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
+        error_fun    = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
+        error_msg dflags = L inst_loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags))))
         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
-        error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ])
+        error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
 
     tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
@@ -1126,14 +1129,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
 
            ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
-                                                   inst_tys sel_id
+                                                    inst_tys sel_id
            ; dm_id <- tcLookupId dm_name
            ; let dm_inline_prag = idInlinePragma dm_id
                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
                        HsVar dm_id
 
                  local_meth_id = sig_id local_meth_sig
-                 meth_bind = mkVarBind local_meth_id (L loc rhs)
+                 meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
                         -- Copy the inline pragma (if any) from the default
                         -- method to this version. Note [INLINE and default methods]
@@ -1151,7 +1154,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
              -- currently they are rejected with
              --           "INLINE pragma lacks an accompanying binding"
 
-           ; return (meth_id1, L loc bind) }
+           ; return (meth_id1, L inst_loc bind) }
 
     ----------------------
     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
@@ -1171,10 +1174,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                  -- and the specialisation would do nothing. (Indeed it'll provoke
                  -- a warning from the desugarer
            | otherwise 
-           = [ L loc (SpecPrag meth_id wrap inl)
-             | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]
+           = [ L inst_loc (SpecPrag meth_id wrap inl)
+             | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
 
-    loc = getSrcSpan dfun_id
+    inst_loc = getSrcSpan dfun_id
 
         -- For instance decls that come from standalone deriving clauses
         -- we want to print out the full source code if there's an error