Fix and improve deriving for indexed data types

- The test for being able to derive the requested classes needs to be made
  with the representation tycon (not the family tycon).
- Standalone deriving for indexed types requires the instance types in the
  derive clause to match a data/newtype instance exactly (modulo alpha).

compiler/typecheck/TcDeriv.lhs

@@ -419,7 +419,7 @@ baleOut err = addErrTc err >> returnM (Nothing, Nothing)
 
 \begin{code}
 mkDataTypeEqn orig gla_exts tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
-  | Just err <- checkSideConditions gla_exts cls cls_tys tycon tc_args
+  | Just err <- checkSideConditions gla_exts cls cls_tys rep_tc
   = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
 
   | otherwise 
@@ -464,15 +464,19 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
 
-checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> [TcType] -> Maybe SDoc
-checkSideConditions gla_exts cls cls_tys tycon tc_tys
+checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
+checkSideConditions gla_exts cls cls_tys rep_tc
   | notNull cls_tys	
   = Just ty_args_why	-- e.g. deriving( Foo s )
   | otherwise
   = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
 	[]     -> Just (non_std_why cls)
-	[cond] -> cond (gla_exts, tycon)
+	[cond] -> cond (gla_exts, rep_tc)
 	other  -> pprPanic "checkSideConditions" (ppr cls)
   where
     ty_args_why	= quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
@@ -508,48 +512,54 @@ andCond c1 c2 tc = case c1 tc of
 		     Just x  -> Just x	-- c1 fails
 
 cond_std :: Condition
-cond_std (gla_exts, tycon)
+cond_std (gla_exts, rep_tc)
   | any (not . isVanillaDataCon) data_cons = Just existential_why     
   | null data_cons		    	   = Just no_cons_why
   | otherwise      			   = Nothing
   where
-    data_cons       = tyConDataCons tycon
-    no_cons_why	    = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
-    existential_why = quotes (ppr tycon) <+> ptext SLIT("has non-Haskell-98 constructor(s)")
+    data_cons       = tyConDataCons rep_tc
+    no_cons_why	    = quotes (pprSourceTyCon rep_tc) <+> 
+		      ptext SLIT("has no data constructors")
+    existential_why = quotes (pprSourceTyCon rep_tc) <+> 
+		      ptext SLIT("has non-Haskell-98 constructor(s)")
   
 cond_isEnumeration :: Condition
-cond_isEnumeration (gla_exts, tycon)
-  | isEnumerationTyCon tycon = Nothing
-  | otherwise		     = Just why
+cond_isEnumeration (gla_exts, rep_tc)
+  | isEnumerationTyCon rep_tc = Nothing
+  | otherwise		      = Just why
   where
-    why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
+    why = quotes (pprSourceTyCon rep_tc) <+> 
+	  ptext SLIT("has non-nullary constructors")
 
 cond_isProduct :: Condition
-cond_isProduct (gla_exts, tycon)
-  | isProductTyCon tycon = Nothing
-  | otherwise	         = Just why
+cond_isProduct (gla_exts, rep_tc)
+  | isProductTyCon rep_tc = Nothing
+  | otherwise	          = Just why
   where
-    why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
+    why = (pprSourceTyCon rep_tc) <+> 
+	  ptext SLIT("has more than one constructor")
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
 -- Currently: (a) args all of kind *
 --	      (b) 7 or fewer args
-cond_typeableOK (gla_exts, tycon)
-  | tyConArity tycon > 7	= Just too_many
-  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) 
+cond_typeableOK (gla_exts, rep_tc)
+  | tyConArity rep_tc > 7	= Just too_many
+  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc)) 
                                 = Just bad_kind
-  | isFamInstTyCon tycon	= Just fam_inst  -- no Typable for family insts
+  | isFamInstTyCon rep_tc	= Just fam_inst  -- no Typable for family insts
   | otherwise	  		= Nothing
   where
-    too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
-    bad_kind = quotes (ppr tycon) <+> 
+    too_many = quotes (pprSourceTyCon rep_tc) <+> 
+	       ptext SLIT("has too many arguments")
+    bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
 	       ptext SLIT("has arguments of kind other than `*'")
-    fam_inst = quotes (ppr tycon) <+> ptext SLIT("is a type family")
+    fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
+	       ptext SLIT("is a type family")
 
 cond_glaExts :: Condition
-cond_glaExts (gla_exts, tycon) | gla_exts  = Nothing
-			       | otherwise = Just why
+cond_glaExts (gla_exts, _rep_tc) | gla_exts  = Nothing
+			         | otherwise = Just why
   where
     why  = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
 

compiler/typecheck/TcEnv.lhs

@@ -170,10 +170,18 @@ tcLookupFamInst tycon tys
        ; eps <- getEps
        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
        ; case lookupFamInstEnv instEnv tycon tys of
-	   [(subst,fam_inst)] -> return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
+
+	   [(subst, fam_inst)] | variable_only_subst -> 
+	     return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
 		where	-- NB: assumption is that (tyConTyVars rep_tc) is in 
 			--     the domain of the substitution
-		  rep_tc = famInstTyCon fam_inst 
+		  rep_tc              = famInstTyCon fam_inst
+		  subst_domain        = varEnvElts . getTvSubstEnv $ subst
+		  tvs		      = map (Type.getTyVar "tcLookupFamInst") 
+					    subst_domain
+		  variable_only_subst = all Type.isTyVarTy subst_domain &&
+					sizeVarSet (mkVarSet tvs) == length tvs
+					-- renaming may have no repetitions
 
 	   other -> famInstNotFound tycon tys other
        }
@@ -680,7 +688,7 @@ wrongThingErr expected thing name
 famInstNotFound tycon tys what
   = failWithTc (msg <+> quotes (ppr tycon <+> hsep (map pprParendType tys)))
   where
-    msg = case what of
-		[] -> ptext SLIT("No instance for")
-		xs -> ptext SLIT("More than one instance for")
+    msg = ptext $ if length what > 1 
+		  then SLIT("More than one family instance for")
+		  else SLIT("No family instance exactly matching")
 \end{code}

compiler/types/FamInstEnv.lhs

@@ -188,52 +188,6 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
 %*									*
 %************************************************************************
 
-@lookupFamInstEnvExact@ looks up in a @FamInstEnv@ using an exact match.
-This is used when we want the @TyCon@ of a particular family instance (e.g.,
-during deriving classes).
-
-\begin{code}
-{-		NOT NEEDED ANY MORE
-lookupFamInstEnvExact :: (FamInstEnv		-- External package inst-env
-		         ,FamInstEnv)		-- Home-package inst-env
-		      -> TyCon -> [Type]	-- What we are looking for
-	              -> Maybe FamInst
-lookupFamInstEnvExact (pkg_ie, home_ie) fam tys
-  = home_matches `mplus` pkg_matches
-  where
-    rough_tcs    = roughMatchTcs tys
-    all_tvs      = all isNothing rough_tcs
-    home_matches = lookup home_ie 
-    pkg_matches  = lookup pkg_ie  
-
-    --------------
-    lookup env = case lookupUFM env fam of
-		   Nothing -> Nothing		-- No instances for this class
-		   Just (FamIE insts has_tv_insts)
-		       -- Short cut for common case:
-		       --   The thing we are looking up is of form (C a
-		       --   b c), and the FamIE has no instances of
-		       --   that form, so don't bother to search 
-		     | all_tvs && not has_tv_insts -> Nothing
-		     | otherwise                   -> find insts
-
-    --------------
-    find [] = Nothing
-    find (item@(FamInst { fi_tcs = mb_tcs, fi_tys = tpl_tys }) : rest)
-	-- Fast check for no match, uses the "rough match" fields
-      | instanceCantMatch rough_tcs mb_tcs
-      = find rest
-
-        -- Proper check
-      | tcEqTypes tpl_tys tys
-      = Just item
-
-        -- No match => try next
-      | otherwise
-      = find rest
--}
-\end{code}
-
 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
 Multiple matches are only possible in case of type families (not data
 families), and then, it doesn't matter which match we choose (as the

compiler/types/Type.lhs

@@ -55,7 +55,7 @@ module Type (
 
 	-- Source types
 	predTypeRep, mkPredTy, mkPredTys,
-	tyConOrigHead,
+	tyConOrigHead, pprSourceTyCon,
 
 	-- Newtypes
 	splitRecNewType_maybe, newTyConInstRhs,
@@ -609,6 +609,13 @@ tyConOrigHead :: TyCon -> (TyCon, [Type])
 tyConOrigHead tycon = case tyConFamInst_maybe tycon of
 		        Nothing      -> (tycon, mkTyVarTys (tyConTyVars tycon))
 			Just famInst -> famInst
+
+-- Pretty prints a tycon, using the family instance in case of a
+-- representation tycon.
+pprSourceTyCon tycon | Just (repTyCon, tys) <- tyConFamInst_maybe tycon =
+  ppr $ repTyCon `TyConApp` tys	       -- can't be FunTyCon
+                     | otherwise                                        =
+  ppr tycon
 \end{code}