Commit eda83294 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-06-02 14:26:54 by simonpj]

Wibbles to nested tuples
parent 663a01b2
......@@ -15,7 +15,7 @@ import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, selectMatchVar )
import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, mkCoreTupTy, selectMatchVar )
import DsMonad
#ifdef GHCI
......@@ -674,8 +674,8 @@ dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
tup_expr | one_var = ret1
| otherwise = ExplicitTuple rets Boxed
tup_ty | one_var = idType var1
| otherwise = mkTupleTy Boxed (length vars) (map idType vars)
tup_ty = mkCoreTupTy (map idType vars)
-- Deals with singleton case
tup_pat | one_var = VarPat var1
| otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
......
......@@ -30,8 +30,7 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type,
splitTyConApp_maybe )
import TysPrim ( alphaTyVar )
import TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId,
unitDataConId, unitTy,
mkListTy, mkTupleTy )
unitDataConId, unitTy, mkListTy )
import Match ( matchSimply )
import PrelNames ( foldrName, buildName, replicatePName, mapPName,
filterPName, zipPName, crossPName, parrTyConName )
......@@ -159,7 +158,7 @@ deListComp (ParStmtOut bndrstmtss : quals) list
= dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
(mk_bndrs_tys bndrs)
mk_bndrs_tys bndrs = mk_tuple_ty (map idType bndrs)
mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
-- Last: the one to return
deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above
......@@ -237,18 +236,13 @@ mkZipBind elt_tys
returnDs (zip_fn, mkLams ass zip_body)
where
list_tys = map mkListTy elt_tys
ret_elt_ty = mk_tuple_ty elt_tys
ret_elt_ty = mkCoreTupTy elt_tys
zip_fn_ty = mkFunTys list_tys (mkListTy ret_elt_ty)
mk_case (as, a', as') rest
= Case (Var as) as [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty),
(DataAlt consDataCon, [a', as'], rest)]
-- Helper function
mk_tuple_ty :: [Type] -> Type
mk_tuple_ty [ty] = ty
mk_tuple_ty tys = mkTupleTy Boxed (length tys) tys
-- Helper functions that makes an HsTuple only for non-1-sized tuples
mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr
mk_hs_tuple_expr [] = HsVar unitDataConId
......
......@@ -24,7 +24,8 @@ module DsUtils (
mkIntExpr, mkCharExpr,
mkStringLit, mkStringLitFS, mkIntegerExpr,
mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkCoreTup,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkCoreTup, mkCoreSel, mkCoreTupTy,
selectMatchVar
) where
......@@ -646,7 +647,7 @@ mkTupleSelector vars the_var scrut_var scrut
mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
mk_tup_sel (chunkify tpl_vs) tpl_v
where
tpl_tys = [mkTupleTy Boxed (length gp) (map idType gp) | gp <- vars_s]
tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
tpl_vs = mkTemplateLocals tpl_tys
[(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
the_var `elem` gp ]
......@@ -672,6 +673,13 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
-- The next three functions make tuple types, constructors and selectors,
-- with the rule that a 1-tuple is represented by the thing itselg
mkCoreTupTy :: [Type] -> Type
mkCoreTupTy [ty] = ty
mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
mkCoreTup :: [CoreExpr] -> CoreExpr
-- Builds exactly the specified tuple.
-- No fancy business for big tuples
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment