Rejig the way in which generic default method signatures are checked

- Check GenericSig in tcClassSigs, along with TypeSig
- Add the generic default methods to the type envt
- Look them up via tcLookupId in TcClassDcl.tcDefMeth

Much nicer!

6 files changed, 77 insertions, 78 deletions

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index a3f441eb3e..eabe8c45aa 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -222,8 +222,8 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 ------------------------------------------------------
 \begin{code}
 type TcMethInfo = (Name, DefMethSpec, Type)  
-        -- A temporary intermediate, to communicate between tcClassSigs and
-        -- buildClass.
+        -- A temporary intermediate, to communicate between 
+        -- tcClassSigs and buildClass.
 
 buildClass :: Bool		-- True <=> do not include unfoldings 
 				--	    on dict selectors
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 493466b612..22aa3f4f04 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1036,7 +1036,9 @@ implicitTyThings (ADataCon dc)  = map AnId (dataConImplicitIds dc)
     
 implicitClassThings :: Class -> [TyThing]
 implicitClassThings cl 
-  = -- dictionary datatype:
+  = -- Does not include default methods, because those Ids may have
+    --    their own pragmas, unfoldings etc, not derived from the Class object
+    -- Dictionary datatype:
     --    [extras_plus:]
     --      type constructor 
     --    [recursive call:]
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index fe7cb81639..8fc8a24e7a 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -27,6 +27,8 @@ import BuildTyCl( TcMethInfo )
 import Class
 import Id
 import Name
+import NameEnv
+import NameSet
 import Var
 import Outputable
 import DynFlags
@@ -81,39 +83,43 @@ Death to "ExpandingDicts".
 %************************************************************************
 
 \begin{code}
-tcClassSigs :: Name	    		-- Name of the class
+tcClassSigs :: Name	             -- Name of the class
 	    -> [LSig Name]
 	    -> LHsBinds Name
-	    -> TcM [TcMethInfo]    -- One for each method
-
+	    -> TcM ([TcMethInfo],    -- Exactly one for each method
+                    NameEnv Type)    -- Types of the generic-default methods
 tcClassSigs clas sigs def_methods
-  = do { -- Check that all def_methods are in the class
-       ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
-       ; let op_names = [ n | (n,_,_) <- op_info ]
+  = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+       ; let gen_dm_env = mkNameEnv gen_dm_prs
+
+       ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
 
+       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
        ; sequence_ [ failWithTc (badMethodErr clas n)
-                   | n <- dm_bind_names, not (n `elem` op_names) ]
+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
 		   -- Value binding for non class-method (ie no TypeSig)
 
        ; sequence_ [ failWithTc (badGenericMethod clas n)
-                   | n <- genop_names, not (n `elem` dm_bind_names) ]
+                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
 		   -- Generic signature without value binding
 
-       ; return op_info }
+       ; return (op_info, gen_dm_env) }
   where
+    vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty) <- sigs]
+    gen_sigs     = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
     dm_bind_names :: [Name]	-- These ones have a value binding in the class decl
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
-    genop_names :: [Name]   -- These ones have a generic signature
-    genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
-
-    tc_sig (TypeSig (L _ op_name) op_hs_ty)
+    tc_sig genop_env (L _ op_name, op_hs_ty)
       = do { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
-           ; let dm | op_name `elem` genop_names   = GenericDM
-                    | op_name `elem` dm_bind_names = VanillaDM
-                    | otherwise                    = NoDM
+           ; let dm | op_name `elemNameEnv` genop_env = GenericDM
+                    | op_name `elem` dm_bind_names    = VanillaDM
+                    | otherwise                       = NoDM
            ; return (op_name, dm, op_ty) }
-    tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
+
+    tc_gen_sig (L _ op_name, gen_hs_ty)
+      = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+           ; return (op_name, gen_op_ty) }
 \end{code}
 
 
@@ -151,7 +157,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 
 	; traceTc "TIM2" (ppr sigs)
 	; let tc_dm = tcDefMeth clas clas_tyvars
-				this_dict default_binds sigs
+				this_dict default_binds 
 	      			sig_fn prag_fn
 
 	; dm_binds <- tcExtendTyVarEnv clas_tyvars $
@@ -161,7 +167,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
           -> SigFun -> PragFun -> ClassOpItem
           -> TcM (LHsBinds TcId)
 -- Generate code for polymorphic default methods only (hence DefMeth)
@@ -170,15 +176,12 @@ 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 clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
   = case dm_info of
       NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
                                ; 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
+      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
@@ -193,13 +196,13 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
     -- 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
+    tc_dm dm_name 
+      = do { dm_id <- tcLookupId dm_name
+	   ; local_dm_name <- newLocalName sel_name
  	     -- Base the local_dm_name on the selector name, because
  	     -- type errors from tcInstanceMethodBody come from here
 
-	   ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
-	         dm_id = mkExportedLocalId dm_name dm_ty
+           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
 	         local_dm_id = mkLocalId local_dm_name local_dm_ty
 
            ; dm_id_w_inline <- addInlinePrags dm_id prags
@@ -215,23 +218,6 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
 
            ; return (unitBag tc_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 -> LHsType 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]
                      -> Id -> Id
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 2542ad3b3d..5aa6959141 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -245,7 +245,6 @@ tcRnImports hsc_env this_mod import_decls
 		-- interfaces, so that their rules and instance decls will be
 		-- found.
 	; loadOrphanModules (imp_orphs  imports) False
-	; loadOrphanModules (imp_finsts imports) True 
 
 		-- Check type-familily consistency
 	; traceRn (text "rn1: checking family instance consistency")
@@ -299,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 	-- any mutually recursive types are done right
 	-- Just discard the auxiliary bindings; they are generated 
 	-- only for Haskell source code, and should already be in Core
-   (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+   (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
 
    setGblEnv tcg_env $ do {
 	-- Make the new type env available to stuff slurped from interface files
@@ -500,10 +499,9 @@ tcRnHsBootDecls decls
 
 		-- Typecheck type/class decls
 	; traceTc "Tc2" empty
-	; (tcg_env, aux_binds, dm_ids, _) 
+	; (tcg_env, aux_binds) 
                <- tcTyAndClassDecls emptyModDetails tycl_decls
-	; setGblEnv tcg_env    $ 
-          tcExtendIdEnv dm_ids $ do {
+	; setGblEnv tcg_env    $ do {
 
 		-- Typecheck instance decls
 		-- Family instance declarations are rejected here
@@ -837,11 +835,10 @@ tcTopSrcDecls boot_details
 		-- The latter come in via tycl_decls
         traceTc "Tc2" empty ;
 
-	(tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ;
+	(tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
 		-- If there are any errors, tcTyAndClassDecls fails here
 	
-	setGblEnv tcg_env	$
-        tcExtendIdEnv dm_ids    $ do {
+	setGblEnv tcg_env	$ do {
 
 		-- Source-language instances, including derivings,
 		-- and import the supporting declarations
@@ -877,7 +874,7 @@ tcTopSrcDecls boot_details
                 -- Second pass over class and instance declarations, 
                 -- now using the kind-checked decls
         traceTc "Tc6" empty ;
-        inst_binds <- tcInstDecls2 kc_decls inst_infos ;
+        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
 
                 -- Foreign exports
         traceTc "Tc7" empty ;
@@ -1387,7 +1384,6 @@ tcGetModuleExports mod directlyImpMods
   		-- Load any orphan-module and family instance-module
   		-- interfaces, so their instances are visible.
        ; loadOrphanModules (dep_orphs (mi_deps iface)) False 
-       ; loadOrphanModules (dep_finsts (mi_deps iface)) True
 
                 -- Check that the family instances of all directly loaded
                 -- modules are consistent.
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index d4e859be38..8d62b78580 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -35,6 +35,7 @@ import IdInfo
 import Var
 import VarSet
 import Name
+import NameEnv
 import Outputable
 import Maybes
 import Unify
@@ -65,9 +66,7 @@ tcTyAndClassDecls :: ModDetails
                    -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
    	           -> TcM (TcGblEnv,   	     -- Input env extended by types and classes 
 					     -- and their implicit Ids,DataCons
-		           HsValBinds Name,  -- Renamed bindings for record selectors
-			   [Id],      	     -- Default method ids
-                           [LTyClDecl Name]) -- Kind-checked declarations
+		           HsValBinds Name)  -- Renamed bindings for record selectors
 -- Fails if there are any errors
 
 tcTyAndClassDecls boot_details decls_s
@@ -109,11 +108,10 @@ tcTyAndClassDecls boot_details decls_s
 	      ; rec_sel_binds   = mkRecSelBinds [tc | ATyCon tc <- tyclss]
               ; dm_ids          = mkDefaultMethodIds tyclss }
 
-  	; env <- tcExtendGlobalEnv implicit_things getGblEnv
-          -- We need the kind-checked declarations later, so we return them
-          -- from here
-        ; kc_decls <- kcTyClDecls tyclds_s
-        ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
+  	; env <- tcExtendGlobalEnv implicit_things $
+                 tcExtendGlobalValEnv dm_ids $
+                 getGblEnv
+        ; return (env, rec_sel_binds) } }
                     
 zipRecTyClss :: [[LTyClDecl Name]]
              -> [TyThing]           -- Knot-tied
@@ -524,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec
     tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mapM (addLocM tc_fundep) fundeps
-  ; sig_stuff <- tcClassSigs class_name sigs meths
+  ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
   ; clas <- fixM $ \ clas -> do
 	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
@@ -537,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec
             ; buildClass False {- Must include unfoldings for selectors -}
 			 class_name tvs' ctxt' fds' (concat atss')
 			 sig_stuff tc_isrec }
-  ; return (AClass clas : map ATyCon (classATs clas))
+
+  ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+                     | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+                     , let gen_dm_tau = expectJust "tcTyClDecl1" $
+                                        lookupNameEnv gen_dm_env (idName sel_id)
+		     , let gen_dm_ty = mkSigmaTy tvs' 
+                                                 [mkClassPred clas (mkTyVarTys tvs')] 
+                                                 gen_dm_tau
+                     ]
+        class_ats = map ATyCon (classATs clas)
+
+  ; return (AClass clas : gen_dm_ids ++ class_ats )
       -- NB: Order is important due to the call to `mkGlobalThings' when
       --     tying the the type and class declaration type checking knot.
   }
@@ -802,6 +811,8 @@ checkValidTyCl decl
 	    ATyCon tc -> checkValidTyCon tc
 	    AClass cl -> do { checkValidClass cl 
                             ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+            AnId _    -> return ()  -- Generic default methods are checked
+	    	      	 	    -- with their parent class
             _         -> panic "checkValidTyCl"
 	; traceTc "Done validity of" (ppr thing)	
 	}
@@ -964,7 +975,7 @@ checkValidClass cls
     unary 	= isSingleton tyvars
     no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
-    check_op constrained_class_methods (sel_id, _) 
+    check_op constrained_class_methods (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
 	{ checkValidTheta SigmaCtxt (tail theta)
 		-- The 'tail' removes the initial (C a) from the
@@ -982,6 +993,11 @@ checkValidClass cls
 	; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
 	; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
 	          (noClassTyVarErr cls sel_id)
+
+        ; case dm of
+            GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+                                     ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+            _                  -> return ()
 	}
 	where
 	  op_name = idName sel_id
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index cb61726a5c..15c817a657 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -30,7 +30,7 @@ import NameSet
 import Digraph
 import BasicTypes
 import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
 import Util ( isSingleton )
 import Data.List
 \end{code}
@@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss
                 nt_loop_breakers  `unionNameSets`
                 prod_loop_breakers
 
-    all_tycons = [ tc | tycls <- tyclss,
+    all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
                            -- Recursion of newtypes/data types can happen via
                            -- the class TyCon, so tyclss includes the class tycons
-                        let tc = getTyCon tycls,
-                        not (tyConName tc `elemNameSet` boot_name_set) ]
+                      , not (tyConName tc `elemNameSet` boot_name_set) ]
                            -- Remove the boot_name_set because they are going
                            -- to be loop breakers regardless.
 
@@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss
 new_tc_rhs :: TyCon -> Type
 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _           = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _           = Nothing
 
 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 -- Finds a set of tycons that cut all loops