From: simonpj Date: Tue, 8 May 2001 14:44:38 +0000 (+0000) Subject: [project @ 2001-05-08 14:44:37 by simonpj] X-Git-Tag: Approximately_9120_patches~1975 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7c72bad588294734ecf3590247c67e47f8ba63fd;p=ghc-hetmet.git [project @ 2001-05-08 14:44:37 by simonpj] **** MERGE WITH 5.00 BRANCH ******** -------------------------------------- Make parallel list comprehensions work -------------------------------------- There were two bugs 1. The desugaring in DsListComp was generating code that failed Lint. I've restructured it quite a lot. 2. More seriously, in a ParStmt, the last 'stmt' may be a guard; but previously both guards and the result of a list comprehension were encoded as an ExprStmt (see HsExpr.Stmt), using the fact that the stmt was last in the list to make the difference between a guard and a result. But in parallel list comp this isn't right: [ e | x <- xs, guard | y <- ys ] Here 'guard' is last in its list, but isn't an overall result. The sensible fix is to properly distinguish "here's the answer" (ResultStmt) "here's a guard or an imperative action" (ExprStmt) The fix is rather easy, but touched quite a lot of files. On the way I tidied up the parser a little. --- diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 02dc08e..abb2f1e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -507,7 +507,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty -- -- In dsDo we can only see DoStmt and ListComp (no gaurds) - go [ExprStmt expr locn] + go [ResultStmt expr locn] | isDoExpr do_or_lc = do_expr expr locn | otherwise = do_expr expr locn `thenDs` \ expr2 -> returnDs (mkApps (Var return_id) [Type b_ty, expr2]) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 918ec65..ab236f9 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -77,11 +77,11 @@ matchGuard :: [TypecheckedStmt] -- Guard -- See comments with HsExpr.HsStmt re what an ExprStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuard [ExprStmt expr locn] ctx +matchGuard [ResultStmt expr locn] ctx = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr -> returnDs (cantFailMatchResult core_expr) - -- Other ExprStmts must be guards + -- ExprStmts must be guards -- Turn an "otherwise" guard is a no-op matchGuard (ExprStmt (HsVar v) _ : stmts) ctx | v `hasKey` otherwiseIdKey diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 337535d..ef622eb 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) ) -import TcHsSyn ( TypecheckedStmt ) +import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr ) import DsHsSyn ( outPatType ) import CoreSyn @@ -25,11 +25,10 @@ import Id ( idType ) import Var ( Id ) import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar ) -import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy ) +import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, mkListTy, mkTupleTy ) import Match ( matchSimply ) import PrelNames ( foldrName, buildName ) import SrcLoc ( noSrcLoc ) -import List ( zip4 ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -112,9 +111,12 @@ comprehensions. The translation goes roughly as follows: [ e | p1 <- e11, let v1 = e12, p2 <- e13 | q1 <- e21, let v2 = e22, q2 <- e23] => - [ e | ((p1,v1,p2), (q1,v2,q2)) <- - zip [(p1,v1,p2) | p1 <- e11, let v1 = e12, p2 <- e13] - [(q1,v2,q2) | q1 <- e21, let v2 = e22, q2 <- e23]] + [ e | ((x1, .., xn), (y1, ..., ym)) <- + zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] + [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] +where (x1, .., xn) are the variables bound in p1, v1, p2 + (y1, .., ym) are the variables bound in q1, v2, q2 + In the translation below, the ParStmtOut branch translates each parallel branch into a sub-comprehension, and desugars each independently. The resulting lists are fed to a zip function, we create a binding for all the variables bound in all @@ -130,59 +132,28 @@ with the Unboxed variety. deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr deListComp (ParStmtOut bndrstmtss : quals) list - = mapDs doListComp qualss `thenDs` \ exps -> - mapDs genAS bndrss `thenDs` \ ass -> - mapDs genA bndrss `thenDs` \ as -> - mapDs genAS' bndrss `thenDs` \ as's -> - let retTy = myTupleTy Boxed (length bndrss) qualTys - zipTy = foldr mkFunTy (mkListTy retTy) (map mkListTy qualTys) - in - newSysLocalDs zipTy `thenDs` \ zipFn -> - let target = mkConsExpr retTy (mkTupleExpr as) (foldl App (Var zipFn) (map Var as's)) - zipExp = mkLet zipFn (zip4 bndrss ass as as's) exps target - in - deBindComp pat zipExp quals list - where (bndrss, stmtss) = unzip bndrstmtss - pats = map (\ps -> mkTuplePat (map VarPat ps)) bndrss - mkTuplePat [p] = p - mkTuplePat ps = TuplePat ps Boxed - pat = TuplePat pats Boxed - - qualss = map mkQuals bndrstmtss - mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ExprStmt (myTupleExpr bndrs) noSrcLoc]) - - qualTys = map mkBndrsTy bndrss - mkBndrsTy bndrs = myTupleTy Boxed (length bndrs) (map idType bndrs) - - doListComp (bndrs, stmts) - = dsListComp stmts (mkBndrsTy bndrs) - genA bndrs = newSysLocalDs (mkBndrsTy bndrs) - genAS bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) - genAS' bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) - - mkLet zipFn vars exps target - = Let (Rec [(zipFn, - foldr Lam (mkBody target vars) (map getAs vars))]) - (foldl App (Var zipFn) exps) - getAs (_, as, _, _) = as - mkBody target vars - = foldr mkCase (foldr mkTuplCase target vars) vars - mkCase (ps, as, a, as') rest - = Case (Var as) as [(DataAlt nilDataCon, [], mkConApp nilDataCon []), - (DataAlt consDataCon, [a, as'], rest)] - mkTuplCase ([p], as, a, as') rest - = App (Lam p rest) (Var a) - mkTuplCase (ps, as, a, as') rest - = Case (Var a) a [(DataAlt (tupleCon Boxed (length ps)), ps, rest)] - - myTupleTy boxity arity [ty] = ty - myTupleTy boxity arity tys = mkTupleTy boxity arity tys - myTupleExpr [] = HsVar unitDataConId - myTupleExpr [id] = HsVar id - myTupleExpr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed + = mapDs do_list_comp bndrstmtss `thenDs` \ exps -> + mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) -> + + -- Deal with [e | pat <- zip l1 .. ln] in example above + deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list + + where -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = TuplePat pats Boxed + pats = map (\(bs,_) -> mk_hs_tuple_pat bs) bndrstmtss + + -- Types of (x1,..,xn), (y1,..,yn) etc + qual_tys = [ mk_bndrs_tys bndrs | (bndrs,_) <- bndrstmtss ] + + do_list_comp (bndrs, stmts) + = dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc]) + (mk_bndrs_tys bndrs) + + mk_bndrs_tys bndrs = mk_tuple_ty (map idType bndrs) -- Last: the one to return -deListComp [ExprStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above +deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr `thenDs` \ core_expr -> returnDs (mkConsExpr (exprType core_expr) core_expr list) @@ -200,7 +171,10 @@ deListComp (LetStmt binds : quals) list deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> deBindComp pat core_list1 quals core_list2 +\end{code} + +\begin{code} deBindComp pat core_list1 quals core_list2 = let u3_ty@u1_ty = exprType core_list1 -- two names, same thing @@ -230,6 +204,52 @@ deBindComp pat core_list1 quals core_list2 \end{code} +\begin{code} +mkZipBind :: [Type] -> DsM (Id, CoreExpr) +-- mkZipBind [t1, t2] +-- = (zip, \as1:[t1] as2:[t2] +-- -> case as1 of +-- [] -> [] +-- (a1:as'1) -> case as2 of +-- [] -> [] +-- (a2:as'2) -> (a2,a2) : zip as'1 as'2)] + +mkZipBind elt_tys + = mapDs newSysLocalDs list_tys `thenDs` \ ass -> + mapDs newSysLocalDs elt_tys `thenDs` \ as' -> + mapDs newSysLocalDs list_tys `thenDs` \ as's -> + newSysLocalDs zip_fn_ty `thenDs` \ zip_fn -> + let + inner_rhs = mkConsExpr ret_elt_ty (mkTupleExpr as') (mkVarApps (Var zip_fn) as's) + zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) + in + returnDs (zip_fn, mkLams ass zip_body) + where + list_tys = map mkListTy elt_tys + ret_elt_ty = mk_tuple_ty elt_tys + zip_fn_ty = mkFunTys list_tys (mkListTy ret_elt_ty) + + mk_case (as, a', as') rest + = Case (Var as) as [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty), + (DataAlt consDataCon, [a', as'], rest)] + +-- Helper function +mk_tuple_ty :: [Type] -> Type +mk_tuple_ty [ty] = ty +mk_tuple_ty tys = mkTupleTy Boxed (length tys) tys + +-- Helper functions that makes an HsTuple only for non-1-sized tuples +mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr +mk_hs_tuple_expr [] = HsVar unitDataConId +mk_hs_tuple_expr [id] = HsVar id +mk_hs_tuple_expr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed + +mk_hs_tuple_pat :: [Id] -> TypecheckedPat +mk_hs_tuple_pat [b] = VarPat b +mk_hs_tuple_pat bs = TuplePat (map VarPat bs) Boxed +\end{code} + + %************************************************************************ %* * \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} @@ -255,7 +275,7 @@ dfListComp :: Id -> Id -- 'c' and 'n' -> DsM CoreExpr -- Last: the one to return -dfListComp c_id n_id [ExprStmt expr locn] +dfListComp c_id n_id [ResultStmt expr locn] = dsExpr expr `thenDs` \ core_expr -> returnDs (mkApps (Var c_id) [core_expr, Var n_id]) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index e65e3fc..c5cd5b5 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -452,7 +452,7 @@ data GRHSs id pat (Maybe Type) -- Just rhs_ty after type checking data GRHS id pat - = GRHS [Stmt id pat] -- The RHS is the final ExprStmt + = GRHS [Stmt id pat] -- The RHS is the final ResultStmt -- I considered using a RetunStmt, but -- it printed 'wrong' in error messages SrcLoc @@ -462,7 +462,7 @@ mkSimpleMatch pats rhs maybe_rhs_ty locn = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty) unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] -unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc] +unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] \end{code} @getMatchLoc@ takes a @Match@ and returns the @@ -508,16 +508,16 @@ pprGRHSs is_case (GRHSs grhss binds maybe_ty) pprGRHS :: (Outputable id, Outputable pat) => Bool -> GRHS id pat -> SDoc -pprGRHS is_case (GRHS [ExprStmt expr _] locn) - = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) +pprGRHS is_case (GRHS [ResultStmt expr _] locn) + = pp_rhs is_case expr pprGRHS is_case (GRHS guarded locn) - = sep [char '|' <+> interpp'SP guards, - text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) - ] + = sep [char '|' <+> interpp'SP guards, pp_rhs is_case expr] where - ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards - guards = init guarded + ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards + guards = init guarded + +pp_rhs is_case rhs = text (if is_case then "->" else "=") <+> pprDeeper (ppr rhs) \end{code} @@ -532,46 +532,49 @@ pprGRHS is_case (GRHS guarded locn) data Stmt id pat = BindStmt pat (HsExpr id pat) SrcLoc | LetStmt (HsBinds id pat) + | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow | ExprStmt (HsExpr id pat) SrcLoc -- See notes that follow | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals - | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming + | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders + -- bound by the stmts \end{code} -ExprStmts are a bit tricky, because what -they mean depends on the context. Consider - ExprStmt E -in the following contexts: +ExprStmts and ResultStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: A do expression of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Non-last stmt in list: do { ....; E; ... } + * ExprStmt E: do { ....; E; ... } E :: m any_ty Translation: E >> ... - * Last stmt in list: do { ....; E } + * ResultStmt E: do { ....; E } E :: m res_ty Translation: E A list comprehensions of type [elt_ty] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Non-last stmt in list: [ .. | ..., E, ... ] + * ExprStmt E: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] E :: Bool Translation: if E then fail else ... - - * Last stmt in list: [ E | ... ] + + * ResultStmt E: [ E | ... ] E :: elt_ty Translation: return E A guard list, guarding a RHS of type rhs_ty ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Non-last stmt in list: f x | ..., E, ... = ...rhs... + * ExprStmt E: f x | ..., E, ... = ...rhs... E :: Bool Translation: if E then fail else ... - * Last stmt in list: f x | ...guards... = E + * ResultStmt E: f x | ...guards... = E E :: rhs_ty Translation: E + \begin{code} consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] consLetStmt EmptyBinds stmts = stmts @@ -583,16 +586,14 @@ instance (Outputable id, Outputable pat) => Outputable (Stmt id pat) where ppr stmt = pprStmt stmt +pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] +pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] +pprStmt (ExprStmt expr _) = ppr expr +pprStmt (ResultStmt expr _) = ppr expr pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) pprStmt (ParStmtOut stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) -pprStmt (BindStmt pat expr _) - = hsep [ppr pat, ptext SLIT("<-"), ppr expr] -pprStmt (LetStmt binds) - = hsep [ptext SLIT("let"), pprBinds binds] -pprStmt (ExprStmt expr _) - = ppr expr pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) @@ -600,8 +601,8 @@ pprDo ListComp stmts = brackets $ hang (pprExpr expr <+> char '|') 4 (interpp'SP quals) where - ExprStmt expr _ = last stmts -- Last stmt should - quals = init stmts -- be an ExprStmt + ResultStmt expr _ = last stmts -- Last stmt should + quals = init stmts -- be an ResultStmt \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs deleted file mode 100644 index cb81b7c..0000000 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ /dev/null @@ -1,134 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides} - -The @Match@, @GRHSs@ and @GRHS@ datatypes. - -\begin{code} -module HsMatches where - -#include "HsVersions.h" - --- Friends -import HsExpr ( HsExpr, Stmt(..) ) -import HsBinds ( HsBinds(..), nullBinds ) -import HsTypes ( HsType ) --- Others -import Type ( Type ) -import SrcLoc ( SrcLoc ) -import Outputable -import List -\end{code} - -%************************************************************************ -%* * -\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} -%* * -%************************************************************************ - -@Match@es are sets of pattern bindings and right hand sides for -functions, patterns or case branches. For example, if a function @g@ -is defined as: -\begin{verbatim} -g (x,y) = y -g ((x:ys),y) = y+1, -\end{verbatim} -then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. - -It is always the case that each element of an @[Match]@ list has the -same number of @pats@s inside it. This corresponds to saying that -a function defined by pattern matching must have the same number of -patterns in each equation. - -\begin{code} -data Match id pat - = Match - [id] -- Tyvars wrt which this match is universally quantified - -- empty after typechecking - [pat] -- The patterns - (Maybe (HsType id)) -- A type signature for the result of the match - -- Nothing after typechecking - - (GRHSs id pat) - --- GRHSs are used both for pattern bindings and for Matches -data GRHSs id pat - = GRHSs [GRHS id pat] -- Guarded RHSs - (HsBinds id pat) -- The where clause - (Maybe Type) -- Just rhs_ty after type checking - -data GRHS id pat - = GRHS [Stmt id pat] -- The RHS is the final ExprStmt - -- I considered using a RetunStmt, but - -- it printed 'wrong' in error messages - SrcLoc - -mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat -mkSimpleMatch pats rhs maybe_rhs_ty locn - = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty) - -unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] -unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc] -\end{code} - -@getMatchLoc@ takes a @Match@ and returns the -source-location gotten from the GRHS inside. -THis is something of a nuisance, but no more. - -\begin{code} -getMatchLoc :: Match id pat -> SrcLoc -getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc -\end{code} - -%************************************************************************ -%* * -\subsection{Printing} -%* * -%************************************************************************ - -We know the list must have at least one @Match@ in it. -\begin{code} -pprMatches :: (Outputable id, Outputable pat) - => (Bool, SDoc) -> [Match id pat] -> SDoc -pprMatches print_info matches = vcat (map (pprMatch print_info) matches) - - -pprMatch :: (Outputable id, Outputable pat) - => (Bool, SDoc) -> Match id pat -> SDoc -pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss) - = maybe_name <+> sep [sep (map ppr pats), - ppr_maybe_ty, - nest 2 (pprGRHSs is_case grhss)] - where - maybe_name | is_case = empty - | otherwise = name - ppr_maybe_ty = case maybe_ty of - Just ty -> dcolon <+> ppr ty - Nothing -> empty - - -pprGRHSs :: (Outputable id, Outputable pat) - => Bool -> GRHSs id pat -> SDoc -pprGRHSs is_case (GRHSs grhss binds maybe_ty) - = vcat (map (pprGRHS is_case) grhss) - $$ - (if nullBinds binds then empty - else text "where" $$ nest 4 (pprDeeper (ppr binds))) - - -pprGRHS :: (Outputable id, Outputable pat) - => Bool -> GRHS id pat -> SDoc - -pprGRHS is_case (GRHS [ExprStmt expr _] locn) - = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) - -pprGRHS is_case (GRHS guarded locn) - = sep [char '|' <+> interpp'SP guards, - text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) - ] - where - ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards - guards = init guarded -\end{code} - diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 8894a00..fc7db9e 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.60 2001/05/07 14:38:15 simonmar Exp $ +$Id: Parser.y,v 1.61 2001/05/08 14:44:37 simonpj Exp $ Haskell grammar. @@ -777,7 +777,7 @@ list :: { RdrNameHsExpr } body qss = [ParStmt (map reverse qss)] } in returnP ( HsDo ListComp - (reverse (ExprStmt $1 $2 : body $3)) + (reverse (ResultStmt $1 $2 : body $3)) $2 ) } @@ -820,7 +820,7 @@ alt :: { RdrNameMatch } (GRHSs $4 $5 Nothing)) )} ralt :: { [RdrNameGRHS] } - : '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] } + : '->' srcloc exp { [GRHS [ResultStmt $3 $2] $2] } | gdpats { (reverse $1) } gdpats :: { [RdrNameGRHS] } @@ -828,27 +828,19 @@ gdpats :: { [RdrNameGRHS] } | gdpat { [$1] } gdpat :: { RdrNameGRHS } - : srcloc '|' quals '->' exp { GRHS (reverse (ExprStmt $5 $1:$3)) $1} + : srcloc '|' quals '->' exp { GRHS (reverse (ResultStmt $5 $1:$3)) $1} ----------------------------------------------------------------------------- -- Statement sequences stmtlist :: { [RdrNameStmt] } - : '{' stmts '}' { reverse $2 } - | layout_on_for_do stmts close { reverse $2 } - --- Stmt list should really end in an expression, but it's not --- convenient to enforce this here, so we throw out erroneous --- statement sequences in the renamer instead. + : '{' stmts '}' { $2 } + | layout_on_for_do stmts close { $2 } stmts :: { [RdrNameStmt] } - : ';' stmts1 { $2 } - | stmts1 { $1 } - -stmts1 :: { [RdrNameStmt] } - : stmts1 ';' stmt { $3 : $1 } - | stmts1 ';' { $1 } - | stmt { [$1] } + : ';' stmts { $2 } + | stmt ';' stmts { $1 : $3 } + | srcloc exp { [ResultStmt $2 $1] } -- for typing stmts at the GHCi prompt, where the input may consist of -- just comments. diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index eb92cd3..a019881 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -235,9 +235,9 @@ rnGRHS (GRHS guarded locn) -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [ExprStmt _ _] = True - is_standard_guard [ExprStmt _ _, ExprStmt _ _] = True - is_standard_guard other = False + is_standard_guard [ResultStmt _ _] = True + is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -378,8 +378,8 @@ rnExpr e@(HsDo do_or_lc stmts src_loc) rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> -- check the statement list ends in an expression case last stmts' of { - ExprStmt _ _ -> returnRn () ; - _ -> addErrRn (doStmtListErr e) + ResultStmt _ _ -> returnRn () ; + _ -> addErrRn (doStmtListErr e) } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) where @@ -591,6 +591,12 @@ rnStmt (ExprStmt expr src_loc) thing_inside thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `plusFV` fvs) +rnStmt (ResultStmt expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `plusFV` fvs) + rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> let new_binders = collectHsBinders binds' in @@ -860,9 +866,7 @@ mkAssertExpr = vname = mkSysLocalName uniq SLIT("v") expr = HsLam ignorePredMatch loc = nameSrcLoc vname - ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing - (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc] - EmptyBinds Nothing) + ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc in returnRn (expr, unitFV name) else diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 2422b42..9939a58 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -718,7 +718,7 @@ gen_Ix_binds tycon where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ExprStmt con_expr tycon_loc] + [ResultStmt con_expr tycon_loc] mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) @@ -907,7 +907,7 @@ gen_Read_binds get_fixity tycon | is_infix = let (h:t) = field_quals in (h:con_qual:t) | otherwise = con_qual:field_quals - stmts = quals ++ [ExprStmt result_expr tycon_loc] + stmts = quals ++ [ResultStmt result_expr tycon_loc] {- c.f. Figure 18 in Haskell 1.1 report. diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 21ca4be..755c68b 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -512,6 +512,11 @@ zonkStmts (ParStmtOut bndrstmtss : stmts) returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) where (bndrss, stmtss) = unzip bndrstmtss +zonkStmts (ResultStmt expr locn : stmts) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ResultStmt new_expr locn : new_stmts) + zonkStmts (ExprStmt expr locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 32fd91e..36aed1b 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -381,7 +381,9 @@ tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next loop ((bndrs,stmts) : pairs) = tcStmtsAndThen - combine_par ListComp (mkListTy, not_required) stmts + combine_par ListComp m_ty stmts + -- Notice we pass on m_ty; the result type is used only + -- to get escaping type variables for checkExistentialPat (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' -> loop pairs `thenTc` \ ((pairs', thing), lie) -> returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) -> @@ -389,12 +391,15 @@ tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next returnTc ( ((bndrs',stmts') : pairs', thing), lie) combine_par stmt (stmts, thing) = (stmt:stmts, thing) - not_required = panic "tcStmtsAndThen: elt_ty" - -- The simple-statment case -tcStmtsAndThen combine do_or_lc m_ty (stmt@(ExprStmt exp locn):stmts) do_next + -- ExprStmt +tcStmtsAndThen combine do_or_lc m_ty@(m, res_elt_ty) (stmt@(ExprStmt exp locn):stmts) do_next = tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( - tcExprStmt do_or_lc m_ty exp (null stmts) + if isDoExpr do_or_lc then + newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> + tcExpr exp (m any_ty) + else + tcExpr exp boolTy ) `thenTc` \ (exp', stmt_lie) -> tcStmtsAndThen combine do_or_lc m_ty stmts do_next `thenTc` \ (thing, stmts_lie) -> @@ -403,24 +408,20 @@ tcStmtsAndThen combine do_or_lc m_ty (stmt@(ExprStmt exp locn):stmts) do_next stmt_lie `plusLIE` stmts_lie) ------------------------------- - -- ExprStmt; see comments with HsExpr.HsStmt - -- for meaning of ExprStmt -tcExprStmt do_or_lc (m, res_elt_ty) exp is_last_stmt - = compute_expr_ty `thenNF_Tc` \ expr_ty -> - tcExpr exp expr_ty - where - compute_expr_ty - | is_last_stmt = if isDoExpr do_or_lc then - returnNF_Tc (m res_elt_ty) - else - returnNF_Tc res_elt_ty - - | otherwise = if isDoExpr do_or_lc then - newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> - returnNF_Tc (m any_ty) - else - returnNF_Tc boolTy + -- Result statements +tcStmtsAndThen combine do_or_lc m_ty@(m, res_elt_ty) (stmt@(ResultStmt exp locn):stmts) do_next + = tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( + if isDoExpr do_or_lc then + tcExpr exp (m res_elt_ty) + else + tcExpr exp res_elt_ty + ) `thenTc` \ (exp', stmt_lie) -> + + tcStmtsAndThen combine do_or_lc m_ty stmts do_next `thenTc` \ (thing, stmts_lie) -> + + returnTc (combine (ResultStmt exp' locn) thing, + stmt_lie `plusLIE` stmts_lie) + ------------------------------ glue_binds combine is_rec binds thing diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1108042..a68b51a 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -200,7 +200,7 @@ tc_stmts names stmts -- Look up the names right in the middle, -- where they will all be in scope mapNF_Tc tcLookupId names `thenNF_Tc` \ ids -> - returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE) + returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE) ) `thenTc` \ ((ids, tc_stmts), lie) -> -- Simplify the context right here, so that we fail