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

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 ...@@ -24,9 +24,9 @@ import HscTypes
import StaticFlags import StaticFlags
import TyCon import TyCon
import FiniteMap import FiniteMap
import Maybes
import Data.Array import Data.Array
import Data.Maybe
import System.Directory ( createDirectoryIfMissing ) import System.Directory ( createDirectoryIfMissing )
import Trace.Hpc.Mix import Trace.Hpc.Mix
...@@ -278,6 +278,10 @@ addTickHsExpr (SectionR e1 e2) = ...@@ -278,6 +278,10 @@ addTickHsExpr (SectionR e1 e2) =
liftM2 SectionR liftM2 SectionR
(addTickLHsExpr e1) (addTickLHsExpr e1)
(addTickLHsExpr e2) (addTickLHsExpr e2)
addTickHsExpr (ExplicitTuple es boxity) =
liftM2 ExplicitTuple
(mapM addTickTupArg es)
(return boxity)
addTickHsExpr (HsCase e mgs) = addTickHsExpr (HsCase e mgs) =
liftM2 HsCase liftM2 HsCase
(addTickLHsExpr e) (addTickLHsExpr e)
...@@ -301,17 +305,13 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do ...@@ -301,17 +305,13 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
ListComp -> Just $ BinBox QualBinBox ListComp -> Just $ BinBox QualBinBox
_ -> Nothing _ -> Nothing
addTickHsExpr (ExplicitList ty es) = addTickHsExpr (ExplicitList ty es) =
liftM2 ExplicitList liftM2 ExplicitList
(return ty) (return ty)
(mapM (addTickLHsExpr) es) (mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitPArr ty es) = addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr liftM2 ExplicitPArr
(return ty) (return ty)
(mapM (addTickLHsExpr) es) (mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitTuple es box) =
liftM2 ExplicitTuple
(mapM (addTickLHsExpr) es)
(return box)
addTickHsExpr (RecordCon id ty rec_binds) = addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon liftM3 RecordCon
(return id) (return id)
...@@ -377,6 +377,10 @@ addTickHsExpr e@(HsType _) = return e ...@@ -377,6 +377,10 @@ addTickHsExpr e@(HsType _) = return e
-- Others dhould never happen in expression content. -- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) 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 Id -> TM (MatchGroup Id)
addTickMatchGroup (MatchGroup matches ty) = do addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches let isOneOfMany = matchesOneOfMany matches
......
...@@ -217,16 +217,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do ...@@ -217,16 +217,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do
\end{code} \end{code}
\begin{code} \begin{code}
mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr 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 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} \end{code}
Translation of arrow abstraction Translation of arrow abstraction
...@@ -479,7 +474,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ ...@@ -479,7 +474,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
(core_leaf, fvs, leaf_ids) <- (core_leaf, fvs, leaf_ids) <-
dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
return (fvs `minusVarSet` bound_vars, return (fvs `minusVarSet` bound_vars,
[noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], [mkHsEnvStackExpr leaf_ids stack_ids],
envStackType leaf_ids stack, envStackType leaf_ids stack,
core_leaf) core_leaf)
......
...@@ -261,6 +261,25 @@ dsExpr (SectionR op expr) = do ...@@ -261,6 +261,25 @@ dsExpr (SectionR op expr) = do
return (bindNonRec y_id y_core $ return (bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) 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 dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs mod_name <- getModuleDs
Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
...@@ -335,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do ...@@ -335,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do
unary fn x = mkApps (Var fn) [Type ty, x] unary fn x = mkApps (Var fn) [Type ty, x]
binary fn x y = mkApps (Var fn) [Type ty, x, y] 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)) dsExpr (ArithSeq expr (From from))
= App <$> dsExpr expr <*> dsLExpr from = App <$> dsExpr expr <*> dsLExpr from
...@@ -793,7 +807,7 @@ dsMDo tbl stmts body result_ty ...@@ -793,7 +807,7 @@ dsMDo tbl stmts body result_ty
-- mkCoreTupTy deals with singleton case -- mkCoreTupTy deals with singleton case
return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mk_ret_tup rets) (mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v mk_wild_pat v = noLoc $ WildPat $ idType v
...@@ -805,10 +819,6 @@ dsMDo tbl stmts body result_ty ...@@ -805,10 +819,6 @@ dsMDo tbl stmts body result_ty
mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed 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}
......
...@@ -642,7 +642,7 @@ dePArrParComp qss body = do ...@@ -642,7 +642,7 @@ dePArrParComp qss body = do
-- empty parallel statement lists have no source representation -- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension" panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement 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 cqs <- dsPArrComp (map unLoc qs) res_expr undefined
parStmts qss (mkLHsVarPatTup xs) cqs parStmts qss (mkLHsVarPatTup xs) cqs
--- ---
...@@ -651,7 +651,7 @@ dePArrParComp qss body = do ...@@ -651,7 +651,7 @@ dePArrParComp qss body = do
zipP <- dsLookupGlobalId zipPName zipP <- dsLookupGlobalId zipPName
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea ty'cea = parrElemType cea
res_expr = mkLHsVarTup xs res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs) res_expr undefined cqs <- dsPArrComp (map unLoc qs) res_expr undefined
let ty'cqs = parrElemType cqs let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, 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) ...@@ -712,8 +712,10 @@ repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed) repE e@(ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs } | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
| otherwise = 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) repE (RecordCon c _ flds)
= do { x <- lookupLOcc c; = do { x <- lookupLOcc c;
fs <- repFields flds; fs <- repFields flds;
......
...@@ -27,7 +27,7 @@ module DsUtils ( ...@@ -27,7 +27,7 @@ module DsUtils (
seqVar, seqVar,
-- LHs tuples -- LHs tuples
mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup, mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
mkSelectorBinds, mkSelectorBinds,
...@@ -583,37 +583,31 @@ mkSelectorBinds pat val_expr ...@@ -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 :: [LPat Id] -> LPat Id
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed 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 -- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id mkBigLHsVarTup :: [Id] -> LHsExpr Id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
mkBigLHsTup = mkChunkified mkLHsTup mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns -- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [Id] -> LPat Id mkBigLHsVarPatTup :: [Id] -> LPat Id
......
...@@ -841,12 +841,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) ...@@ -841,12 +841,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
-- are "equal"---conservatively, we use syntactic equality -- are "equal"---conservatively, we use syntactic equality
sameGroup _ _ = False sameGroup _ _ = False
-- An approximation of syntactic equality used for determining when view
-- exprs are in the same group. -- 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. -- 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 -- and anything else that we can do without involving other
-- HsSyn types in the recursion -- HsSyn types in the recursion
-- --
...@@ -859,12 +859,11 @@ viewLExprEq (e1,_) (e2,_) = ...@@ -859,12 +859,11 @@ viewLExprEq (e1,_) (e2,_) =
-- short name for recursive call on unLoc -- short name for recursive call on unLoc
lexp e e' = exp (unLoc e) (unLoc e') lexp e e' = exp (unLoc e) (unLoc e')
-- check that two lists have the same length eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
-- and that they match up pairwise eq_list _ [] [] = True
lexps [] [] = True eq_list _ [] (_:_) = False
lexps [] (_:_) = False eq_list _ (_:_) [] = False
lexps (_:_) [] = False eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
lexps (x:xs) (y:ys) = lexp x y && lexps xs ys
-- conservative, in that it demands that wrappers be -- conservative, in that it demands that wrappers be
-- syntactically identical and doesn't look under binders -- syntactically identical and doesn't look under binders
...@@ -893,15 +892,13 @@ viewLExprEq (e1,_) (e2,_) = ...@@ -893,15 +892,13 @@ viewLExprEq (e1,_) (e2,_) =
-- above does -- above does
exp (HsIPVar i) (HsIPVar i') = i == i' exp (HsIPVar i) (HsIPVar i') = i == i'
exp (HsOverLit l) (HsOverLit l') = 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. -- and the data is the same.
-- this is coarser than comparing the SyntaxExpr's in l and l', -- this is coarser than comparing the SyntaxExpr's in l and l',
-- which resolve the overloading (e.g., fromInteger 1), -- which resolve the overloading (e.g., fromInteger 1),
-- because these expressions get written as a bunch of different variables -- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing) -- (presumably to improve sharing)
tcEqType (overLitType l) (overLitType l') && l == l' 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' 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 -- the fixities have been straightened out by now, so it's safe
-- to ignore them? -- to ignore them?
...@@ -912,14 +909,20 @@ viewLExprEq (e1,_) (e2,_) = ...@@ -912,14 +909,20 @@ viewLExprEq (e1,_) (e2,_) =
lexp e1 e1' && lexp e2 e2' lexp e1 e1' && lexp e2 e2'
exp (SectionR e1 e2) (SectionR e1' e2') = exp (SectionR e1 e2) (SectionR e1' e2') =
lexp e1 e1' && lexp e2 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') = exp (HsIf e e1 e2) (HsIf e' e1' e2') =
lexp e e' && lexp e1 e1' && lexp e2 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 -- Enhancement: could implement equality for more expressions
-- if it seems useful -- 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 in
lexp e1 e2 lexp e1 e2
......
...@@ -521,7 +521,7 @@ cvtl e = wrapL (cvt e) ...@@ -521,7 +521,7 @@ cvtl e = wrapL (cvt e)
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) 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 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
; return $ HsIf x' y' z' } ; return $ HsIf x' y' z' }
cvt (LetE ds e) = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' } cvt (LetE ds e) = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
......
...@@ -121,6 +121,10 @@ data HsExpr id ...@@ -121,6 +121,10 @@ data HsExpr id
| SectionR (LHsExpr id) -- operator | SectionR (LHsExpr id) -- operator
(LHsExpr id) -- operand (LHsExpr id) -- operand
| ExplicitTuple -- Used for explicit tuples and sections thereof
[HsTupArg id]
Boxity
| HsCase (LHsExpr id) | HsCase (LHsExpr id)
(MatchGroup id) (MatchGroup id)
...@@ -147,14 +151,6 @@ data HsExpr id ...@@ -147,14 +151,6 @@ data HsExpr id
PostTcType -- type of elements of the parallel array PostTcType -- type of elements of the parallel array
[LHsExpr id] [LHsExpr id]
| ExplicitTuple -- tuple
[LHsExpr id]
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
Boxity
-- Record construction -- Record construction
| RecordCon (Located id) -- The constructor. After type checking | RecordCon (Located id) -- The constructor. After type checking
-- it's the dataConWrapId of the constructor -- it's the dataConWrapId of the constructor
...@@ -280,6 +276,17 @@ data HsExpr id ...@@ -280,6 +276,17 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION | HsWrap HsWrapper -- TRANSLATION
(HsExpr id) (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 type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
-- pasted back in by the desugarer -- pasted back in by the desugarer
\end{code} \end{code}
...@@ -380,6 +387,17 @@ ppr_expr (SectionR op expr) ...@@ -380,6 +387,17 @@ ppr_expr (SectionR op expr)
pp_infixly v pp_infixly v
= (sep [pprHsInfix v, pp_expr]) = (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 --avoid using PatternSignatures for stage1 code portability
ppr_expr exprType@(HsLam matches) ppr_expr exprType@(HsLam matches)
= pprMatches (LambdaExpr `asTypeOf` idType exprType) matches = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
...@@ -413,9 +431,6 @@ ppr_expr (ExplicitList _ exprs) ...@@ -413,9 +431,6 @@ ppr_expr (ExplicitList _ exprs)
ppr_expr (ExplicitPArr _ exprs) ppr_expr (ExplicitPArr _ exprs)
= pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr 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) ppr_expr (RecordCon con_id _ rbinds)
= hang (ppr con_id) 2 (ppr rbinds) = hang (ppr con_id) 2 (ppr rbinds)
...@@ -529,18 +544,18 @@ pprParendExpr expr ...@@ -529,18 +544,18 @@ pprParendExpr expr
-- I think that is usually (always?) right -- I think that is usually (always?) right
in in
case unLoc expr of case unLoc expr of
ArithSeq{} -> pp_as_was ArithSeq {} -> pp_as_was
PArrSeq{} -> pp_as_was PArrSeq {} -> pp_as_was
HsLit _ -> pp_as_was HsLit {} -> pp_as_was
HsOverLit _ -> pp_as_was HsOverLit {} -> pp_as_was
HsVar _ -> pp_as_was HsVar {} -> pp_as_was
HsIPVar _ -> pp_as_was HsIPVar {} -> pp_as_was
ExplicitList _ _ -> pp_as_was ExplicitTuple {} -> pp_as_was
ExplicitPArr _ _ -> pp_as_was ExplicitList {} -> pp_as_was
ExplicitTuple _ _ -> pp_as_was ExplicitPArr {} -> pp_as_was
HsPar _ -> pp_as_was HsPar {} -> pp_as_was
HsBracket _ -> pp_as_was HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was HsBracketOut _ [] -> pp_as_was
HsDo sc _ _ _ HsDo sc _ _ _
| isListCompExpr sc -> pp_as_was | isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was _ -> parens pp_as_was
......
...@@ -245,9 +245,6 @@ nlWildConPat :: DataCon -> LPat RdrName ...@@ -245,9 +245,6 @@ nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
nlTuplePat :: [LPat id] -> Boxity -> LPat id
nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
nlWildPat :: LPat id nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
...@@ -261,14 +258,12 @@ nlHsLam :: LMatch id -> LHsExpr id ...@@ -261,14 +258,12 @@ nlHsLam :: LMatch id -> LHsExpr id
nlHsPar :: LHsExpr id -> LHsExpr id nlHsPar :: LHsExpr id -> LHsExpr id
nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
nlTuple :: [LHsExpr id] -> Boxity -> LHsExpr id
nlList :: [LHsExpr id] -> LHsExpr id nlList :: [LHsExpr id] -> LHsExpr id
nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e) nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (HsIf cond true false) nlHsIf cond true false = noLoc (HsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
nlList exprs = noLoc (ExplicitList placeHolderType exprs) nlList exprs = noLoc (ExplicitList placeHolderType exprs)
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
...@@ -283,7 +278,24 @@ nlHsTyConApp :: name -> [LHsType name] -> LHsType name ...@@ -283,7 +278,24 @@ nlHsTyConApp :: name -> [LHsType name] -> LHsType name
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
\end{code} \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 ...@@ -250,6 +250,7 @@ data DynFlag
| Opt_GeneralizedNewtypeDeriving | Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo