[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 (file)
--- 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 (file)
--- 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 (file)
--- 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