import RnHsSyn ( RenamedHsExpr )
-import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
+import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
-import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
- mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
- mkFunTy, isTyVarTy,
- splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
+import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
+ mkTyVarTys, mkForAllTys, mkTyConApp,
+ mkFunTy, isTyVarTy, getTyVar_maybe,
+ funTyCon
)
+import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
+import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon )
-import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
-
-import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable,
+import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe,
tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
)
-import Name ( Name, mkSysLocalName )
-import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
+import Name ( Name, mkSystemName )
+import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..),
mkConApp, Alt, mkTyApps, mkVarApps )
+import CoreUtils ( exprArity )
import BasicTypes ( EP(..), Boxity(..) )
import Var ( TyVar )
-import VarSet ( isEmptyVarSet )
-import Id ( Id, mkTemplateLocal, idType, idName,
- mkTemplateLocalsNum, mkId
- )
+import VarSet ( varSetElems )
+import Id ( Id, mkVanillaGlobal, idType, idName, mkSysLocal )
+import MkId ( mkReboxingAlt, mkNewTypeBody )
import TysWiredIn ( genericTyCons,
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
inlDataCon, crossTyCon, crossDataCon
)
-import IdInfo ( vanillaIdInfo, setUnfoldingInfo )
+import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
import CoreUnfold ( mkTopUnfolding )
-import Unique ( mkBuiltinUnique )
+import Maybe ( isNothing )
import SrcLoc ( builtinSrcLoc )
-import Maybes ( expectJust )
+import Unique ( Unique, builtinUniques, mkBuiltinUnique )
+import Util ( takeList, dropList )
import Outputable
+import FastString
#include "HsVersions.h"
\end{code}
HsOpTy is tied to Generic definitions which is not a very good design
feature, indeed a bug. However, the check is easy to move from
tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5.
+bug #5. [I don't think that this is the case anymore after SPJ's latest
+changes in that regard. Delete this comment? -=chak/7Jun2]
Generics.lhs
-- f {| a + Int |}
validGenericInstanceType inst_ty
- = case splitTyConApp_maybe inst_ty of
+ = case tcSplitTyConApp_maybe inst_ty of
Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
Nothing -> False
-- * function arrow
-- * boxed tuples
-- * an arbitrary type not involving the class type variables
-validGenericMethodType ty = valid ty
-
-valid ty
- | isTyVarTy ty = True
- | not (null arg_tys) = all valid arg_tys && valid res_ty
- | no_tyvars_in_ty = True
- | otherwise = isBoxedTupleTyCon tc && all valid tys
+ -- e.g. this is ok: forall b. Ord b => [b] -> a
+ -- where a is the class variable
+validGenericMethodType ty
+ = valid tau
where
- (arg_tys, res_ty) = splitFunTys ty
- no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty)
- Just (tc,tys) = splitTyConApp_maybe ty
+ (local_tvs, _, tau) = tcSplitSigmaTy ty
+
+ valid ty
+ | isTyVarTy ty = True
+ | no_tyvars_in_ty = True
+ | otherwise = case tcSplitTyConApp_maybe ty of
+ Just (tc,tys) -> valid_tycon tc && all valid tys
+ Nothing -> False
+ where
+ no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
+
+ valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
+ -- Compare bimapApp, below
\end{code}
%************************************************************************
\begin{code}
-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
-- mkTyConGenInfo is called twice
-- once from TysWiredIn for Tuples
-- once the typechecker TcTyDecls
-- The two names are the names constructed by the renamer
-- for the fromT and toT conversion functions.
-mkTyConGenInfo tycon from_name to_name
- | null datacons -- Abstractly imported types don't have
- = Nothing -- to/from operations, (and should not need them)
+mkTyConGenInfo tycon []
+ = Nothing -- This happens when we deal with the interface-file type
+ -- decl for a module compiled without -fgenerics
- -- If any of the constructor has an unboxed type as argument
+mkTyConGenInfo tycon [from_name, to_name]
+ | isNothing maybe_datacons -- Abstractly imported types don't have
+ = Nothing -- to/from operations, (and should not need them)
+
+ -- 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
-- at the argument types of the constructors
- | any (any isUnLiftedType . dataConOrigArgTys) datacons
+ -- Nor can we do the job if it's an existential data constructor,
+ | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
+ | dc <- datacons ]
= Nothing
+ | null datacons -- There are no constructors;
+ = Nothing -- there are no values of this type
+
| otherwise
- = Just (EP { fromEP = mkId from_name from_ty from_id_info,
- toEP = mkId to_name to_ty to_id_info })
+ = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons
+ Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
+ toEP = mkVanillaGlobal to_name to_ty to_id_info })
where
- tyvars = tyConTyVars tycon -- [a, b, c]
- datacons = tyConDataConsIfAvailable tycon -- [C, D]
- tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
- tyvar_tys = mkTyVarTys tyvars
+ maybe_datacons = tyConDataCons_maybe tycon
+ Just datacons = maybe_datacons -- [C, D]
- from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
- to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+ tyvars = tyConTyVars tycon -- [a, b, c]
+ tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
+ tyvar_tys = mkTyVarTys tyvars
+
+ from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+ `setArityInfo` exprArity from_fn
+ to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+ `setArityInfo` exprArity to_fn
+ -- It's important to set the arity info, so that
+ -- the calling convention (gotten from arity)
+ -- matches reality.
from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
(from_fn, to_fn, rep_ty)
| isNewTyCon tycon
- = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x),
+ = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_ty (Var x),
Var (dataConWrapId the_datacon),
newrep_ty )
idType rep_var )
-- x :: T a b c
- x = mkTemplateLocal 1 tycon_ty
+ x = mkGenericLocal u1 tycon_ty
+ (u1 : uniqs) = builtinUniques
----------------------
-- Newtypes only
[the_datacon] = datacons
- newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+ (_, newrep_ty) = newTyConRep tycon
----------------------
-- Non-newtypes only
-- Recurse over the sum first
-- The "2" is the first free unique
- (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
+ (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
+mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
----------------------------------------------------
-- Dealing with sums
----------------------------------------------------
-mk_sum_stuff :: Int -- Base for generating unique names
+mk_sum_stuff :: [Unique] -- Base for generating unique names
-> [TyVar] -- Type variables over which the tycon is abstracted
-> [DataCon] -- The data constructors
-> ([Alt Id], CoreExpr, Id)
-- D a b c }} },
-- cd)
-mk_sum_stuff i tyvars [datacon]
+mk_sum_stuff us tyvars [datacon]
= ([from_alt], to_body_fn app_exp, rep_var)
where
- types = dataConOrigArgTys datacon
- datacon_vars = mkTemplateLocalsNum i types
- new_i = i + length types
- app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
- from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
+ types = dataConOrigArgTys datacon -- Existentials already excluded
+ datacon_vars = zipWith mkGenericLocal us types
+ us' = dropList types us
+
+ app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
+ from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
+ -- We are talking about *user* datacons here; hence
+ -- dataConWrapId
+ -- mkReboxingAlt
+
+ (_,args',_) = from_alt
+ us'' = dropList args' us' -- Conservative, but safe
- (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
+ (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
-mk_sum_stuff i tyvars datacons
+mk_sum_stuff (u:us) tyvars datacons
= (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
(DataAlt inrDataCon, [r_rep_var], r_to_body)],
rep_var)
where
(l_datacons, r_datacons) = splitInHalf datacons
- (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
- (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
+ (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
+ (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
rep_tys = [idType l_rep_var, idType r_rep_var]
rep_ty = mkTyConApp plusTyCon rep_tys
- rep_var = mkTemplateLocal i rep_ty
+ rep_var = mkGenericLocal u rep_ty
wrap :: DataCon -> [Alt Id] -> [Alt Id]
-- Wrap an application of the Inl or Inr constructor round each alternative
where
datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-
----------------------------------------------------
-- Dealing with products
----------------------------------------------------
-mk_prod_stuff :: Int -- Base for unique names
+mk_prod_stuff :: [Unique] -- Base for unique names
-> [Id] -- arg-ids; args of the original user-defined constructor
-- They are bound enclosing from_rhs
-- Please bind these in the to_body_fn
- -> (Int, -- Depleted unique-name supply
+ -> ([Unique], -- Depleted unique-name supply
CoreExpr, -- from-rhs: puts together the representation from the arg_ids
CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
Id) -- The rep-id; please bind this to the representation
-- because the returned to_body_fns are nested.
-- Hence the returned unqique-name supply
-mk_prod_stuff i [] -- Unit case
- = (i,
+mk_prod_stuff (u:us) [] -- Unit case
+ = (us,
Var (dataConWrapId genUnitDataCon),
\x -> x,
- mkTemplateLocal i (mkTyConApp genUnitTyCon []))
+ mkGenericLocal u (mkTyConApp genUnitTyCon []))
-mk_prod_stuff i [arg_var] -- Singleton case
- = (i, Var arg_var, \x -> x, arg_var)
+mk_prod_stuff us [arg_var] -- Singleton case
+ = (us, Var arg_var, \x -> x, arg_var)
-mk_prod_stuff i arg_vars -- Two or more
- = (r_i,
+mk_prod_stuff (u:us) arg_vars -- Two or more
+ = (us'',
mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
\x -> Case (Var rep_var) rep_var
[(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
rep_var)
where
(l_arg_vars, r_arg_vars) = splitInHalf arg_vars
- (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
- (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
- rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
+ (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
+ (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
+ rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
rep_tys = [idType l_rep_var, idType r_rep_var]
\end{code}
half = length list `div` 2
left = take half list
right = drop half list
+
+mkGenericLocal :: Unique -> Type -> Id
+mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
\end{code}
%************************************************************************
Generating the Generic default method. Uses the bimaps to generate the
actual method. All of this is rather incomplete, but it would be nice
-to make even this work.
+to make even this work. Example
+
+ class Foo a where
+ op :: Op a
+
+ instance Foo T
+
+Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
+
+ instance Foo T where
+ op = <mkGenericRhs op a T>
+
+To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
+
+ toOp :: Op Trep -> Op T
+ fromOp :: Op T -> Op Trep
+
+(the bimap) and then fill in the RHS with
+
+ instance Foo T where
+ op = toOp op
+
+Remember, we're generating a RenamedHsExpr, so the result of all this
+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:
+
+ class Baz a where
+ op :: forall b. Ord b => a -> b -> b
+
+Then we can still generate a bimap with
+
+ toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
+
+and fill in the instance decl thus
+
+ instance Foo T where
+ op = toOp op
+
+By the time the type checker has done its stuff we'll get
+
+ instance Foo T where
+ op = \b. \dict::Ord b. toOp b (op Trep b dict)
\begin{code}
mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
ep = EP (HsVar (idName from)) (HsVar (idName to))
- -- Takes out the ForAll and the Class rstrictions in front of the
- -- type of the method.
- (_,_,op_ty) = splitSigmaTy (idType sel_id)
+ -- Takes out the ForAll and the Class restrictions
+ -- in front of the type of the method.
+ (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
+
+ -- Do it again! This deals with the case where the method type
+ -- is polymorphic -- see notes above
+ (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-- Now we probably have a tycon in front
-- of us, quite probably a FunTyCon.
- bimap = generate_bimap (tyvar, ep) op_ty
+ bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
--- EP is the environment of to/from bimaps, but as we only have one type
--- variable at the moment, there is only one EP.
+type EPEnv = (TyVar, -- The class type variable
+ EP RenamedHsExpr, -- The EP it maps to
+ [TyVar] -- Other in-scope tyvars; they have an identity EP
+ )
-------------------
-generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
+generate_bimap :: EPEnv
+ -> Type
+ -> EP RenamedHsExpr
-- Top level case - splitting the TyCon.
-generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
- | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty)
+generate_bimap env@(tv,ep,local_tvs) ty
+ = case getTyVar_maybe ty of
+ Just tv1 | tv == tv1 -> ep -- The class tyvar
+ | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
+ idEP
+ Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
-------------------
-bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
-bimapApp ep Nothing = panic "TcClassDecl: Type Application!"
-bimapApp ep (Just (tycon, ty_args))
+bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
+bimapApp env Nothing = panic "TcClassDecl: Type Application!"
+bimapApp env (Just (tycon, ty_args))
| tycon == funTyCon = bimapArrow arg_eps
| isBoxedTupleTyCon tycon = bimapTuple arg_eps
| otherwise = -- Otherwise validGenericMethodType will
-- have checked that the type is a constant type
- ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
- EP idexpr idexpr
+ ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
+ idEP
where
- arg_eps = map (generate_bimap ep) ty_args
+ arg_eps = map (generate_bimap env) ty_args
+ (_,_,local_tvs) = env
-------------------
+-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
bimapArrow [ep1, ep2]
= EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
= EP { fromEP = mk_hs_lam [tuple_pat] from_body,
toEP = mk_hs_lam [tuple_pat] to_body }
where
- names = take (length eps) genericNames
+ names = takeList eps genericNames
tuple_pat = TuplePatIn (map VarPatIn names) Boxed
eps_w_names = eps `zip` names
to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
-------------------
genericNames :: [Name]
-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
(g1:g2:g3:_) = genericNames
-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
-idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
+
+idEP :: EP RenamedHsExpr
+idEP = EP idexpr idexpr
+ where
+ idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
\end{code}
projects / ghc-hetmet.git / blobdiff