Commit 3548802d authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

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).
parent ec15937a
......@@ -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")
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment