Commit 7c72bad5 authored by simonpj's avatar simonpj
Browse files

[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.
parent 76573a24
......@@ -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])
......
......@@ -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
......
......@@ -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])
......
......@@ -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}
%************************************************************************
......
%
% (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}
{-
-----------------------------------------------------------------------------
$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.
......
......@@ -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
......
......@@ -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.
......
......@@ -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 ->
......
......@@ -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 (