More small fixes to generics branch (doesn't compile yet)

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 5aebd37..a251734 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -13,7 +13,7 @@ have a standard form, namely:
 
 \begin{code}
 module MkId (
-        mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+        mkDictFunId, mkDictFunTy, mkDictSelId,
 
         mkDataConIds,
         mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
@@ -826,11 +826,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
 that they aren't discarded by the occurrence analyser.
 
 \begin{code}
-mkDefaultMethodId :: Id                -- Selector Id
-                 -> Name       -- Default method name
-                 -> Id         -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
 mkDictFunId :: Name      -- Name to use for the dict fun;
             -> [TyVar]
             -> ThetaType

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index a5ce2ea..2e93e90 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -180,55 +180,68 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
 -- default method for every class op, regardless of whether or not 
 -- the programmer supplied an explicit default decl for the class.  
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth _ tyvars _ binds_in sigs sig_fn prag_fn (sel_id, dm_info)
-  | NoDefMeth <- dm_info = return emptyBag
-  | otherwise
-  = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info 
-       ; let L loc meth_bind = findMethodBind sel_name binds_in
-                               `orElse` pprPanic "tcDefMeth" (ppr sel_id)
-              dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) })
-                             -- Substitute the meth_name for the binder
-                            -- NB: the binding is always a FunBind
-
-             dm_sig_fn  _  = Just (clas_tv_names ++ tvs, sig_loc)
-              dm_prag_fn _  = prag_fn sel_name
-
-       ; (binds,_) <- tcExtendIdEnv [dm_id] $
-                      tcPolyBinds TopLevel dm_sig_fn dm_prag_fn 
-                            NonRecursive NonRecursive
-                            [dm_bind]
-        ; return binds }
+tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+  = case dm_info of
+      NoDefMeth          -> return emptyBag
+      DefMeth dm_name    -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
+      GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
+                               ; tc_dm dm_name tau } 
+           -- In the case of a generic default, we have to get the type from the signature
+           -- Otherwise we can get it by instantiating the method selector
   where
-    sel_name      = idName sel_id
-    clas_tv_names = map getName tyvars
-
-    -- Find the 'generic op :: ty' signature among the sigs
-    -- If dm_info is GenDefMeth, the corresponding signature
-    -- should jolly well exist!  Hence the panic
-    genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
-                             , n == sel_name ] of
-                      [lty] -> lty
-                      _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
-
-    tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan)
-    -- Make a default-method Id of the appropriate type
-    -- That may entail getting the generic-default signature
-    -- from the type signatures.
-    -- Also return the in-scope tyvars for the default method, and their binding site
-    tc_dm_id NoDefMeth         = panic "tc_dm_id"
-    tc_dm_id (DefMeth dm_name) 
-      | Just (tvs, loc) <- sig_fn sel_name
-      = return (mkDefaultMethodId sel_id dm_name, tvs, loc)
-      | otherwise
-      = pprPanic "No sig for" (ppr sel_name)
-    tc_dm_id (GenDefMeth dm_name)
-      = setSrcSpan loc $
-        do { tau <- tcHsKindedType genop_lhs_ty
-          ; checkValidType (FunSigCtxt sel_name) tau   
-           ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau)
-                    , hsExplicitTvs genop_lhs_ty, loc ) }
-      where
-        loc = getLoc genop_lhs_ty
+    sel_name = idName sel_id
+
+    -- Eg.   class C a where
+    --          op :: forall b. Eq b => a -> [b] -> a
+    --         gen_op :: a -> a
+    --                 generic gen_op :: D a => a -> a
+    -- The "local_dm_ty" is precisely the type in the above
+    -- type signatures, ie with no "forall a. C a =>" prefix
+
+    tc_dm dm_name local_dm_ty
+      = do { local_dm_name <- newLocalName sel_name
+            -- Base the local_dm_name on the selector name, because
+            -- type errors from tcInstanceMethodBody come from here
+
+          ; let meth_bind = findMethodBind sel_name binds_in
+                            `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+                dm_sig_fn  _  = sig_fn sel_name
+                 dm_prag_fn _  = prag_fn sel_name
+
+                dm_ty = mkSigmaTy tyvars [mkClassPred clas tyvars] local_dm_ty
+                dm_id = mkExportedLocalId dm_name dm_ty
+                local_dm_id = mkLocalId local_dm_name local_dm_type
+
+           ; dm_id_w_inline <- addInlinePrags dm_id prags
+           ; spec_prags     <- tcSpecPrags dm_id prags
+
+           ; warnTc (not (null spec_prags))
+                    (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                     <+> quotes (ppr sel_name))
+
+           ; dm_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+                                             dm_id_w_inline local_dm_id dm_sig_fn 
+                                             IsDefaultMethodId dm_bind
+
+           ; return (unitBag dm_bind) }
+
+    tc_genop_ty :: LHsType Name -> TcM Type
+    tc_genop_ty hs_ty 
+       = setSrcSpan (getLoc hs_ty) $
+         do { tau <- tcHsKindedType hs_ty
+            ; checkValidType (FunSigCtxt sel_name) tau 
+            ; return tau }
+
+findGenericSig :: [LSig Name] -> Name -> LSig Name
+-- Find the 'generic op :: ty' signature among the sigs
+-- If dm_info is GenDefMeth, the corresponding signature
+-- should jolly well exist!  Hence the panic
+findGenericSig sigs sel_name 
+  = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+         , n == sel_name ] of
+      [lty] -> lty
+      _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
 
 ---------------
 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index cb07c69..c50dc99 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -30,7 +30,6 @@ import Class
 import TyCon
 import DataCon
 import Id
-import MkId            ( mkDefaultMethodId )
 import MkCore          ( rEC_SEL_ERROR_ID )
 import IdInfo
 import Var
@@ -1195,7 +1194,7 @@ checkValidClass cls
 mkDefaultMethodIds :: [TyThing] -> [Id]
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds things
-  = [ mkDefaultMethodId sel_id dm_name
+  = [ mkExportedLocalId dm_name (idType sel_id)
     | AClass cls <- things
     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
 \end{code}