X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=61b1a0f470772d06cae70c73d5f66a732ca43a45;hb=6a4854eaa266d994ebd0d471614a52b43dd329d9;hp=dc027164b238bfa68714ae29cbfad61a0fe9fa8c;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index dc02716..61b1a0f 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -10,8 +10,9 @@ import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, isTyVarTy, getTyVar_maybe, funTyCon ) import TcHsSyn ( mkSimpleHsAlt ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) -import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, + isTauTy, mkTyVarTy ) +import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon, dataConSourceArity ) import TyCon ( TyCon, tyConName, tyConDataCons, @@ -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} @@ -228,7 +231,7 @@ canDoGenerics data_cons = not (any bad_con data_cons) -- See comment below && not (null data_cons) -- No values of the type where - bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc + bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types @@ -253,11 +256,11 @@ type FromAlt = (LPat RdrName, LHsExpr RdrName) mkTyConGenericBinds :: TyCon -> LHsBinds RdrName mkTyConGenericBinds tycon = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -} - [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])) + (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]))) `unionBags` unitBag (L loc (FunBind (L loc to_RDR) False - [mkSimpleHsAlt to_pat to_body])) + (mkMatchGroup [mkSimpleHsAlt to_pat to_body]))) where loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon @@ -305,8 +308,8 @@ mk_sum_stuff us datacons = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, nlVarPat to_arg, noLoc (HsCase (nlHsVar to_arg) - [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, - mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])) + (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, + mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))) where (l_datacons, r_datacons) = splitInHalf datacons (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons @@ -364,8 +367,9 @@ mk_prod_stuff us arg_vars -- Two or more = (us'', nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], nlVarPat to_arg, - \x -> noLoc (HsCase (nlHsVar to_arg) - [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])) +-- gaw 2004 FIX? + \x -> noLoc (HsCase (nlHsVar to_arg) + (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))) where to_arg = mkGenericLocal us (l_arg_vars, r_arg_vars) = splitInHalf arg_vars @@ -428,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 @@ -450,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 @@ -491,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 @@ -510,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) } @@ -521,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) .. ] ]