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 Name ( nameModule, nameOccName, getSrcLoc )
import OccName ( mkGenOcc1, mkGenOcc2 )
import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig )
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
-- * 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
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}
= 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
\begin{code}
type US = Int -- Local unique supply, just a plain Int
-type FromAlt = (Pat RdrName, HsExpr RdrName)
+type FromAlt = (LPat RdrName, LHsExpr RdrName)
-mkTyConGenericBinds :: TyCon -> MonoBinds RdrName
+mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
mkTyConGenericBinds tycon
- = FunMonoBind from_RDR False {- Not infix -}
- [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
- loc
- `AndMonoBinds`
- FunMonoBind to_RDR False
- [mkSimpleHsAlt to_pat to_body] loc
+ = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+ `unionBags`
+ unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
where
- loc = getSrcLoc tycon
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt to_pat to_body]
+ loc = srcLocSpan (getSrcLoc tycon)
datacons = tyConDataCons tycon
(from_RDR, to_RDR) = mkGenericNames tycon
mk_sum_stuff :: US -- Base for generating unique names
-> [DataCon] -- The data constructors
- -> ([FromAlt], -- Alternatives for the T->Trep "from" function
- InPat 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
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_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,
- VarPat to_arg,
- HsCase (HsVar to_arg)
- [mkSimpleHsAlt (ConPatIn inlDataCon_RDR (PrefixCon [l_to_pat])) l_to_body,
- mkSimpleHsAlt (ConPatIn inrDataCon_RDR (PrefixCon [r_to_pat])) 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_pat, l_to_body) = mk_sum_stuff us' l_datacons
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]
----------------------------------------------------
-- 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
+ LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
InPat RdrName, -- to_pat:
- HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation
+ LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
-- For example:
-- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
mk_prod_stuff us [] -- Unit case
= (us+1,
- HsVar genUnitDataCon_RDR,
- SigPatIn (VarPat (mkGenericLocal us))
- (HsTyVar (getRdrName genUnitTyConName)),
+ 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
\x -> x)
mk_prod_stuff us [arg_var] -- Singleton case
- = (us, HsVar arg_var, VarPat 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,
- VarPat to_arg,
- \x -> HsCase (HsVar to_arg)
- [mkSimpleHsAlt (ConPatIn crossDataCon_RDR (PrefixCon [l_to_pat, r_to_pat]))
- (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_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)
where
tc_name = tyConName tycon
tc_occ = nameOccName tc_name
- tc_mod = nameModuleName tc_name
+ tc_mod = nameModule tc_name
from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
\end{code}
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
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
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
-------------------
-- 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 placeHolderType
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}
projects / ghc-hetmet.git / blobdiff