Add tuple sections as a new feature

This patch adds tuple sections, so that

	(x,,z)  means   \y -> (x,y,z)

Thanks for Max Bolinbroke for doing the hard work.

In the end, instead of using two constructors in HsSyn, I used
just one (still called ExplicitTuple) whose arguments can be
	Present (LHsExpr id)
or	Missing PostTcType

While I was at it, I did a bit of refactoring too.

7 files changed, 72 insertions, 64 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 8260cfb473..f31b2c897b 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -24,9 +24,9 @@ import HscTypes
 import StaticFlags
 import TyCon
 import FiniteMap
+import Maybes
 
 import Data.Array
-import Data.Maybe
 import System.Directory ( createDirectoryIfMissing )
 
 import Trace.Hpc.Mix
@@ -278,6 +278,10 @@ addTickHsExpr (SectionR e1 e2) =
 	liftM2 SectionR
 		(addTickLHsExpr e1)
 		(addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple es boxity) =
+        liftM2 ExplicitTuple
+                (mapM addTickTupArg es)
+                (return boxity)
 addTickHsExpr (HsCase e mgs) = 
 	liftM2 HsCase
 		(addTickLHsExpr e) 
@@ -301,17 +305,13 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
 		    ListComp -> Just $ BinBox QualBinBox
 		    _        -> Nothing
 addTickHsExpr (ExplicitList ty es) = 
-	liftM2 ExplicitList 
+	liftM2 ExplicitList
 		(return ty)
 		(mapM (addTickLHsExpr) es)
 addTickHsExpr (ExplicitPArr ty es) =
 	liftM2 ExplicitPArr
 		(return ty)
 		(mapM (addTickLHsExpr) es)
-addTickHsExpr (ExplicitTuple es box) =
-	liftM2 ExplicitTuple
-		(mapM (addTickLHsExpr) es)
-		(return box)
 addTickHsExpr (RecordCon id ty rec_binds) = 
 	liftM3 RecordCon
 		(return id)
@@ -377,6 +377,10 @@ addTickHsExpr e@(HsType _) = return e
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
+addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
+addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
+addTickTupArg (Missing ty) = return (Missing ty)
+
 addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
 addTickMatchGroup (MatchGroup matches ty) = do
   let isOneOfMany = matchesOneOfMany matches
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 76117b3474..cead3dd541 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -217,16 +217,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do
 \end{code}
 
 \begin{code}
-mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
-mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
-
-mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
-mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
-
-mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id
 mkHsEnvStackExpr env_ids stack_ids
-  = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+  = foldl (\a b -> mkLHsTupleExpr [a,b]) 
+	  (mkLHsVarTuple env_ids) 
+	  (map nlHsVar stack_ids)
 \end{code}
 
 Translation of arrow abstraction
@@ -479,7 +474,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
             (core_leaf, fvs, leaf_ids) <-
                   dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
             return (fvs `minusVarSet` bound_vars,
-                    [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+                    [mkHsEnvStackExpr leaf_ids stack_ids],
                     envStackType leaf_ids stack,
                     core_leaf)
     
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 2eca842eb0..820bd9ac3e 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -261,6 +261,25 @@ dsExpr (SectionR op expr) = do
     return (bindNonRec y_id y_core $
             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 
+dsExpr (ExplicitTuple tup_args boxity)
+  = do { let go (lam_vars, args) (Missing ty)
+                    -- For every missing expression, we need
+		    -- another lambda in the desugaring.
+               = do { lam_var <- newSysLocalDs ty
+                    ; return (lam_var : lam_vars, Var lam_var : args) }
+	     go (lam_vars, args) (Present expr)
+     	            -- Expressions that are present don't generate
+                    -- lambdas, just arguments.
+               = do { core_expr <- dsLExpr expr
+                    ; return (lam_vars, core_expr : args) }
+
+       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
+		-- The reverse is because foldM goes left-to-right
+
+       ; return $ mkCoreLams lam_vars $ 
+                  mkConApp (tupleCon boxity (length tup_args))
+                           (map (Type . exprType) args ++ args) }
+
 dsExpr (HsSCC cc expr) = do
     mod_name <- getModuleDs
     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
@@ -335,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do
     unary  fn x   = mkApps (Var fn) [Type ty, x]
     binary fn x y = mkApps (Var fn) [Type ty, x, y]
 
-dsExpr (ExplicitTuple expr_list boxity) = do
-    core_exprs <- mapM dsLExpr expr_list
-    return (mkConApp (tupleCon boxity (length expr_list))
-                  (map (Type .  exprType) core_exprs ++ core_exprs))
-
 dsExpr (ArithSeq expr (From from))
   = App <$> dsExpr expr <*> dsLExpr from
 
@@ -793,7 +807,7 @@ dsMDo tbl stmts body result_ty
 		  -- mkCoreTupTy deals with singleton case
 
 	return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
-			      (mk_ret_tup rets)
+			      (mkLHsTupleExpr rets)
 
 	mk_wild_pat :: Id -> LPat Id 
    	mk_wild_pat v = noLoc $ WildPat $ idType v
@@ -805,10 +819,6 @@ dsMDo tbl stmts body result_ty
  	mk_tup_pat :: [LPat Id] -> LPat Id
   	mk_tup_pat [p] = p
 	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
-
-	mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
-	mk_ret_tup [r] = r
-	mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 \end{code}
 
 
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 99a5dab44a..e7c1f20df8 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -642,7 +642,7 @@ dePArrParComp qss body = do
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
     deParStmt ((qs, xs):qss) = do        -- first statement
-      let res_expr = mkLHsVarTup xs
+      let res_expr = mkLHsVarTuple xs
       cqs <- dsPArrComp (map unLoc qs) res_expr undefined
       parStmts qss (mkLHsVarPatTup xs) cqs
     ---
@@ -651,7 +651,7 @@ dePArrParComp qss body = do
       zipP <- dsLookupGlobalId zipPName
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
-          res_expr = mkLHsVarTup xs
+          res_expr = mkLHsVarTuple xs
       cqs <- dsPArrComp (map unLoc qs) res_expr undefined
       let ty'cqs = parrElemType cqs
           cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index ab40ab1e2b..411da4074c 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -712,8 +712,10 @@ repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple es boxed) 
-  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
-  | otherwise		  = notHandled "Unboxed tuples" (ppr e)
+  | not (isBoxed boxed)        = notHandled "Unboxed tuples" (ppr e)
+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
+  | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repTup xs }
+
 repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index d932ab1fdb..f5650217d0 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -27,7 +27,7 @@ module DsUtils (
         seqVar,
 
         -- LHs tuples
-        mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
+        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
         mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
         mkSelectorBinds,
@@ -583,37 +583,31 @@ mkSelectorBinds pat val_expr
 
 \end{code}
 
-Creating tuples and their types for full Haskell expressions
+Creating big tuples and their types for full Haskell expressions.
+They work over *Ids*, and create tuples replete with their types,
+which is whey they are not in HsUtils.
 
 \begin{code}
-
--- Smart constructors for source tuple expressions
-mkLHsVarTup :: [Id] -> LHsExpr Id
-mkLHsVarTup ids  = mkLHsTup (map nlHsVar ids)
-
-mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
-mkLHsTup []     = nlHsVar unitDataConId
-mkLHsTup [lexp] = lexp
-mkLHsTup lexps  = L (getLoc (head lexps)) $ 
-		  ExplicitTuple lexps Boxed
-
--- Smart constructors for source tuple patterns
-mkLHsVarPatTup :: [Id] -> LPat Id
-mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
-
 mkLHsPatTup :: [LPat Id] -> LPat Id
 mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
 mkLHsPatTup [lpat] = lpat
 mkLHsPatTup lpats  = L (getLoc (head lpats)) $ 
 		     mkVanillaTuplePat lpats Boxed
 
+mkLHsVarPatTup :: [Id] -> LPat Id
+mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
+
+mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box 
+  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
+
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [Id] -> LHsExpr Id
 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
 
 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
-mkBigLHsTup = mkChunkified mkLHsTup
-
+mkBigLHsTup = mkChunkified mkLHsTupleExpr
 
 -- The Big equivalents for the source tuple patterns
 mkBigLHsVarPatTup :: [Id] -> LPat Id
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 474f7bf63f..d90f9048c3 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -841,12 +841,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
        -- are "equal"---conservatively, we use syntactic equality
 sameGroup _          _          = False
 
--- an approximation of syntactic equality used for determining when view
+-- An approximation of syntactic equality used for determining when view
 -- exprs are in the same group.
--- this function can always safely return false;
+-- This function can always safely return false;
 -- but doing so will result in the application of the view function being repeated.
 --
--- currently: compare applications of literals and variables
+-- Currently: compare applications of literals and variables
 --            and anything else that we can do without involving other
 --            HsSyn types in the recursion
 --
@@ -859,12 +859,11 @@ viewLExprEq (e1,_) (e2,_) =
         -- short name for recursive call on unLoc
         lexp e e' = exp (unLoc e) (unLoc e')
 
-        -- check that two lists have the same length
-        -- and that they match up pairwise
-        lexps [] [] = True
-        lexps [] (_:_) = False
-        lexps (_:_) [] = False
-        lexps (x:xs) (y:ys) = lexp x y && lexps xs ys
+	eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+        eq_list _  []     []     = True
+        eq_list _  []     (_:_)  = False
+        eq_list _  (_:_)  []     = False
+        eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
 
         -- conservative, in that it demands that wrappers be
         -- syntactically identical and doesn't look under binders
@@ -893,15 +892,13 @@ viewLExprEq (e1,_) (e2,_) =
         -- above does
         exp (HsIPVar i) (HsIPVar i') = i == i' 
         exp (HsOverLit l) (HsOverLit l') = 
-            -- overloaded lits are equal if they have the same type
+            -- Overloaded lits are equal if they have the same type
             -- and the data is the same.
             -- this is coarser than comparing the SyntaxExpr's in l and l',
             -- which resolve the overloading (e.g., fromInteger 1),
             -- because these expressions get written as a bunch of different variables
             -- (presumably to improve sharing)
             tcEqType (overLitType l) (overLitType l') && l == l'
-        -- comparing the constants seems right
-        exp (HsLit l) (HsLit l') = l == l'
         exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
         -- the fixities have been straightened out by now, so it's safe
         -- to ignore them?
@@ -912,14 +909,20 @@ viewLExprEq (e1,_) (e2,_) =
             lexp e1 e1' && lexp e2 e2'
         exp (SectionR e1 e2) (SectionR e1' e2') = 
             lexp e1 e1' && lexp e2 e2'
+        exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+            eq_list tup_arg es1 es2
         exp (HsIf e e1 e2) (HsIf e' e1' e2') =
             lexp e e' && lexp e1 e1' && lexp e2 e2'
-        exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls'
-        exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls'
-        exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls'
+
         -- Enhancement: could implement equality for more expressions
         --   if it seems useful
+	-- But no need for HsLit, ExplicitList, ExplicitTuple, 
+	-- because they cannot be functions
         exp _ _  = False
+
+        tup_arg (Present e1) (Present e2) = lexp e1 e2
+        tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+        tup_arg _ _ = False
     in
       lexp e1 e2