Commit 58521c72 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 4b8dfb01
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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]
......
......@@ -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;
......
......@@ -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
......
......@@ -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
-- exprs are in the same group.
-- exprs are in the same group.
-- 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
-- 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
......
......@@ -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 (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' }
......
......@@ -121,6 +121,10 @@ data HsExpr id
| SectionR (LHsExpr id) -- operator
(LHsExpr id) -- operand
| ExplicitTuple -- Used for explicit tuples and sections thereof
[HsTupArg id]
Boxity
| HsCase (LHsExpr id)
(MatchGroup id)
......@@ -147,14 +151,6 @@ data HsExpr 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
......@@ -280,6 +276,17 @@ data 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}
......@@ -380,6 +387,17 @@ ppr_expr (SectionR op 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
......@@ -413,9 +431,6 @@ ppr_expr (ExplicitList _ 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)
......@@ -529,18 +544,18 @@ pprParendExpr expr
-- 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
......
......@@ -245,9 +245,6 @@ nlWildConPat :: DataCon -> LPat RdrName
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
......@@ -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
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))
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
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}
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}
%************************************************************************
%* *
......
......@@ -250,6 +250,7 @@ data DynFlag
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_PostfixOperators
| Opt_TupleSections
| 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 ),
( "TupleSections", Opt_TupleSections, const Supported ),
( "PatternGuards", Opt_PatternGuards, const Supported ),
( "UnicodeSyntax", Opt_UnicodeSyntax, const Supported ),
( "MagicHash", Opt_MagicHash, const Supported ),
......
......@@ -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) }
-- 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 }
......@@ -1383,6 +1387,9 @@ cvtopdecls0 :: { [LHsDecl RdrName] }
: {- 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
......@@ -1406,10 +1413,20 @@ texp :: { LHsExpr RdrName }
-- 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
......@@ -1657,9 +1674,9 @@ con_list : con { L1 [$1] }
sysdcon :: { Located DataCon } -- Wired in data constructors
: '(' ')' { LL unitDataCon }
| '(' commas ')' { LL $ tupleCon Boxed $2 }
| '(' commas ')' { LL $ tupleCon Boxed ($2 + 1) }
| '(#' '#)' { LL $ unboxedSingletonDataCon }
| '(#' commas '#)' { LL $ tupleCon Unboxed $2 }
| '(#' commas '#)' { LL $ tupleCon Unboxed ($2 + 1) }
| '[' ']' { LL nilDataCon }
conop :: { Located RdrName }
......@@ -1676,9 +1693,9 @@ qconop :: { Located RdrName }
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 }
| '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed $2) }
| '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) }
| '(' '->' ')' { LL $ getRdrName funTyCon }
| '[' ']' { LL $ listTyCon_RDR }
| '[:' ':]' { LL $ parrTyCon_RDR }
......@@ -1887,7 +1904,7 @@ modid :: { Located ModuleName }
commas :: { Int }
: commas ',' { $1 + 1 }
| ',' { 2 }
| ',' { 1 }
-----------------------------------------------------------------------------
-- Documentation comments
......
......@@ -777,8 +777,10 @@ checkAPat loc e = case e of
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
......@@ -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
-----------------------------------------------------------------------------
-- utilities for foreign declarations
......
......@@ -239,10 +239,14 @@ rnExpr (ExplicitPArr _ exps)
= 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
......@@ -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
---------
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
......
......@@ -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 (ExplicitTuple es _) = checkl_es es
check_e other = Just other -- Fails
checkl_es es = foldr (mplus . checkl_e) Nothing es
......
......@@ -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"
-- 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}
......@@ -344,23 +371,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
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') }
......
......@@ -718,7 +718,7 @@ gen_Ix_binds loc tycon
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
......@@ -740,11 +740,11 @@ gen_Ix_binds loc tycon
) 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
= nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
= nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
------------------
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
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}
%************************************************************************
......@@ -832,9 +831,8 @@ gen_Read_binds get_fixity loc tycon
_ -> [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
......
......@@ -13,7 +13,7 @@ module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat,
nlHsIntLit,
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}
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
......@@ -490,6 +485,13 @@ zonkExpr env (SectionR op 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