From 58521c72cec262496dabf5fffb057d25ab17a0f7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 23 Jul 2009 06:38:59 +0000 Subject: [PATCH] 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. --- compiler/deSugar/Coverage.lhs | 16 +++++---- compiler/deSugar/DsArrows.lhs | 15 +++------ compiler/deSugar/DsExpr.lhs | 30 +++++++++++------ compiler/deSugar/DsListComp.lhs | 4 +-- compiler/deSugar/DsMeta.hs | 6 ++-- compiler/deSugar/DsUtils.lhs | 32 ++++++++---------- compiler/deSugar/Match.lhs | 33 ++++++++++--------- compiler/hsSyn/Convert.lhs | 2 +- compiler/hsSyn/HsExpr.lhs | 61 ++++++++++++++++++++++------------- compiler/hsSyn/HsUtils.lhs | 22 ++++++++++--- compiler/main/DynFlags.hs | 2 ++ compiler/parser/Parser.y.pp | 37 +++++++++++++++------ compiler/parser/RdrHsSyn.lhs | 7 ++-- compiler/rename/RnExpr.lhs | 22 ++++++++++--- compiler/rename/RnSource.lhs | 1 - compiler/typecheck/TcExpr.lhs | 44 +++++++++++++++---------- compiler/typecheck/TcGenDeriv.lhs | 14 ++++---- compiler/typecheck/TcHsSyn.lhs | 18 +++++------ compiler/typecheck/TcTyClsDecls.lhs | 2 +- compiler/types/Generics.lhs | 8 ++--- compiler/types/TypeRep.lhs | 1 + docs/users_guide/glasgow_exts.xml | 38 ++++++++++++++++++++++ 22 files changed, 263 insertions(+), 152 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 8260cfb..f31b2c8 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -24,9 +24,9 @@ import HscTypes import StaticFlags import TyCon import FiniteMap +import Maybes import Data.Array -import Data.Maybe import System.Directory ( createDirectoryIfMissing ) import Trace.Hpc.Mix @@ -278,6 +278,10 @@ addTickHsExpr (SectionR e1 e2) = liftM2 SectionR (addTickLHsExpr e1) (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple es boxity) = + liftM2 ExplicitTuple + (mapM addTickTupArg es) + (return boxity) addTickHsExpr (HsCase e mgs) = liftM2 HsCase (addTickLHsExpr e) @@ -301,17 +305,13 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do ListComp -> Just $ BinBox QualBinBox _ -> Nothing addTickHsExpr (ExplicitList ty es) = - liftM2 ExplicitList + liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) (mapM (addTickLHsExpr) es) -addTickHsExpr (ExplicitTuple es box) = - liftM2 ExplicitTuple - (mapM (addTickLHsExpr) es) - (return box) addTickHsExpr (RecordCon id ty rec_binds) = liftM3 RecordCon (return id) @@ -377,6 +377,10 @@ addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) +addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id) +addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') } +addTickTupArg (Missing ty) = return (Missing ty) + addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id) addTickMatchGroup (MatchGroup matches ty) = do let isOneOfMany = matchesOneOfMany matches diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 76117b3..cead3dd 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -217,16 +217,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do \end{code} \begin{code} -mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id -mkHsTupleExpr [e] = e -mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed - -mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id -mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2] - -mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id +mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id mkHsEnvStackExpr env_ids stack_ids - = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids) + = foldl (\a b -> mkLHsTupleExpr [a,b]) + (mkLHsVarTuple env_ids) + (map nlHsVar stack_ids) \end{code} Translation of arrow abstraction @@ -479,7 +474,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ (core_leaf, fvs, leaf_ids) <- dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf return (fvs `minusVarSet` bound_vars, - [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], + [mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 2eca842..820bd9a 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -261,6 +261,25 @@ dsExpr (SectionR op expr) = do return (bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) +dsExpr (ExplicitTuple tup_args boxity) + = do { let go (lam_vars, args) (Missing ty) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDs ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (Present expr) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExpr expr + ; return (lam_vars, core_expr : args) } + + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + -- The reverse is because foldM goes left-to-right + + ; return $ mkCoreLams lam_vars $ + mkConApp (tupleCon boxity (length tup_args)) + (map (Type . exprType) args ++ args) } + dsExpr (HsSCC cc expr) = do mod_name <- getModuleDs Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr @@ -335,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] -dsExpr (ExplicitTuple expr_list boxity) = do - core_exprs <- mapM dsLExpr expr_list - return (mkConApp (tupleCon boxity (length expr_list)) - (map (Type . exprType) core_exprs ++ core_exprs)) - dsExpr (ArithSeq expr (From from)) = App <$> dsExpr expr <*> dsLExpr from @@ -793,7 +807,7 @@ dsMDo tbl stmts body result_ty -- mkCoreTupTy deals with singleton case return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mk_ret_tup rets) + (mkLHsTupleExpr rets) mk_wild_pat :: Id -> LPat Id mk_wild_pat v = noLoc $ WildPat $ idType v @@ -805,10 +819,6 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed - - mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id - mk_ret_tup [r] = r - mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed \end{code} diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 99a5dab..e7c1f20 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -642,7 +642,7 @@ dePArrParComp qss body = do -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = do -- first statement - let res_expr = mkLHsVarTup xs + let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined parStmts qss (mkLHsVarPatTup xs) cqs --- @@ -651,7 +651,7 @@ dePArrParComp qss body = do zipP <- dsLookupGlobalId zipPName let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea - res_expr = mkLHsVarTup xs + res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ab40ab1..411da40 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -712,8 +712,10 @@ repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) - | isBoxed boxed = do { xs <- repLEs es; repTup xs } - | otherwise = notHandled "Unboxed tuples" (ppr e) + | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e) + | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) + | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs } + repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index d932ab1..f565021 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -27,7 +27,7 @@ module DsUtils ( seqVar, -- LHs tuples - mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup, + mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, mkSelectorBinds, @@ -583,37 +583,31 @@ mkSelectorBinds pat val_expr \end{code} -Creating tuples and their types for full Haskell expressions +Creating big tuples and their types for full Haskell expressions. +They work over *Ids*, and create tuples replete with their types, +which is whey they are not in HsUtils. \begin{code} - --- Smart constructors for source tuple expressions -mkLHsVarTup :: [Id] -> LHsExpr Id -mkLHsVarTup ids = mkLHsTup (map nlHsVar ids) - -mkLHsTup :: [LHsExpr Id] -> LHsExpr Id -mkLHsTup [] = nlHsVar unitDataConId -mkLHsTup [lexp] = lexp -mkLHsTup lexps = L (getLoc (head lexps)) $ - ExplicitTuple lexps Boxed - --- Smart constructors for source tuple patterns -mkLHsVarPatTup :: [Id] -> LPat Id -mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) - mkLHsPatTup :: [LPat Id] -> LPat Id mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed +mkLHsVarPatTup :: [Id] -> LPat Id +mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) + +mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box + = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats)) + -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [Id] -> LHsExpr Id mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id -mkBigLHsTup = mkChunkified mkLHsTup - +mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns mkBigLHsVarPatTup :: [Id] -> LPat Id diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 474f7bf..d90f904 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -841,12 +841,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False --- an approximation of syntactic equality used for determining when view +-- An approximation of syntactic equality used for determining when view -- exprs are in the same group. --- this function can always safely return false; +-- This function can always safely return false; -- but doing so will result in the application of the view function being repeated. -- --- currently: compare applications of literals and variables +-- Currently: compare applications of literals and variables -- and anything else that we can do without involving other -- HsSyn types in the recursion -- @@ -859,12 +859,11 @@ viewLExprEq (e1,_) (e2,_) = -- short name for recursive call on unLoc lexp e e' = exp (unLoc e) (unLoc e') - -- check that two lists have the same length - -- and that they match up pairwise - lexps [] [] = True - lexps [] (_:_) = False - lexps (_:_) [] = False - lexps (x:xs) (y:ys) = lexp x y && lexps xs ys + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys -- conservative, in that it demands that wrappers be -- syntactically identical and doesn't look under binders @@ -893,15 +892,13 @@ viewLExprEq (e1,_) (e2,_) = -- above does exp (HsIPVar i) (HsIPVar i') = i == i' exp (HsOverLit l) (HsOverLit l') = - -- overloaded lits are equal if they have the same type + -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', -- which resolve the overloading (e.g., fromInteger 1), -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) tcEqType (overLitType l) (overLitType l') && l == l' - -- comparing the constants seems right - exp (HsLit l) (HsLit l') = l == l' exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? @@ -912,14 +909,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e1' && lexp e2 e2' exp (SectionR e1 e2) (SectionR e1' e2') = lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + eq_list tup_arg es1 es2 exp (HsIf e e1 e2) (HsIf e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' - exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls' - exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls' - exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls' + -- Enhancement: could implement equality for more expressions -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions exp _ _ = False + + tup_arg (Present e1) (Present e2) = lexp e1 e2 + tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2 + tup_arg _ _ = False in lexp e1 e2 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 8b64c98..9928420 100644 --- 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 (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' } diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index db54ab8..3142abc 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index db9460e..667f8cc 100644 --- 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))) -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} %************************************************************************ %* * diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 17dc60c..500d257 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 ), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index cbc3bcb..47307ff 100644 --- 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) } + -- 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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 779b67b..a914bba 100644 --- 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) - 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 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 86b41ae..12e96d8 100644 --- 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) -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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 674ec78..e2adb33 100644 --- 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 (ExplicitTuple es _) = checkl_es 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 --- 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" + +-- 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') } diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index f940e16..2192531 100644 --- 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) - (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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 7b88356..299d70f 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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 + 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 -> @@ -523,10 +525,6 @@ zonkExpr env (ExplicitPArr ty 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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 049276d..b03870e 100644 --- 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 - unit_rhs = L loc $ ExplicitTuple [] Boxed + unit_rhs = mkLHsTupleExpr [] msg_lit = HsStringPrim $ mkFastString $ occNameString (getOccName sel_name) diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index fed023e..604db8d 100644 --- 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 - = 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 - 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] diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 146c081..c3bd746 100644 --- 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] + 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 --- 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. + +Tuple sections + + + The flag enables Python-style partially applied + tuple constructors. For example, the following program + + (, True) + + is considered to be an alternative notation for the more unwieldy alternative + + \x -> (x, True) + +You can omit any combination of arguments to the tuple, as in the following + + (, "I", , , "Love", , 1337) + +which translates to + + \a b c d -> (a, "I", b, c, "Love", d, 1337) + + + + + If you have unboxed tuples enabled, tuple sections + will also be available for them, like so + + (# , True #) + +Because there is no unboxed unit tuple, the following expression + + (# #) + +continues to stand for the unboxed singleton tuple data constructor. + + + + Record field disambiguation -- 1.7.10.4