import TcBinds
import TcTyClsDecls
import TcClassDcl
+import TcPat( addInlinePrags )
import TcRnMonad
import TcMType
import TcType
import DataCon
import Class
import Var
-import VarSet ( emptyVarSet )
import CoreUtils ( mkPiTypes )
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var) )
mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
-- NOT FINISHED!
- ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet
+ ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol
inst_tyvars' dfun_ev_vars $
emitWanteds ScOrigin sc_eqs
self_ev_bind@(EvBind self_dict _)
(sc_sel, sc_pred)
= do { (ev_binds, wanted, sc_dict)
- <- newImplication InstSkol emptyVarSet tyvars dicts $
+ <- newImplication InstSkol tyvars dicts $
emitWanted ScOrigin sc_pred
; simplifySuperClass self_dict wanted
; let spec_ty = mkSigmaTy tyvars theta tau
; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
(idType dfun_id) spec_ty
- ; return (SpecPrag co_fn defaultInlinePragma) }
+ ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
where
spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
----------------------
tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
tc_body sel_id generated_code rn_bind
- = add_meth_ctxt generated_code rn_bind $
+ = add_meth_ctxt sel_id generated_code rn_bind $
do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
- ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True
- meth_id (prag_fn (idName sel_id))
-
+ ; let prags = prag_fn (idName sel_id)
+ ; meth_id1 <- addInlinePrags meth_id prags
+ ; spec_prags <- tcSpecPrags meth_id1 prags
; bind <- tcInstanceMethodBody InstSkol
- tyvars dfun_ev_vars
- mb_dict_ev
- meth_id1 local_meth_id
- meth_sig_fn
- (SpecPrags (spec_inst_prags ++ spec_prags))
+ tyvars dfun_ev_vars mb_dict_ev
+ meth_id1 local_meth_id meth_sig_fn
+ (mk_meth_spec_prags meth_id1 spec_prags)
rn_bind
; return (meth_id1, bind) }
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [( tyvars, meth_id1, local_meth_id
- , SpecPrags spec_inst_prags)]
+ , mk_meth_spec_prags meth_id1 [])]
, abs_ev_binds = EvBinds (unitBag self_dict_ev)
, abs_binds = unitBag meth_bind }
-- Default methods in an instance declaration can't have their own
; return (meth_id1, L loc bind) }
----------------------
+ mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
+ -- Adapt the SPECIALISE pragmas to work for this method Id
+ -- There are two sources:
+ -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
+ -- These ones have the dfun inside, but [perhaps surprisingly]
+ -- the correct wrapper
+ -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+ mk_meth_spec_prags meth_id spec_prags_for_me
+ = SpecPrags (spec_prags_for_me ++
+ [ L loc (SpecPrag meth_id wrap inl)
+ | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
+
loc = getSrcSpan dfun_id
meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
-- But there are no scoped type variables from local_method_id
-- For instance decls that come from standalone deriving clauses
-- we want to print out the full source code if there's an error
-- because otherwise the user won't see the code at all
- add_meth_ctxt generated_code rn_bind thing
- | generated_code = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
+ add_meth_ctxt sel_id generated_code rn_bind thing
+ | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
| otherwise = thing
-- by the constraint solver, since the <context> may be
-- user-specified.
- = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
+ = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
emitWanted ScOrigin rep_pred
; mapAndUnzipM (tc_item rep_d_stuff) op_items }
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
-derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
-derivBindCtxt clas tys bind
- = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
- <+> quotes (pprClassPred clas tys) <> colon
- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt sel_id clas tys _bind
+ = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
+ , nest 2 (ptext (sLit "in a standalone derived instance for")
+ <+> quotes (pprClassPred clas tys) <> colon)
+ , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
+
+-- Too voluminous
+-- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
warnMissingMethod :: Id -> TcM ()
warnMissingMethod sel_id