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.

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 8260cfb..f31b2c8 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -24,9 +24,9 @@ import HscTypes
 import StaticFlags
 import TyCon
 import FiniteMap
 import StaticFlags
 import TyCon
 import FiniteMap

+import Maybes

 
 import Data.Array
 
 import Data.Array

-import Data.Maybe

 import System.Directory ( createDirectoryIfMissing )
 
 import Trace.Hpc.Mix
 import System.Directory ( createDirectoryIfMissing )
 
 import Trace.Hpc.Mix

@@ -278,6 +278,10 @@ addTickHsExpr (SectionR e1 e2) =
        liftM2 SectionR
                (addTickLHsExpr e1)
                (addTickLHsExpr 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) 
 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) = 
                    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)
                (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)
 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)
 
 -- 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
 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 76117b3..cead3dd 100644 (file)
--- 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}
 \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
 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
 \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,
             (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)
     
                     envStackType leaf_ids stack,
                     core_leaf)
     

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 2eca842..820bd9a 100644 (file)
--- 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]))
 
     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
 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]
 
     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
 
 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]) 
                  -- 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
 
        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_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}
 
 
 \end{code}
 
 

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 99a5dab..e7c1f20 100644 (file)
--- 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
       -- 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
     ---
       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
       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]
       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 ab40ab1..411da40 100644 (file)
--- 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) 
 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;
 repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index d932ab1..f565021 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -27,7 +27,7 @@ module DsUtils (
         seqVar,
 
         -- LHs tuples
         seqVar,
 
         -- LHs tuples

-        mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
+        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,

         mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
         mkSelectorBinds,
         mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
         mkSelectorBinds,

@@ -583,37 +583,31 @@ mkSelectorBinds pat val_expr
 
 \end{code}
 
 
 \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}
 
 \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
 
 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
 -- 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
 
 -- 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 474f7bf..d90f904 100644 (file)
--- 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
 
        -- 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.
 -- 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.
 --
 -- 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
 --
 --            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')
 
         -- 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
 
         -- 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') = 
         -- 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'
             -- 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?
         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'
             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 (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
         -- 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
         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
 
     in
       lexp e1 e2
 

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 8b64c98..9928420 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -521,7 +521,7 @@ cvtl e = wrapL (cvt e)
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
                            ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
     cvt (TupE [e])     = cvt e -- Singleton tuples treated like nothing (just parens)
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
                            ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
     cvt (TupE [e])     = cvt e -- Singleton tuples treated like nothing (just parens)

-    cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
+    cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }

     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
                            ; return $ HsIf x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
                            ; return $ HsIf x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index db54ab8..3142abc 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -121,6 +121,10 @@ data HsExpr id
   | SectionR    (LHsExpr id)    -- operator
                 (LHsExpr id)    -- operand
 
   | SectionR    (LHsExpr id)    -- operator
                 (LHsExpr id)    -- operand
 

+  | ExplicitTuple              -- Used for explicit tuples and sections thereof
+        [HsTupArg id] 
+        Boxity
+

   | HsCase      (LHsExpr id)
                 (MatchGroup id)
 
   | HsCase      (LHsExpr id)
                 (MatchGroup id)
 

@@ -147,14 +151,6 @@ data HsExpr id
                 PostTcType      -- type of elements of the parallel array
                 [LHsExpr id]
 
                 PostTcType      -- type of elements of the parallel array
                 [LHsExpr id]
 

-  | ExplicitTuple               -- tuple
-                [LHsExpr id]
-                                -- NB: Unit is ExplicitTuple []
-                                -- for tuples, we can get the types
-                                -- direct from the components
-                Boxity
-
-

   -- Record construction
   | RecordCon   (Located id)       -- The constructor.  After type checking
                                    -- it's the dataConWrapId of the constructor
   -- Record construction
   | RecordCon   (Located id)       -- The constructor.  After type checking
                                    -- it's the dataConWrapId of the constructor

@@ -280,6 +276,17 @@ data HsExpr id
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
 

+-- HsTupArg is used for tuple sections
+--  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
+--  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
+data HsTupArg id
+  = Present (LHsExpr id)       -- The argument
+  | Missing PostTcType         -- The argument is missing, but this is its type
+
+tupArgPresent :: HsTupArg id -> Bool
+tupArgPresent (Present {}) = True
+tupArgPresent (Missing {}) = False
+

 type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                         -- pasted back in by the desugarer
 \end{code}
 type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                         -- pasted back in by the desugarer
 \end{code}

@@ -380,6 +387,17 @@ ppr_expr (SectionR op expr)
     pp_infixly v
       = (sep [pprHsInfix v, pp_expr])
 
     pp_infixly v
       = (sep [pprHsInfix v, pp_expr])
 

+ppr_expr (ExplicitTuple exprs boxity)
+  = tupleParens boxity (fcat (ppr_tup_args exprs))
+  where
+    ppr_tup_args []               = []
+    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+    ppr_tup_args (Missing _ : es) = comma : ppr_tup_args es
+
+    punc (Present {} : _) = comma <> space
+    punc (Missing {} : _) = comma
+    punc []               = empty
+

 --avoid using PatternSignatures for stage1 code portability
 ppr_expr exprType@(HsLam matches)
   = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
 --avoid using PatternSignatures for stage1 code portability
 ppr_expr exprType@(HsLam matches)
   = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches

@@ -413,9 +431,6 @@ ppr_expr (ExplicitList _ exprs)
 ppr_expr (ExplicitPArr _ exprs)
   = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
 
 ppr_expr (ExplicitPArr _ exprs)
   = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
 

-ppr_expr (ExplicitTuple exprs boxity)
-  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
-

 ppr_expr (RecordCon con_id _ rbinds)
   = hang (ppr con_id) 2 (ppr rbinds)
 
 ppr_expr (RecordCon con_id _ rbinds)
   = hang (ppr con_id) 2 (ppr rbinds)
 

@@ -529,18 +544,18 @@ pprParendExpr expr
         -- I think that is usually (always?) right
     in
     case unLoc expr of
         -- I think that is usually (always?) right
     in
     case unLoc expr of

-      ArithSeq{}           -> pp_as_was
-      PArrSeq{}            -> pp_as_was
-      HsLit _              -> pp_as_was
-      HsOverLit _          -> pp_as_was
-      HsVar _              -> pp_as_was
-      HsIPVar _            -> pp_as_was
-      ExplicitList _ _     -> pp_as_was
-      ExplicitPArr _ _     -> pp_as_was
-      ExplicitTuple _ _    -> pp_as_was
-      HsPar _              -> pp_as_was
-      HsBracket _          -> pp_as_was
-      HsBracketOut _ []    -> pp_as_was
+      ArithSeq {}       -> pp_as_was
+      PArrSeq {}        -> pp_as_was
+      HsLit {}          -> pp_as_was
+      HsOverLit {}      -> pp_as_was
+      HsVar {}          -> pp_as_was
+      HsIPVar {}        -> pp_as_was
+      ExplicitTuple {}  -> pp_as_was
+      ExplicitList {}   -> pp_as_was
+      ExplicitPArr {}   -> pp_as_was
+      HsPar {}          -> pp_as_was
+      HsBracket {}      -> pp_as_was
+      HsBracketOut _ [] -> pp_as_was

       HsDo sc _ _ _
        | isListCompExpr sc -> pp_as_was
       _                    -> parens pp_as_was
       HsDo sc _ _ _
        | isListCompExpr sc -> pp_as_was
       _                    -> parens pp_as_was

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index db9460e..667f8cc 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -245,9 +245,6 @@ nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 

-nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
-

 nlWildPat :: LPat id
 nlWildPat  = noLoc (WildPat placeHolderType)   -- Pre-typechecking
 
 nlWildPat :: LPat id
 nlWildPat  = noLoc (WildPat placeHolderType)   -- Pre-typechecking
 

@@ -261,14 +258,12 @@ nlHsLam  :: LMatch id -> LHsExpr id
 nlHsPar  :: LHsExpr id -> LHsExpr id
 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 nlHsPar  :: LHsExpr id -> LHsExpr id
 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id

-nlTuple  :: [LHsExpr id] -> Boxity -> LHsExpr id

 nlList   :: [LHsExpr id] -> LHsExpr id
 
 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (HsIf cond true false)
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup matches))
 nlList   :: [LHsExpr id] -> LHsExpr id
 
 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (HsIf cond true false)
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup matches))

-nlTuple exprs box      = noLoc (ExplicitTuple exprs box)

 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 
 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 
 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name

@@ -283,7 +278,24 @@ nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 

+Tuples.  All these functions are *pre-typechecker* because they lack
+types on the tuple.
+
+\begin{code}
+mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+-- Makes a pre-typechecker boxed tuple, deals with 1 case
+mkLHsTupleExpr [e] = e
+mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
+
+mkLHsVarTuple :: [a] -> LHsExpr a
+mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)

 
 

+nlTuplePat :: [LPat id] -> Boxity -> LPat id
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+
+missingTupArg :: HsTupArg a
+missingTupArg = Missing placeHolderType
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 17dc60c..500d257 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -250,6 +250,7 @@ data DynFlag
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PostfixOperators
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PostfixOperators

+   | Opt_TupleSections

    | Opt_PatternGuards
    | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types
    | Opt_PatternGuards
    | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types

@@ -1769,6 +1770,7 @@ xFlags :: [(String, DynFlag, Bool -> Deprecated)]
 xFlags = [
   ( "CPP",                              Opt_Cpp, const Supported ),
   ( "PostfixOperators",                 Opt_PostfixOperators, const Supported ),
 xFlags = [
   ( "CPP",                              Opt_Cpp, const Supported ),
   ( "PostfixOperators",                 Opt_PostfixOperators, const Supported ),

+  ( "TupleSections",                    Opt_TupleSections, const Supported ),

   ( "PatternGuards",                    Opt_PatternGuards, const Supported ),
   ( "UnicodeSyntax",                    Opt_UnicodeSyntax, const Supported ),
   ( "MagicHash",                        Opt_MagicHash, const Supported ),
   ( "PatternGuards",                    Opt_PatternGuards, const Supported ),
   ( "UnicodeSyntax",                    Opt_UnicodeSyntax, const Supported ),
   ( "MagicHash",                        Opt_MagicHash, const Supported ),

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index cbc3bcb..47307ff 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1332,13 +1332,17 @@ aexp2   :: { LHsExpr RdrName }
 --     | STRING                        { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) }
        | INTEGER                       { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) }
        | RATIONAL                      { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) }
 --     | STRING                        { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) }
        | INTEGER                       { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) }
        | RATIONAL                      { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) }

+

         -- N.B.: sections get parsed by these next two productions.
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98
         -- (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
        | '(' texp ')'                  { LL (HsPar $2) }
         -- N.B.: sections get parsed by these next two productions.
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98
         -- (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
        | '(' texp ')'                  { LL (HsPar $2) }

-       | '(' texp ',' texps ')'        { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
-       | '(#' texps '#)'               { LL $ ExplicitTuple (reverse $2)      Unboxed }
+       | '(' tup_exprs ')'             { LL (ExplicitTuple $2 Boxed) }
+
+       | '(#' texp '#)'                { LL (ExplicitTuple [Present $2] Unboxed) }
+       | '(#' tup_exprs '#)'           { LL (ExplicitTuple $2 Unboxed) }
+

        | '[' list ']'                  { LL (unLoc $2) }
        | '[:' parr ':]'                { LL (unLoc $2) }
        | '_'                           { L1 EWildPat }
        | '[' list ']'                  { LL (unLoc $2) }
        | '[:' parr ':]'                { LL (unLoc $2) }
        | '_'                           { L1 EWildPat }

@@ -1383,6 +1387,9 @@ cvtopdecls0 :: { [LHsDecl RdrName] }
        : {- empty -}           { [] }
        | cvtopdecls            { $1 }
 
        : {- empty -}           { [] }
        | cvtopdecls            { $1 }
 

+-----------------------------------------------------------------------------
+-- Tuple expressions
+

 -- "texp" is short for tuple expressions: 
 -- things that can appear unparenthesized as long as they're
 -- inside parens or delimitted by commas
 -- "texp" is short for tuple expressions: 
 -- things that can appear unparenthesized as long as they're
 -- inside parens or delimitted by commas

@@ -1406,10 +1413,20 @@ texp :: { LHsExpr RdrName }
        -- View patterns get parenthesized above
        | exp '->' exp   { LL $ EViewPat $1 $3 }
 
        -- View patterns get parenthesized above
        | exp '->' exp   { LL $ EViewPat $1 $3 }
 

-texps :: { [LHsExpr RdrName] }
-       : texps ',' texp                { $3 : $1 }
-       | texp                          { [$1] }
+-- Always at least one comma
+tup_exprs :: { [HsTupArg RdrName] }
+           : texp commas_tup_tail  { Present $1 : $2 }
+           | commas tup_tail      { replicate $1 missingTupArg ++ $2 }
+
+-- Always starts with commas; always follows an expr
+commas_tup_tail :: { [HsTupArg RdrName] }
+commas_tup_tail : commas tup_tail  { replicate ($1-1) missingTupArg ++ $2 }

 
 

+-- Always follows a comma
+tup_tail :: { [HsTupArg RdrName] }
+          : texp commas_tup_tail       { Present $1 : $2 }
+         | texp                        { [Present $1] }
+          | {- empty -}                        { [missingTupArg] }

 
 -----------------------------------------------------------------------------
 -- List expressions
 
 -----------------------------------------------------------------------------
 -- List expressions

@@ -1657,9 +1674,9 @@ con_list : con                  { L1 [$1] }
 
 sysdcon        :: { Located DataCon }  -- Wired in data constructors
        : '(' ')'               { LL unitDataCon }
 
 sysdcon        :: { Located DataCon }  -- Wired in data constructors
        : '(' ')'               { LL unitDataCon }

-       | '(' commas ')'        { LL $ tupleCon Boxed $2 }
+       | '(' commas ')'        { LL $ tupleCon Boxed ($2 + 1) }

        | '(#' '#)'             { LL $ unboxedSingletonDataCon }
        | '(#' '#)'             { LL $ unboxedSingletonDataCon }

-       | '(#' commas '#)'      { LL $ tupleCon Unboxed $2 }
+       | '(#' commas '#)'      { LL $ tupleCon Unboxed ($2 + 1) }

        | '[' ']'               { LL nilDataCon }
 
 conop :: { Located RdrName }
        | '[' ']'               { LL nilDataCon }
 
 conop :: { Located RdrName }

@@ -1676,9 +1693,9 @@ qconop :: { Located RdrName }
 gtycon         :: { Located RdrName }  -- A "general" qualified tycon
        : oqtycon                       { $1 }
        | '(' ')'                       { LL $ getRdrName unitTyCon }
 gtycon         :: { Located RdrName }  -- A "general" qualified tycon
        : oqtycon                       { $1 }
        | '(' ')'                       { LL $ getRdrName unitTyCon }

-       | '(' commas ')'                { LL $ getRdrName (tupleTyCon Boxed $2) }
+       | '(' commas ')'                { LL $ getRdrName (tupleTyCon Boxed ($2 + 1)) }

        | '(#' '#)'                     { LL $ getRdrName unboxedSingletonTyCon }
        | '(#' '#)'                     { LL $ getRdrName unboxedSingletonTyCon }

-       | '(#' commas '#)'              { LL $ getRdrName (tupleTyCon Unboxed $2) }
+       | '(#' commas '#)'              { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) }

        | '(' '->' ')'                  { LL $ getRdrName funTyCon }
        | '[' ']'                       { LL $ listTyCon_RDR }
        | '[:' ':]'                     { LL $ parrTyCon_RDR }
        | '(' '->' ')'                  { LL $ getRdrName funTyCon }
        | '[' ']'                       { LL $ listTyCon_RDR }
        | '[:' ':]'                     { LL $ parrTyCon_RDR }

@@ -1887,7 +1904,7 @@ modid     :: { Located ModuleName }
 
 commas :: { Int }
        : commas ','                    { $1 + 1 }
 
 commas :: { Int }
        : commas ','                    { $1 + 1 }

-       | ','                           { 2 }
+       | ','                           { 1 }

 
 -----------------------------------------------------------------------------
 -- Documentation comments
 
 -----------------------------------------------------------------------------
 -- Documentation comments

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 779b67b..a914bba 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -777,8 +777,10 @@ checkAPat loc e = case e of
    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
                             return (PArrPat ps placeHolderType)
    
    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
                             return (PArrPat ps placeHolderType)
    

-   ExplicitTuple es b -> do ps <- mapM checkLPat es
-                            return (TuplePat ps b placeHolderType)
+   ExplicitTuple es b 
+     | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
+                                   return (TuplePat ps b placeHolderType)
+     | otherwise -> parseError loc "Illegal tuple section in pattern"

    
    RecordCon c _ (HsRecFields fs dd)
                       -> do fs <- mapM checkPatField fs
    
    RecordCon c _ (HsRecFields fs dd)
                       -> do fs <- mapM checkPatField fs

@@ -959,7 +961,6 @@ mkInlineSpec Nothing        match_info False = neverInlineSpec  match_info
                                                                 -- NOINLINE
 mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
 
                                                                 -- NOINLINE
 mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
 

-

 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
 
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
 

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 86b41ae..12e96d8 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -239,10 +239,14 @@ rnExpr (ExplicitPArr _ exps)
   = rnExprs exps                       `thenM` \ (exps', fvs) ->
     return  (ExplicitPArr placeHolderType exps', fvs)
 
   = rnExprs exps                       `thenM` \ (exps', fvs) ->
     return  (ExplicitPArr placeHolderType exps', fvs)
 

-rnExpr (ExplicitTuple exps boxity)
-  = checkTupSize (length exps)                 `thenM_`
-    rnExprs exps                               `thenM` \ (exps', fvs) ->
-    return (ExplicitTuple exps' boxity, fvs)
+rnExpr (ExplicitTuple tup_args boxity)
+  = do { checkTupleSection tup_args
+       ; checkTupSize (length tup_args)
+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
+       ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+  where
+    rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
+    rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)

 
 rnExpr (RecordCon con_id _ rbinds)
   = do { conname <- lookupLocatedOccRn con_id
 
 rnExpr (RecordCon con_id _ rbinds)
   = do { conname <- lookupLocatedOccRn con_id

@@ -1193,7 +1197,15 @@ checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt    -- Ok to n
 checkTransformStmt ctxt = addErr msg
   where
     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
 checkTransformStmt ctxt = addErr msg
   where
     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt

-    
+
+---------
+checkTupleSection :: [HsTupArg RdrName] -> RnM ()
+checkTupleSection args
+  = do { tuple_section <- doptM Opt_TupleSections
+       ; checkErr (all tupArgPresent args || tuple_section) msg }
+  where
+    msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
+

 ---------
 sectionErr :: HsExpr RdrName -> SDoc
 sectionErr expr
 ---------
 sectionErr :: HsExpr RdrName -> SDoc
 sectionErr expr

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 674ec78..e2adb33 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -598,7 +598,6 @@ validRuleLhs foralls lhs
     check_e (HsApp e1 e2)               = checkl_e e1 `mplus` checkl_e e2
     check_e (NegApp e _)                = checkl_e e
     check_e (ExplicitList _ es)         = checkl_es es
     check_e (HsApp e1 e2)               = checkl_e e1 `mplus` checkl_e e2
     check_e (NegApp e _)                = checkl_e e
     check_e (ExplicitList _ es)         = checkl_es es

-    check_e (ExplicitTuple es _) = checkl_es es

     check_e other               = Just other   -- Fails
 
     checkl_es es = foldr (mplus . checkl_e) Nothing es
     check_e other               = Just other   -- Fails
 
     checkl_es es = foldr (mplus . checkl_e) Nothing es

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 93d3fe9..482baba 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -280,6 +280,33 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
             ; qtys' <- mapM refineBox qtys     -- c.f. tcArgs 
             ; return (qtys', arg2') }
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
             ; qtys' <- mapM refineBox qtys     -- c.f. tcArgs 
             ; return (qtys', arg2') }
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"

+
+-- For tuples, take care to preserve rigidity
+-- E.g.        case (x,y) of ....
+--        The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
+tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty
+  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
+                                   ; Unboxed -> argTypeKind }
+             arity = length tup_args
+             tup_tc = tupleTyCon boxity arity
+             mk_tup_res_ty arg_tys 
+                 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
+                            (mkTyConApp tup_tc arg_tys)
+
+       ; checkWiredInTyCon tup_tc       -- Ensure instances are available
+       ; tvs <- newBoxyTyVars (replicate arity kind)
+       ; let arg_tys1 = map mkTyVarTy tvs
+       ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
+       
+       ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
+             go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (Present expr') }
+       ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+       
+       ; arg_tys3 <- mapM refineBox arg_tys2
+       ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
+       ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -344,23 +371,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty       -- maybe empty
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 

--- For tuples, take care to preserve rigidity
--- E.g.        case (x,y) of ....
---        The scrutinee should have a rigid type if x,y do
--- The general scheme is the same as in tcIdApp
-tcExpr (ExplicitTuple exprs boxity) res_ty
-  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
-                                   ; Unboxed -> argTypeKind }
-       ; tvs <- newBoxyTyVars [kind | e <- exprs]
-       ; let tup_tc     = tupleTyCon boxity (length exprs)
-             tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
-       ; checkWiredInTyCon tup_tc      -- Ensure instances are available
-       ; arg_tys  <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
-       ; exprs'   <- tcPolyExprs exprs arg_tys
-       ; arg_tys' <- mapM refineBox arg_tys
-       ; co_fn    <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
-       ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
-

 tcExpr (HsProc pat cmd) res_ty
   = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
 tcExpr (HsProc pat cmd) res_ty
   = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index f940e16..2192531 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -718,7 +718,7 @@ gen_Ix_binds loc tycon
 
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR) 
 
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR) 

-                                       (nlTuple [nlHsVar a, nlHsVar b] Boxed))
+                                         (mkLHsVarTuple [a,b]))

 
     ----------------
     single_con_index
 
     ----------------
     single_con_index

@@ -740,11 +740,11 @@ gen_Ix_binds loc tycon
            ) plus_RDR (
                genOpApp (
                    (nlHsApp (nlHsVar unsafeRangeSize_RDR) 
            ) plus_RDR (
                genOpApp (
                    (nlHsApp (nlHsVar unsafeRangeSize_RDR) 

-                          (nlTuple [nlHsVar l, nlHsVar u] Boxed))
+                            (mkLHsVarTuple [l,u]))

                ) times_RDR (mk_index rest)
           )
        mk_one l u i
                ) times_RDR (mk_index rest)
           )
        mk_one l u i

-         = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
+         = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]

 
     ------------------
     single_con_inRange
 
     ------------------
     single_con_inRange

@@ -753,8 +753,7 @@ gen_Ix_binds loc tycon
                 con_pat cs_needed] $
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
       where
                 con_pat cs_needed] $
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
       where

-       in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
-                                              nlHsVar c]
+       in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -832,9 +831,8 @@ gen_Read_binds get_fixity loc tycon
             _     -> [nlHsApp (nlHsVar choose_RDR) 
                              (nlList (map mk_pair nullary_cons))]
     
             _     -> [nlHsApp (nlHsVar choose_RDR) 
                              (nlList (map mk_pair nullary_cons))]
     

-    mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), 
-                          result_expr con []]
-                         Boxed
+    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), 
+                                 result_expr con []]

     
     read_non_nullary_con data_con
       | is_infix  = mk_parser infix_prec  infix_stmts  body
     
     read_non_nullary_con data_con
       | is_infix  = mk_parser infix_prec  infix_stmts  body

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 7b88356..299d70f 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -13,7 +13,7 @@ module TcHsSyn (
        mkHsConApp, mkHsDictLet, mkHsApp,
        hsLitType, hsLPatType, hsPatType, 
        mkHsAppTy, mkSimpleHsAlt,
        mkHsConApp, mkHsDictLet, mkHsApp,
        hsLitType, hsLPatType, hsPatType, 
        mkHsAppTy, mkSimpleHsAlt,

-       nlHsIntLit, mkVanillaTuplePat, 
+       nlHsIntLit, 

        shortCutLit, hsOverLitName,
        
        mkArbitraryType,        -- Put this elsewhere?
        shortCutLit, hsOverLitName,
        
        mkArbitraryType,        -- Put this elsewhere?

@@ -80,11 +80,6 @@ mappM = mapM
 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
 \begin{code}
 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
 \begin{code}

-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))
-

 hsLPatType :: OutPat Id -> Type
 hsLPatType (L _ pat) = hsPatType pat
 
 hsLPatType :: OutPat Id -> Type
 hsLPatType (L _ pat) = hsPatType pat
 

@@ -490,6 +485,13 @@ zonkExpr env (SectionR op expr)
     zonkLExpr env expr         `thenM` \ new_expr ->
     returnM (SectionR new_op new_expr)
 
     zonkLExpr env expr         `thenM` \ new_expr ->
     returnM (SectionR new_op new_expr)
 

+zonkExpr env (ExplicitTuple tup_args boxed)
+  = do { new_tup_args <- mapM zonk_tup_arg tup_args
+       ; return (ExplicitTuple new_tup_args boxed) }
+  where
+    zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
+    zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+

 zonkExpr env (HsCase expr ms)
   = zonkLExpr env expr         `thenM` \ new_expr ->
     zonkMatchGroup env ms      `thenM` \ new_ms ->
 zonkExpr env (HsCase expr ms)
   = zonkLExpr env expr         `thenM` \ new_expr ->
     zonkMatchGroup env ms      `thenM` \ new_ms ->

@@ -523,10 +525,6 @@ zonkExpr env (ExplicitPArr ty exprs)
     zonkLExprs env exprs       `thenM` \ new_exprs ->
     returnM (ExplicitPArr new_ty new_exprs)
 
     zonkLExprs env exprs       `thenM` \ new_exprs ->
     returnM (ExplicitPArr new_ty new_exprs)
 

-zonkExpr env (ExplicitTuple exprs boxed)
-  = zonkLExprs env exprs       `thenM` \ new_exprs ->
-    returnM (ExplicitTuple new_exprs boxed)
-

 zonkExpr env (RecordCon data_con con_expr rbinds)
   = do { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
 zonkExpr env (RecordCon data_con con_expr rbinds)
   = do { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 049276d..b03870e 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1269,7 +1269,7 @@ mkRecSelBind (tycon, sel_name)
                         || dataConCannotMatch inst_tys con)
     inst_tys = tyConAppArgs data_ty
 
                         || dataConCannotMatch inst_tys con)
     inst_tys = tyConAppArgs data_ty
 

-    unit_rhs = L loc $ ExplicitTuple [] Boxed
+    unit_rhs = mkLHsTupleExpr []

     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)
 
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)
 

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index fed023e..604db8d 100644 (file)
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -543,14 +543,14 @@ bimapArrow [ep1, ep2]
 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 bimapTuple eps 
 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 bimapTuple eps 

-  = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
-        toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
+  = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
+        toEP   = mkHsLam [noLoc tuple_pat] to_body }

   where
     names      = takeList eps gs_RDR
     tuple_pat  = TuplePat (map nlVarPat names) Boxed placeHolderType
     eps_w_names = eps `zip` names
   where
     names      = takeList eps gs_RDR
     tuple_pat  = TuplePat (map nlVarPat names) Boxed placeHolderType
     eps_w_names = eps `zip` names

-    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
+    to_body     = mkLHsTupleExpr [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
+    from_body   = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]

 
 -------------------
 -- bimapList :: EP a b -> EP [a] [b]
 
 -------------------
 -- bimapList :: EP a b -> EP [a] [b]

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 146c081..c3bd746 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -432,6 +432,7 @@ pprPred :: PredType -> SDoc
 pprPred (ClassP cls tys) = pprClassPred cls tys
 pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
 pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]
 pprPred (ClassP cls tys) = pprClassPred cls tys
 pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
 pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]

+

 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
 
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
 

diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 43cfa48..43e8439 100644 (file)
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1269,6 +1269,44 @@ definitions; you must define such a function in prefix form.</para>
 
 </sect2>
 
 
 </sect2>
 

+<sect2 id="tuple-sections">
+<title>Tuple sections</title>
+
+<para>
+  The <option>-XTupleSections</option> flag enables Python-style partially applied
+  tuple constructors. For example, the following program
+<programlisting>
+  (, True)
+</programlisting>
+  is considered to be an alternative notation for the more unwieldy alternative
+<programlisting>
+  \x -> (x, True)
+</programlisting>
+You can omit any combination of arguments to the tuple, as in the following
+<programlisting>
+  (, "I", , , "Love", , 1337)
+</programlisting>
+which translates to
+<programlisting>
+  \a b c d -> (a, "I", b, c, "Love", d, 1337)
+</programlisting>
+</para>
+
+<para>
+  If you have <link linkend="unboxed-tuples">unboxed tuples</link> enabled, tuple sections
+  will also be available for them, like so
+<programlisting>
+  (# , True #)
+</programlisting>
+Because there is no unboxed unit tuple, the following expression
+<programlisting>
+  (# #)
+</programlisting>
+continues to stand for the unboxed singleton tuple data constructor.
+</para>
+
+</sect2>
+

 <sect2 id="disambiguate-fields">
 <title>Record field disambiguation</title>
 <para>
 <sect2 id="disambiguate-fields">
 <title>Record field disambiguation</title>
 <para>