Commit 06832583 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent 80893918
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment