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).

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index de0f133..af53740 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/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")
 

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index e1b9bd3..0972530 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/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}

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index b851ec1..b9276b7 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/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

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index d81278a..147f546 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/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}