Tidy-up sweep, following the Great Skolemisation Simplification

[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 571cd70..4e40be3 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -12,6 +12,7 @@ import HsSyn
 import TcBinds
 import TcTyClsDecls
 import TcClassDcl
+import TcPat( addInlinePrags )
 import TcRnMonad
 import TcMType
 import TcType
@@ -19,6 +20,7 @@ import Inst
 import InstEnv
 import FamInst
 import FamInstEnv
+import MkCore  ( nO_METHOD_BINDING_ERROR_ID )
 import TcDeriv
 import TcEnv
 import RnSource ( addTcgDUs )
@@ -31,7 +33,6 @@ import TyCon
 import DataCon
 import Class
 import Var
-import VarSet    ( emptyVarSet )
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn   ( Expr(Var) )
@@ -636,7 +637,7 @@ tc_inst_decl2 dfun_id inst_binds
                                     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
 
@@ -705,7 +706,7 @@ tcSuperClass tyvars dicts
              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
@@ -787,7 +788,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
         ; 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)
 
@@ -834,18 +835,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     ----------------------
     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) }
 
@@ -895,7 +894,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                            
                  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 
@@ -906,6 +905,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
            ; 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
@@ -924,8 +935,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
        -- 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
 
 
@@ -958,7 +969,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 -- 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 }
@@ -1026,11 +1037,15 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
 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