From: simonpj <unknown>
Date: Mon, 2 Jun 2003 14:26:55 +0000 (+0000)
Subject: [project @ 2003-06-02 14:26:54 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~823
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=eda832945f6ccdd582eeeeaa26a47d5a36731045;p=ghc-hetmet.git

[project @ 2003-06-02 14:26:54 by simonpj]
Wibbles to nested tuples
---

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 46e63e3..20414c0 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -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)
 
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 7af59eb..7c2343d 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -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
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 31f11d6..5191c9d 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -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