From 3548802de235eca280982270463db84910ee3748 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Thu, 4 Jan 2007 01:31:56 +0000 Subject: [PATCH] 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 | 60 +++++++++++++++++++++++----------------- compiler/typecheck/TcEnv.lhs | 18 ++++++++---- compiler/types/FamInstEnv.lhs | 46 ------------------------------ compiler/types/Type.lhs | 9 +++++- 4 files changed, 56 insertions(+), 77 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index de0f133..af53740 100644 --- 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 --- 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 --- 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 --- 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} -- 1.7.10.4