Commit 380512de authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Deriving for indexed data types

- This patch implements deriving clauses for data instance declarations
  (toplevel and associated)
- Doesn't support standalone deriving.  This could be easily supported,
  but requires an extension of the syntax of standalone deriving clauses.
  Björn, fancy adding this?
- We cannot derive Typeable.  This seems a problem of notation, more than 
  anything else.  Why?  For a binary vanilla data type "T a b", we would 
  generate an instance Typeable2 T; ie, the instance is for the constructor
  alone.  In the case of a family instance, such as (S [a] (Maybe b)), we
  simply have no means to denote the associated constuctor.  It appears to
  require type level lambda - something like (/\a b. S [a] (Maybe b).
- Derivings are for *individual* family *instances*, not for entire families.
  Currently, I know of no simple translation of class instances for entire 
  families to System F_C.  This actually seems to be similar to implementing
  open data types à la Löh & Hinze.
- This patch only covers data types, not newtypes.
parent 5f8b35ad
......@@ -135,10 +135,14 @@ So, here are the synonyms for the ``equation'' structures:
type DerivEqn = (SrcSpan, InstOrigin, Name, Class, TyCon, [TyVar], DerivRhs)
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the RHS
-- For family indexes, the tycon is the representation tycon
pprDerivEqn :: DerivEqn -> SDoc
pprDerivEqn (l,_,n,c,tc,tvs,rhs)
= parens (hsep [ppr l, ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
pprDerivEqn (l, _, n, c, tc, tvs, rhs)
= parens (hsep [ppr l, ppr n, ppr c, ppr origTc, ppr tys] <+> equals <+>
ppr rhs)
where
(origTc, tys) = tyConOrigHead tc
type DerivRhs = ThetaType
type DerivSoln = DerivRhs
......@@ -270,7 +274,8 @@ deriveOrdinaryStuff overlap_flag eqns
; extra_binds <- genTaggeryBinds inst_infos
-- Done
; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s))
; returnM (map fst inst_infos,
unionManyBags (extra_binds : aux_binds_s))
}
-----------------------------------------
......@@ -328,6 +333,13 @@ when the dict is constructed in TcInstDcls.tcInstDecl2
\begin{code}
type DerivSpec = (SrcSpan, -- location of the deriving clause
InstOrigin, -- deriving at data decl or standalone?
NewOrData, -- newtype or data type
Name, -- Type constructor for which we derive
Maybe [LHsType Name], -- Type indexes if indexed type
LHsType Name) -- Class instance to be generated
makeDerivEqns :: OverlapFlag
-> [LTyClDecl Name]
-> [LDerivDecl Name]
......@@ -335,44 +347,60 @@ makeDerivEqns :: OverlapFlag
[InstInfo]) -- Special newtype derivings
makeDerivEqns overlap_flag tycl_decls deriv_decls
= do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes
= do derive_top_level <- mapM top_level_deriv deriv_decls
(maybe_ordinaries, maybe_newtypes)
<- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level)
<- mapAndUnzipM mk_eqn (derive_data ++ catMaybes derive_top_level)
return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)]
-- Find the (nd, TyCon, Pred) pairs that must be `derived'
derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, nd, tycon, pred)
| L _ (TyData { tcdND = nd, tcdLName = L _ tycon,
tcdDerivs = Just preds }) <- tycl_decls,
-- Deriving clauses at data declarations
derive_data :: [DerivSpec]
derive_data = [ (loc, DerivOrigin, nd, tycon, tyPats, pred)
| L loc (TyData { tcdND = nd, tcdLName = L _ tycon,
tcdTyPats = tyPats,
tcdDerivs = Just preds }) <- tycl_decls,
pred <- preds ]
top_level_deriv :: LDerivDecl Name -> TcM (Maybe (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name))
top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $
-- Standalone deriving declarations
top_level_deriv :: LDerivDecl Name -> TcM (Maybe DerivSpec)
top_level_deriv d@(L loc (DerivDecl inst ty_name)) =
recoverM (returnM Nothing) $ setSrcSpan loc $
do tycon <- tcLookupLocatedTyCon ty_name
let new_or_data = if isNewTyCon tycon then NewType else DataType
traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst))
return $ Just (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst)
traceTc (text "Stand-alone deriving:" <+>
ppr (new_or_data, unLoc ty_name, inst))
return $ Just (loc, StandAloneDerivOrigin, new_or_data,
unLoc ty_name, Nothing, inst)
------------------------------------------------------------------
-- takes (whether newtype or data, name of data type, partially applied type class)
mk_eqn :: (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- Derive equation/inst info for one deriving clause (data or standalone)
mk_eqn :: DerivSpec -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
--
-- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign
-- we allow deriving (forall a. C [a]).
mk_eqn (loc, orig, new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
setSrcSpan loc $
addErrCtxt (derivCtxt tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
doptM Opt_GlasgowExts `thenM` \ gla_exts ->
mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
-- The "deriv_ty" is a LHsType to take account of the fact that for
-- newtype deriving we allow deriving (forall a. C [a]).
mk_eqn (loc, orig, new_or_data, tycon_name, mb_tys, hs_deriv_ty)
= setSrcSpan loc $
addErrCtxt (derivCtxt tycon_name mb_tys) $
do { named_tycon <- tcLookupTyCon tycon_name
-- Lookup representation tycon in case of a family instance
; tycon <- case mb_tys of
Nothing -> return named_tycon
Just hsTys -> do
tys <- mapM dsHsType hsTys
tcLookupFamInst named_tycon tys
-- Enable deriving preds to mention the type variables in the
-- instance type
; tcExtendTyVarEnv (tyConTyVars tycon) $ do
--
{ (deriv_tvs, clas, tys) <- tcHsDeriv hs_deriv_ty
; gla_exts <- doptM Opt_GlasgowExts
; mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
}}
------------------------------------------------------------------
-- data/newtype T a = ... deriving( C t1 t2 )
......@@ -381,10 +409,12 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls
mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys
| Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
= bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
= bale_out (derivingThingErr clas tys origTyCon ttys err)
| otherwise
= do { eqn <- mkDataTypeEqn loc orig tycon clas
; returnM (Just eqn, Nothing) }
where
(origTyCon, ttys) = tyConOrigHead tycon
mk_eqn_help loc orig gla_exts NewType tycon deriv_tvs clas tys
| can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
......@@ -528,7 +558,7 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls
&& (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
&& (tyVarsOfTypes tys `disjointVarSet` dropped_tvs)
cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
cant_derive_err = derivingThingErr clas tys tycon (mkTyVarTys tyvars_to_keep)
(vcat [ptext SLIT("even with cunning newtype deriving:"),
if isRecursiveTyCon tycon then
ptext SLIT("the newtype is recursive")
......@@ -545,7 +575,7 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls
else empty
])
non_std_err = derivingThingErr clas tys tycon tyvars_to_keep
non_std_err = derivingThingErr clas tys tycon (mkTyVarTys tyvars_to_keep)
(vcat [non_std_why clas,
ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])
......@@ -588,7 +618,8 @@ mkDataTypeEqn loc orig tycon clas
| otherwise
= do { dfun_name <- new_dfun_name clas tycon
; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) }
; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints)
}
where
tyvars = tyConTyVars tycon
constraints = extra_constraints ++ ordinary_constraints
......@@ -598,7 +629,7 @@ mkDataTypeEqn loc orig tycon clas
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
arg_ty <- dataConInstOrigArgTys data_con (mkTyVarTys tyvars),
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
......@@ -678,12 +709,16 @@ cond_typeableOK :: Condition
-- 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)) = Just bad_kind
| otherwise = Nothing
| tyConArity tycon > 7 = Just too_many
| not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon))
= Just bad_kind
| isFamInstTyCon tycon = 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) <+> ptext SLIT("has arguments of kind other than `*'")
bad_kind = quotes (ppr tycon) <+>
ptext SLIT("has arguments of kind other than `*'")
fam_inst = quotes (ppr tycon) <+> ptext SLIT("is a type family")
cond_glaExts :: Condition
cond_glaExts (gla_exts, tycon) | gla_exts = Nothing
......@@ -757,9 +792,9 @@ solveDerivEqns overlap_flag orig_eqns
------------------------------------------------------------------
gen_soln :: DerivEqn -> TcM [PredType]
gen_soln (loc, orig, _, clas, tc,tyvars,deriv_rhs)
gen_soln (loc, orig, _, clas, tc, tyvars, deriv_rhs)
= setSrcSpan loc $
do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
do { let inst_tys = [origHead]
; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
tcSimplifyDeriv orig tc tyvars deriv_rhs
-- Claim: the result instance declaration is guaranteed valid
......@@ -767,15 +802,15 @@ solveDerivEqns overlap_flag orig_eqns
-- checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
where
origHead = uncurry mkTyConApp (tyConOrigHead tc)
------------------------------------------------------------------
mk_inst_spec :: DerivEqn -> DerivSoln -> Instance
mk_inst_spec (loc, orig, dfun_name, clas, tycon, tyvars, _) theta
= mkLocalInstance dfun overlap_flag
where
dfun = mkDictFunId dfun_name tyvars theta clas
[mkTyConApp tycon (mkTyVarTys tyvars)]
dfun = mkDictFunId dfun_name tyvars theta clas [origHead]
origHead = uncurry mkTyConApp (tyConOrigHead tycon)
extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
-- Add new locally-defined instances; don't bother to check
......@@ -850,16 +885,27 @@ the renamer. What a great hack!
\end{itemize}
\begin{code}
-- Generate the InstInfo for the required instance,
-- Generate the InstInfo for the required instance paired with the
-- *representation* tycon for that instance,
-- plus any auxiliary bindings required
genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName)
--
-- Representation tycons differ from the tycon in the instance signature in
-- case of instances for indexed families.
--
genInst :: Instance -> TcM ((InstInfo, TyCon), LHsBinds RdrName)
genInst spec
= do { fix_env <- getFixityEnv
; let
(tyvars,_,clas,[ty]) = instanceHead spec
clas_nm = className clas
tycon = tcTyConAppTyCon ty
(meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
(visible_tycon, tyArgs) = tcSplitTyConApp ty
-- In case of a family instance, we need to use the representation
-- tycon (after all it has the data constructors)
; tycon <- if isOpenTyCon visible_tycon
then tcLookupFamInst visible_tycon tyArgs
else return visible_tycon
; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
-- Bring the right type variables into
-- scope, and rename the method binds
......@@ -870,10 +916,10 @@ genInst spec
rnMethodBinds clas_nm (\n -> []) [] meth_binds
-- Build the InstInfo
; return (InstInfo { iSpec = spec,
iBinds = VanillaInst rn_meth_binds [] },
; return ((InstInfo { iSpec = spec,
iBinds = VanillaInst rn_meth_binds [] }, tycon),
aux_binds)
}
}
genDerivBinds clas fix_env tycon
| className clas `elem` typeableClassNames
......@@ -936,15 +982,14 @@ We're deriving @Enum@, or @Ix@ (enum type only???)
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName)
genTaggeryBinds :: [(InstInfo, TyCon)] -> TcM (LHsBinds RdrName)
genTaggeryBinds infos
= do { names_so_far <- foldlM do_con2tag [] tycons_of_interest
; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest
; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) }
where
all_CTs = [ (cls, tcTyConAppTyCon ty)
| info <- infos,
let (cls,ty) = simpleInstInfoClsTy info ]
all_CTs = [ (fst (simpleInstInfoClsTy info), tc)
| (info, tc) <- infos]
all_tycons = map snd all_CTs
(tycons_of_interest, _) = removeDups compare all_tycons
......@@ -983,17 +1028,24 @@ genTaggeryBinds infos
\end{code}
\begin{code}
derivingThingErr clas tys tycon tyvars why
= sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
derivingThingErr clas tys tycon ttys why
= sep [hsep [ptext SLIT("Can't make a derived instance of"),
quotes (ppr pred)],
nest 2 (parens why)]
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
pred = mkClassPred clas (tys ++ [mkTyConApp tycon ttys])
derivCtxt :: TyCon -> SDoc
derivCtxt tycon
= ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
derivCtxt :: Name -> Maybe [LHsType Name] -> SDoc
derivCtxt tycon mb_tys
= ptext SLIT("When deriving instances for") <+> quotes typeInst
where
typeInst = case mb_tys of
Nothing -> ppr tycon
Just tys -> ppr tycon <+>
hsep (map (pprParendHsType . unLoc) tys)
derivInstCtxt1 clas inst_tys
= ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys)
= ptext SLIT("When deriving the instance for") <+>
quotes (pprClassPred clas inst_tys)
\end{code}
......@@ -17,7 +17,7 @@ module TcEnv(
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass,
tcLookupLocatedClass, tcLookupFamInst,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs,
......@@ -61,6 +61,7 @@ import VarSet
import VarEnv
import RdrName
import InstEnv
import FamInstEnv
import DataCon
import TyCon
import Class
......@@ -157,6 +158,18 @@ tcLookupLocatedClass = addLocM tcLookupClass
tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
-- Look up the representation tycon of a family instance.
--
tcLookupFamInst :: TyCon -> [Type] -> TcM TyCon
tcLookupFamInst tycon tys
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; case lookupFamInstEnvExact instEnv tycon tys of
Nothing -> famInstNotFound tycon tys
Just famInst -> return $ famInstTyCon famInst
}
\end{code}
%************************************************************************
......@@ -656,4 +669,9 @@ notFound name
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
ptext SLIT("used as a") <+> text expected)
famInstNotFound tycon tys
= failWithTc (quotes famInst <+> ptext SLIT("is not in scope"))
where
famInst = ppr tycon <+> hsep (map pprParendType tys)
\end{code}
......@@ -12,7 +12,7 @@ module FamInstEnv (
FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
famInstEnvElts, familyInstances,
lookupFamInstEnv, lookupFamInstEnvUnify
lookupFamInstEnvExact, lookupFamInstEnv, lookupFamInstEnvUnify
) where
#include "HsVersions.h"
......@@ -174,7 +174,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
add (FamIE items tyvar) _ = FamIE (ins_item:items)
(ins_tyvar || tyvar)
ins_tyvar = not (any isJust mb_tcs)
\end{code}
\end{code}
%************************************************************************
%* *
......@@ -182,6 +182,50 @@ 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}
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,6 +55,7 @@ module Type (
-- Source types
predTypeRep, mkPredTy, mkPredTys,
tyConOrigHead,
-- Newtypes
splitRecNewType_maybe, newTyConInstRhs,
......@@ -602,6 +603,13 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a newtype application, but the consumer will
-- look through that too if necessary
predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
-- The original head is the tycon and its variables for a vanilla tycon and it
-- is the family tycon and its type indexes for a family instance.
tyConOrigHead :: TyCon -> (TyCon, [Type])
tyConOrigHead tycon = case tyConFamInst_maybe tycon of
Nothing -> (tycon, mkTyVarTys (tyConTyVars tycon))
Just famInst -> famInst
\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