X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=61b1a0f470772d06cae70c73d5f66a732ca43a45;hb=6a4854eaa266d994ebd0d471614a52b43dd329d9;hp=a0297ad7eefa4711c2144ada8dc019a3ffae71f5;hpb=d51aa9da8ced82cc4762b6e69fd5f147fb5c7eb8;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index a0297ad..61b1a0f 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -1,5 +1,5 @@ \begin{code} -module Generics ( canDoGenerics, mkGenericBinds, +module Generics ( canDoGenerics, mkTyConGenericBinds, mkGenericRhs, validGenericInstanceType, validGenericMethodType ) where @@ -9,12 +9,14 @@ import HsSyn import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, isTyVarTy, getTyVar_maybe, funTyCon ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) -import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, +import TcHsSyn ( mkSimpleHsAlt ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, + isTauTy, mkTyVarTy ) +import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon, dataConSourceArity ) import TyCon ( TyCon, tyConName, tyConDataCons, - tyConHasGenerics, isBoxedTupleTyCon + isBoxedTupleTyCon ) import Name ( nameModuleName, nameOccName, getSrcLoc ) import OccName ( mkGenOcc1, mkGenOcc2 ) @@ -23,10 +25,12 @@ import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) import Id ( Id, idType ) +import TysWiredIn ( listTyCon ) import PrelNames -import SrcLoc ( generatedSrcLoc ) -import Util ( takeList ) +import SrcLoc ( srcLocSpan, noLoc, Located(..) ) +import Util ( takeList, isSingleton ) +import Bag import Outputable import FastString @@ -188,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 @@ -205,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} @@ -226,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 @@ -246,28 +251,24 @@ canDoGenerics data_cons \begin{code} type US = Int -- Local unique supply, just a plain Int -type FromAlt = (Pat RdrName, HsExpr RdrName) - -mkGenericBinds :: [TyCon] -> MonoBinds RdrName -mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc - | tc <- tcs, tyConHasGenerics tc] - -mkTyConGenBinds :: TyCon -> MonoBinds RdrName -mkTyConGenBinds tycon - = FunMonoBind from_RDR False {- Not infix -} - [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - loc - `AndMonoBinds` - FunMonoBind to_RDR False - [mkSimpleHsAlt (VarPat to_arg) to_body] loc +type FromAlt = (LPat RdrName, LHsExpr RdrName) + +mkTyConGenericBinds :: TyCon -> LHsBinds RdrName +mkTyConGenericBinds tycon + = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -} + (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]))) + + `unionBags` + unitBag (L loc (FunBind (L loc to_RDR) False + (mkMatchGroup [mkSimpleHsAlt to_pat to_body]))) where - loc = getSrcLoc tycon + loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon (from_RDR, to_RDR) = mkGenericNames tycon -- Recurse over the sum first from_alts :: [FromAlt] - (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons + (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons init_us = 1::Int -- Unique supply ---------------------------------------------------- @@ -276,8 +277,8 @@ mkTyConGenBinds tycon mk_sum_stuff :: US -- Base for generating unique names -> [DataCon] -- The data constructors - -> ([FromAlt], -- Alternatives for the T->Trep "from" function - RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function + -> ([FromAlt], -- Alternatives for the T->Trep "from" function + InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function -- For example, given -- data T = C | D Int Int Int @@ -290,7 +291,7 @@ mk_sum_stuff :: US -- Base for generating unique names -- cd) mk_sum_stuff us [datacon] - = ([from_alt], to_arg, to_body_fn app_exp) + = ([from_alt], to_pat, to_body_fn app_exp) where n_args = dataConSourceArity datacon -- Existentials already excluded @@ -298,29 +299,28 @@ mk_sum_stuff us [datacon] us' = us + n_args datacon_rdr = getRdrName datacon - app_exp = mkHsVarApps datacon_rdr datacon_vars - from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs) + app_exp = nlHsVarApps datacon_rdr datacon_vars + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars + (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars mk_sum_stuff us datacons = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, - to_arg, - HsCase (HsVar to_arg) - [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body, - mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body] - generatedSrcLoc) + nlVarPat to_arg, + noLoc (HsCase (nlHsVar to_arg) + (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_arg, l_to_body) = mk_sum_stuff us' l_datacons - (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons + (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons + (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons to_arg = mkGenericLocal us us' = us+1 wrap :: RdrName -> [FromAlt] -> [FromAlt] -- Wrap an application of the Inl or Inr constructor round each alternative - wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts] + wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] ---------------------------------------------------- @@ -331,15 +331,16 @@ mk_prod_stuff :: US -- Base for unique names -- They are bound enclosing from_rhs -- Please bind these in the to_body_fn -> (US, -- Depleted unique-name supply - HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids - RdrName, -- to_arg: - HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation + LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids + InPat RdrName, -- to_pat: + LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation -- For example: -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), --- \x -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- x) +-- abc, +-- \ -> case abc of { a :*: bc -> +-- case bc of { b :*: c -> +-- ) -- We need to use different uniques in the branches -- because the returned to_body_fns are nested. @@ -347,26 +348,34 @@ mk_prod_stuff :: US -- Base for unique names mk_prod_stuff us [] -- Unit case = (us+1, - HsVar genUnitDataCon_RDR, - mkGenericLocal us, + nlHsVar genUnitDataCon_RDR, + noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) + (noLoc (HsTyVar (getRdrName genUnitTyConName)))), + -- Give a signature to the pattern so we get + -- data S a = Nil | S a + -- toS = \x -> case x of { Inl (g :: Unit) -> Nil + -- Inr x -> S x } + -- The (:: Unit) signature ensures that we'll infer the right + -- type for toS. If we leave it out, the type is too polymorphic + \x -> x) mk_prod_stuff us [arg_var] -- Singleton case - = (us, HsVar arg_var, arg_var, \x -> x) + = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) mk_prod_stuff us arg_vars -- Two or more = (us'', - HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs, - to_arg, - \x -> HsCase (HsVar to_arg) - [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg]) - (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc) + nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], + nlVarPat to_arg, +-- 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 - (us', l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars - (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars - + (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars + (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars + pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat] splitInHalf :: [a] -> ([a],[a]) splitInHalf list = (left, right) @@ -423,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 @@ -443,36 +454,37 @@ By the time the type checker has done its stuff we'll get op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName +mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName mkGenericRhs sel_id tyvar tycon - = HsApp (toEP bimap) (HsVar (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 -- of us, quite probably a FunTyCon. - ep = EP (HsVar from_RDR) (HsVar to_RDR) + ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR) bimap = generate_bimap (tyvar, ep, local_tvs) final_ty type EPEnv = (TyVar, -- The class type variable - EP (HsExpr RdrName), -- The EP it maps to + EP (LHsExpr RdrName), -- The EP it maps to [TyVar] -- Other in-scope tyvars; they have an identity EP ) ------------------- generate_bimap :: EPEnv -> Type - -> EP (HsExpr RdrName) + -> EP (LHsExpr RdrName) -- Top level case - splitting the TyCon. generate_bimap env@(tv,ep,local_tvs) ty = case getTyVar_maybe ty of @@ -482,10 +494,11 @@ generate_bimap env@(tv,ep,local_tvs) ty Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName) +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 @@ -498,32 +511,37 @@ bimapApp env (Just (tycon, ty_args)) ------------------- -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] - = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body, - toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body } + = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, + toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body } where - from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR)) - to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR)) + from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR)) + 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 = mk_hs_lam [tuple_pat] from_body, - toEP = mk_hs_lam [tuple_pat] to_body } + = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body), + toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } where names = takeList eps gs_RDR - tuple_pat = TuplePat (map VarPat names) Boxed + tuple_pat = TuplePat (map nlVarPat names) Boxed eps_w_names = eps `zip` names - to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed - from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed + to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed + 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) .. ] ] -mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc)) - -idEP :: EP (HsExpr RdrName) +idEP :: EP (LHsExpr RdrName) idEP = EP idexpr idexpr where - idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR) + idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR) \end{code}