From: simonpj Date: Mon, 11 Oct 2004 16:16:23 +0000 (+0000) Subject: [project @ 2004-10-11 16:16:20 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1505 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6a4854eaa266d994ebd0d471614a52b43dd329d9 [project @ 2004-10-11 16:16:20 by simonpj] --------------------------------- Add lists to valid derivable methods --------------------------------- (It'd be nice to merge this into the stable branch. It is an increase in functionality, but it's quite separate from everything else.) Lists are useful in derivable type classes. E.g. methods like class Shrinkable a where op :: a -> [a] This commit adds them, to join functions and tuples. --- diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 1c9447d..9516686 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -702,7 +702,7 @@ genericMultiParamErr clas badGenericMethodType op op_ty = hang (ptext SLIT("Generic method type is too complex")) 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext SLIT("You can only use type variables, arrows, and tuples")]) + ptext SLIT("You can only use type variables, arrows, lists, and tuples")]) recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 0063140..61b1a0f 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -10,7 +10,8 @@ import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, isTyVarTy, getTyVar_maybe, funTyCon ) import TcHsSyn ( mkSimpleHsAlt ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, + isTauTy, mkTyVarTy ) import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon, dataConSourceArity ) @@ -24,10 +25,11 @@ import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) import Id ( Id, idType ) +import TysWiredIn ( listTyCon ) import PrelNames import SrcLoc ( srcLocSpan, noLoc, Located(..) ) -import Util ( takeList ) +import Util ( takeList, isSingleton ) import Bag import Outputable import FastString @@ -190,6 +192,7 @@ validGenericMethodType :: Type -> Bool -- * type variables -- * function arrow -- * boxed tuples + -- * lists -- * an arbitrary type not involving the class type variables -- e.g. this is ok: forall b. Ord b => [b] -> a -- where a is the class variable @@ -207,7 +210,7 @@ validGenericMethodType ty where no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) - valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc + valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc -- Compare bimapApp, below \end{code} @@ -429,7 +432,9 @@ will be fed to the type checker. So the 'op' on the RHS will be at the representation type for T, Trep. -A note about polymorphism. Suppose the class op is polymorphic: +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the class op is polymorphic: class Baz a where op :: forall b. Ord b => a -> b -> b @@ -451,18 +456,19 @@ By the time the type checker has done its stuff we'll get \begin{code} mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName mkGenericRhs sel_id tyvar tycon - = mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id)) + = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context + pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $ + mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id)) where -- Initialising the "Environment" with the from/to functions -- on the datatype (actually tycon) in question (from_RDR, to_RDR) = mkGenericNames tycon - -- Takes out the ForAll and the Class restrictions - -- in front of the type of the method. - (_,_,op_ty) = tcSplitSigmaTy (idType sel_id) + -- Instantiate the selector type, and strip off its class context + (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar)) -- Do it again! This deals with the case where the method type - -- is polymorphic -- see notes above + -- is polymorphic -- see Note [Polymorphic methods] above (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty -- Now we probably have a tycon in front @@ -492,6 +498,7 @@ bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName) bimapApp env Nothing = panic "TcClassDecl: Type Application!" bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps + | tycon == listTyCon = bimapList arg_eps | isBoxedTupleTyCon tycon = bimapTuple arg_eps | otherwise = -- Otherwise validGenericMethodType will -- have checked that the type is a constant type @@ -511,6 +518,7 @@ bimapArrow [ep1, ep2] to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR)) ------------------- +-- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn) bimapTuple eps = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body), toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } @@ -522,6 +530,12 @@ bimapTuple eps from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed ------------------- +-- bimapList :: EP a b -> EP [a] [b] +bimapList [ep] + = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep), + toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) } + +------------------- a_RDR = mkVarUnqual FSLIT("a") b_RDR = mkVarUnqual FSLIT("b") gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]