--
-- 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])
-- 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
import BasicTypes ( Boxity(..) )
import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) )
-import TcHsSyn ( TypecheckedStmt )
+import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr )
import DsHsSyn ( outPatType )
import CoreSyn
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''
[ 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
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)
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
\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}
-> 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])
(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
= 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
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}
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
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))
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}
%************************************************************************
+++ /dev/null
-%
-% (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.
body qss = [ParStmt (map reverse qss)] }
in
returnP ( HsDo ListComp
- (reverse (ExprStmt $1 $2 : body $3))
+ (reverse (ResultStmt $1 $2 : body $3))
$2
)
}
(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] }
| 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.
-- 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}
%************************************************************************
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
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
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
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)
| 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.
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 ->
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) ->
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) ->
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
-- 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
projects / ghc-hetmet.git / commitdiff