3d592b1c0c19a5df8d9793d929d38e197395ca73
[ghc.git] / compiler / deSugar / DsArrows.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Desugaring arrow commands
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module DsArrows ( dsProcExpr ) where
12
13 #include "HsVersions.h"
14
15 import Match
16 import DsUtils
17 import DsMonad
18
19 import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
20 import TcHsSyn
21 import qualified HsUtils
22
23 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
24 -- needs to see source types (newtypes etc), and sometimes not
25 -- So WATCH OUT; check each use of split*Ty functions.
26 -- Sigh. This is a pain.
27
28 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
29
30 import TcType
31 import TcEvidence
32 import CoreSyn
33 import CoreFVs
34 import CoreUtils
35 import MkCore
36 import DsBinds (dsHsWrapper)
37
38 import Name
39 import Var
40 import Id
41 import DataCon
42 import TysWiredIn
43 import BasicTypes
44 import PrelNames
45 import Outputable
46 import Bag
47 import VarSet
48 import SrcLoc
49 import ListSetOps( assocDefault )
50 import FastString
51 import Data.List
52
53 data DsCmdEnv = DsCmdEnv {
54 arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
55 }
56
57 mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
58 -- See Note [CmdSyntaxTable] in HsExpr
59 mkCmdEnv tc_meths
60 = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
61 ; return (meth_binds, DsCmdEnv {
62 arr_id = Var (find_meth prs arrAName),
63 compose_id = Var (find_meth prs composeAName),
64 first_id = Var (find_meth prs firstAName),
65 app_id = Var (find_meth prs appAName),
66 choice_id = Var (find_meth prs choiceAName),
67 loop_id = Var (find_meth prs loopAName)
68 }) }
69 where
70 mk_bind (std_name, expr)
71 = do { rhs <- dsExpr expr
72 ; id <- newSysLocalDs (exprType rhs)
73 ; return (NonRec id rhs, (std_name, id)) }
74
75 find_meth prs std_name
76 = assocDefault (mk_panic std_name) prs std_name
77 mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
78
79 -- arr :: forall b c. (b -> c) -> a b c
80 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
81 do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
82
83 -- (>>>) :: forall b c d. a b c -> a c d -> a b d
84 do_compose :: DsCmdEnv -> Type -> Type -> Type ->
85 CoreExpr -> CoreExpr -> CoreExpr
86 do_compose ids b_ty c_ty d_ty f g
87 = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
88
89 -- first :: forall b c d. a b c -> a (b,d) (c,d)
90 do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
91 do_first ids b_ty c_ty d_ty f
92 = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
93
94 -- app :: forall b c. a (a b c, b) c
95 do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
96 do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
97
98 -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
99 -- note the swapping of d and c
100 do_choice :: DsCmdEnv -> Type -> Type -> Type ->
101 CoreExpr -> CoreExpr -> CoreExpr
102 do_choice ids b_ty c_ty d_ty f g
103 = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
104
105 -- loop :: forall b d c. a (b,d) (c,d) -> a b c
106 -- note the swapping of d and c
107 do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
108 do_loop ids b_ty c_ty d_ty f
109 = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
110
111 -- premap :: forall b c d. (b -> c) -> a c d -> a b d
112 -- premap f g = arr f >>> g
113 do_premap :: DsCmdEnv -> Type -> Type -> Type ->
114 CoreExpr -> CoreExpr -> CoreExpr
115 do_premap ids b_ty c_ty d_ty f g
116 = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
117
118 mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
119 mkFailExpr ctxt ty
120 = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
121
122 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
123 mkFstExpr :: Type -> Type -> DsM CoreExpr
124 mkFstExpr a_ty b_ty = do
125 a_var <- newSysLocalDs a_ty
126 b_var <- newSysLocalDs b_ty
127 pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
128 return (Lam pair_var
129 (coreCasePair pair_var a_var b_var (Var a_var)))
130
131 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
132 mkSndExpr :: Type -> Type -> DsM CoreExpr
133 mkSndExpr a_ty b_ty = do
134 a_var <- newSysLocalDs a_ty
135 b_var <- newSysLocalDs b_ty
136 pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
137 return (Lam pair_var
138 (coreCasePair pair_var a_var b_var (Var b_var)))
139
140 {-
141 Build case analysis of a tuple. This cannot be done in the DsM monad,
142 because the list of variables is typically not yet defined.
143 -}
144
145 -- coreCaseTuple [u1..] v [x1..xn] body
146 -- = case v of v { (x1, .., xn) -> body }
147 -- But the matching may be nested if the tuple is very big
148
149 coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
150 coreCaseTuple uniqs scrut_var vars body
151 = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
152
153 coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
154 coreCasePair scrut_var var1 var2 body
155 = Case (Var scrut_var) scrut_var (exprType body)
156 [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
157
158 mkCorePairTy :: Type -> Type -> Type
159 mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
160
161 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
162 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
163
164 mkCoreUnitExpr :: CoreExpr
165 mkCoreUnitExpr = mkCoreTup []
166
167 {-
168 The input is divided into a local environment, which is a flat tuple
169 (unless it's too big), and a stack, which is a right-nested pair.
170 In general, the input has the form
171
172 ((x1,...,xn), (s1,...(sk,())...))
173
174 where xi are the environment values, and si the ones on the stack,
175 with s1 being the "top", the first one to be matched with a lambda.
176 -}
177
178 envStackType :: [Id] -> Type -> Type
179 envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
180
181 -- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
182 splitTypeAt :: Int -> Type -> ([Type], Type)
183 splitTypeAt n ty
184 | n == 0 = ([], ty)
185 | otherwise = case tcTyConAppArgs ty of
186 [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
187 _ -> pprPanic "splitTypeAt" (ppr ty)
188
189 ----------------------------------------------
190 -- buildEnvStack
191 --
192 -- ((x1,...,xn),stk)
193
194 buildEnvStack :: [Id] -> Id -> CoreExpr
195 buildEnvStack env_ids stack_id
196 = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
197
198 ----------------------------------------------
199 -- matchEnvStack
200 --
201 -- \ ((x1,...,xn),stk) -> body
202 -- =>
203 -- \ pair ->
204 -- case pair of (tup,stk) ->
205 -- case tup of (x1,...,xn) ->
206 -- body
207
208 matchEnvStack :: [Id] -- x1..xn
209 -> Id -- stk
210 -> CoreExpr -- e
211 -> DsM CoreExpr
212 matchEnvStack env_ids stack_id body = do
213 uniqs <- newUniqueSupply
214 tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
215 let match_env = coreCaseTuple uniqs tup_var env_ids body
216 pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
217 return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
218
219 ----------------------------------------------
220 -- matchEnv
221 --
222 -- \ (x1,...,xn) -> body
223 -- =>
224 -- \ tup ->
225 -- case tup of (x1,...,xn) ->
226 -- body
227
228 matchEnv :: [Id] -- x1..xn
229 -> CoreExpr -- e
230 -> DsM CoreExpr
231 matchEnv env_ids body = do
232 uniqs <- newUniqueSupply
233 tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
234 return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
235
236 ----------------------------------------------
237 -- matchVarStack
238 --
239 -- case (x1, ...(xn, s)...) -> e
240 -- =>
241 -- case z0 of (x1,z1) ->
242 -- case zn-1 of (xn,s) ->
243 -- e
244 matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
245 matchVarStack [] stack_id body = return (stack_id, body)
246 matchVarStack (param_id:param_ids) stack_id body = do
247 (tail_id, tail_code) <- matchVarStack param_ids stack_id body
248 pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
249 return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
250
251 mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id
252 mkHsEnvStackExpr env_ids stack_id
253 = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
254
255 -- Translation of arrow abstraction
256
257 -- D; xs |-a c : () --> t' ---> c'
258 -- --------------------------
259 -- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'
260 --
261 -- where (xs) is the tuple of variables bound by p
262
263 dsProcExpr
264 :: LPat Id
265 -> LHsCmdTop Id
266 -> DsM CoreExpr
267 dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
268 (meth_binds, meth_ids) <- mkCmdEnv ids
269 let locals = mkVarSet (collectPatBinders pat)
270 (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
271 let env_ty = mkBigCoreVarTupTy env_ids
272 let env_stk_ty = mkCorePairTy env_ty unitTy
273 let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
274 fail_expr <- mkFailExpr ProcExpr env_stk_ty
275 var <- selectSimpleMatchVarL pat
276 match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
277 let pat_ty = hsLPatType pat
278 proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
279 (Lam var match_code)
280 core_cmd
281 return (mkLets meth_binds proc_code)
282
283 {-
284 Translation of a command judgement of the form
285
286 D; xs |-a c : stk --> t
287
288 to an expression e such that
289
290 D |- e :: a (xs, stk) t
291 -}
292
293 dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
294 -> DsM (CoreExpr, IdSet)
295 dsLCmd ids local_vars stk_ty res_ty cmd env_ids
296 = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
297
298 dsCmd :: DsCmdEnv -- arrow combinators
299 -> IdSet -- set of local vars available to this command
300 -> Type -- type of the stack (right-nested tuple)
301 -> Type -- return type of the command
302 -> HsCmd Id -- command to desugar
303 -> [Id] -- list of vars in the input to this command
304 -- This is typically fed back,
305 -- so don't pull on it too early
306 -> DsM (CoreExpr, -- desugared expression
307 IdSet) -- subset of local vars that occur free
308
309 -- D |- fun :: a t1 t2
310 -- D, xs |- arg :: t1
311 -- -----------------------------
312 -- D; xs |-a fun -< arg : stk --> t2
313 --
314 -- ---> premap (\ ((xs), _stk) -> arg) fun
315
316 dsCmd ids local_vars stack_ty res_ty
317 (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
318 env_ids = do
319 let
320 (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
321 (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
322 core_arrow <- dsLExpr arrow
323 core_arg <- dsLExpr arg
324 stack_id <- newSysLocalDs stack_ty
325 core_make_arg <- matchEnvStack env_ids stack_id core_arg
326 return (do_premap ids
327 (envStackType env_ids stack_ty)
328 arg_ty
329 res_ty
330 core_make_arg
331 core_arrow,
332 exprFreeIds core_arg `intersectVarSet` local_vars)
333
334 -- D, xs |- fun :: a t1 t2
335 -- D, xs |- arg :: t1
336 -- ------------------------------
337 -- D; xs |-a fun -<< arg : stk --> t2
338 --
339 -- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
340
341 dsCmd ids local_vars stack_ty res_ty
342 (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
343 env_ids = do
344 let
345 (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
346 (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
347
348 core_arrow <- dsLExpr arrow
349 core_arg <- dsLExpr arg
350 stack_id <- newSysLocalDs stack_ty
351 core_make_pair <- matchEnvStack env_ids stack_id
352 (mkCorePairExpr core_arrow core_arg)
353
354 return (do_premap ids
355 (envStackType env_ids stack_ty)
356 (mkCorePairTy arrow_ty arg_ty)
357 res_ty
358 core_make_pair
359 (do_app ids arg_ty res_ty),
360 (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)
361 `intersectVarSet` local_vars)
362
363 -- D; ys |-a cmd : (t,stk) --> t'
364 -- D, xs |- exp :: t
365 -- ------------------------
366 -- D; xs |-a cmd exp : stk --> t'
367 --
368 -- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
369
370 dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
371 core_arg <- dsLExpr arg
372 let
373 arg_ty = exprType core_arg
374 stack_ty' = mkCorePairTy arg_ty stack_ty
375 (core_cmd, free_vars, env_ids')
376 <- dsfixCmd ids local_vars stack_ty' res_ty cmd
377 stack_id <- newSysLocalDs stack_ty
378 arg_id <- newSysLocalDs arg_ty
379 -- push the argument expression onto the stack
380 let
381 stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
382 core_body = bindNonRec arg_id core_arg
383 (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
384
385 -- match the environment and stack against the input
386 core_map <- matchEnvStack env_ids stack_id core_body
387 return (do_premap ids
388 (envStackType env_ids stack_ty)
389 (envStackType env_ids' stack_ty')
390 res_ty
391 core_map
392 core_cmd,
393 free_vars `unionVarSet`
394 (exprFreeIds core_arg `intersectVarSet` local_vars))
395
396 -- D; ys |-a cmd : stk t'
397 -- -----------------------------------------------
398 -- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
399 --
400 -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
401
402 dsCmd ids local_vars stack_ty res_ty
403 (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _
404 (GRHSs [L _ (GRHS [] body)] _ ))] }))
405 env_ids = do
406 let
407 pat_vars = mkVarSet (collectPatsBinders pats)
408 local_vars' = pat_vars `unionVarSet` local_vars
409 (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
410 (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body
411 param_ids <- mapM newSysLocalDs pat_tys
412 stack_id' <- newSysLocalDs stack_ty'
413
414 -- the expression is built from the inside out, so the actions
415 -- are presented in reverse order
416
417 let
418 -- build a new environment, plus what's left of the stack
419 core_expr = buildEnvStack env_ids' stack_id'
420 in_ty = envStackType env_ids stack_ty
421 in_ty' = envStackType env_ids' stack_ty'
422
423 fail_expr <- mkFailExpr LambdaExpr in_ty'
424 -- match the patterns against the parameters
425 match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr
426 -- match the parameters against the top of the old stack
427 (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
428 -- match the old environment and stack against the input
429 select_code <- matchEnvStack env_ids stack_id param_code
430 return (do_premap ids in_ty in_ty' res_ty select_code core_body,
431 free_vars `minusVarSet` pat_vars)
432
433 dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
434 = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
435
436 -- D, xs |- e :: Bool
437 -- D; xs1 |-a c1 : stk --> t
438 -- D; xs2 |-a c2 : stk --> t
439 -- ----------------------------------------
440 -- D; xs |-a if e then c1 else c2 : stk --> t
441 --
442 -- ---> premap (\ ((xs),stk) ->
443 -- if e then Left ((xs1),stk) else Right ((xs2),stk))
444 -- (c1 ||| c2)
445
446 dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
447 env_ids = do
448 core_cond <- dsLExpr cond
449 (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
450 (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
451 stack_id <- newSysLocalDs stack_ty
452 either_con <- dsLookupTyCon eitherTyConName
453 left_con <- dsLookupDataCon leftDataConName
454 right_con <- dsLookupDataCon rightDataConName
455
456 let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e]
457 mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e]
458
459 in_ty = envStackType env_ids stack_ty
460 then_ty = envStackType then_ids stack_ty
461 else_ty = envStackType else_ids stack_ty
462 sum_ty = mkTyConApp either_con [then_ty, else_ty]
463 fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars
464
465 core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id)
466 core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
467
468 core_if <- case mb_fun of
469 Just fun -> do { core_fun <- dsExpr fun
470 ; matchEnvStack env_ids stack_id $
471 mkCoreApps core_fun [core_cond, core_left, core_right] }
472 Nothing -> matchEnvStack env_ids stack_id $
473 mkIfThenElse core_cond core_left core_right
474
475 return (do_premap ids in_ty sum_ty res_ty
476 core_if
477 (do_choice ids then_ty else_ty res_ty core_then core_else),
478 fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
479
480 {-
481 Case commands are treated in much the same way as if commands
482 (see above) except that there are more alternatives. For example
483
484 case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
485
486 is translated to
487
488 premap (\ ((xs)*ts) -> case e of
489 p1 -> (Left (Left (xs1)*ts))
490 p2 -> Left ((Right (xs2)*ts))
491 p3 -> Right ((xs3)*ts))
492 ((c1 ||| c2) ||| c3)
493
494 The idea is to extract the commands from the case, build a balanced tree
495 of choices, and replace the commands with expressions that build tagged
496 tuples, obtaining a case expression that can be desugared normally.
497 To build all this, we use triples describing segments of the list of
498 case bodies, containing the following fields:
499 * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
500 into the case replacing the commands
501 * a sum type that is the common type of these expressions, and also the
502 input type of the arrow
503 * a CoreExpr for an arrow built by combining the translated command
504 bodies with |||.
505 -}
506
507 dsCmd ids local_vars stack_ty res_ty
508 (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
509 , mg_origin = origin }))
510 env_ids = do
511 stack_id <- newSysLocalDs stack_ty
512
513 -- Extract and desugar the leaf commands in the case, building tuple
514 -- expressions that will (after tagging) replace these leaves
515
516 let
517 leaves = concatMap leavesMatch matches
518 make_branch (leaf, bound_vars) = do
519 (core_leaf, _fvs, leaf_ids) <-
520 dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf
521 return ([mkHsEnvStackExpr leaf_ids stack_id],
522 envStackType leaf_ids stack_ty,
523 core_leaf)
524
525 branches <- mapM make_branch leaves
526 either_con <- dsLookupTyCon eitherTyConName
527 left_con <- dsLookupDataCon leftDataConName
528 right_con <- dsLookupDataCon rightDataConName
529 let
530 left_id = HsVar (noLoc (dataConWrapId left_con))
531 right_id = HsVar (noLoc (dataConWrapId right_con))
532 left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
533 right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
534
535 -- Prefix each tuple with a distinct series of Left's and Right's,
536 -- in a balanced way, keeping track of the types.
537
538 merge_branches (builds1, in_ty1, core_exp1)
539 (builds2, in_ty2, core_exp2)
540 = (map (left_expr in_ty1 in_ty2) builds1 ++
541 map (right_expr in_ty1 in_ty2) builds2,
542 mkTyConApp either_con [in_ty1, in_ty2],
543 do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
544 (leaves', sum_ty, core_choices) = foldb merge_branches branches
545
546 -- Replace the commands in the case with these tagged tuples,
547 -- yielding a HsExpr Id we can feed to dsExpr.
548
549 (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
550 in_ty = envStackType env_ids stack_ty
551
552 core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
553 , mg_arg_tys = arg_tys
554 , mg_res_ty = sum_ty, mg_origin = origin }))
555 -- Note that we replace the HsCase result type by sum_ty,
556 -- which is the type of matches'
557
558 core_matches <- matchEnvStack env_ids stack_id core_body
559 return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
560 exprFreeIds core_body `intersectVarSet` local_vars)
561
562 -- D; ys |-a cmd : stk --> t
563 -- ----------------------------------
564 -- D; xs |-a let binds in cmd : stk --> t
565 --
566 -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
567
568 dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
569 let
570 defined_vars = mkVarSet (collectLocalBinders binds)
571 local_vars' = defined_vars `unionVarSet` local_vars
572
573 (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
574 stack_id <- newSysLocalDs stack_ty
575 -- build a new environment, plus the stack, using the let bindings
576 core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id)
577 -- match the old environment and stack against the input
578 core_map <- matchEnvStack env_ids stack_id core_binds
579 return (do_premap ids
580 (envStackType env_ids stack_ty)
581 (envStackType env_ids' stack_ty)
582 res_ty
583 core_map
584 core_body,
585 exprFreeIds core_binds `intersectVarSet` local_vars)
586
587 -- D; xs |-a ss : t
588 -- ----------------------------------
589 -- D; xs |-a do { ss } : () --> t
590 --
591 -- ---> premap (\ (env,stk) -> env) c
592
593 dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do
594 (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
595 let env_ty = mkBigCoreVarTupTy env_ids
596 core_fst <- mkFstExpr env_ty stack_ty
597 return (do_premap ids
598 (mkCorePairTy env_ty stack_ty)
599 env_ty
600 res_ty
601 core_fst
602 core_stmts,
603 env_ids')
604
605 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
606 -- D; xs |-a ci :: stki --> ti
607 -- -----------------------------------
608 -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
609
610 dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
611 let env_ty = mkBigCoreVarTupTy env_ids
612 core_op <- dsLExpr op
613 (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
614 return (mkApps (App core_op (Type env_ty)) core_args,
615 unionVarSets fv_sets)
616
617 dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
618 (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
619 wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd
620 return (wrapped_cmd, env_ids')
621
622 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
623
624 -- D; ys |-a c : stk --> t (ys <= xs)
625 -- ---------------------
626 -- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
627
628 dsTrimCmdArg
629 :: IdSet -- set of local vars available to this command
630 -> [Id] -- list of vars in the input to this command
631 -> LHsCmdTop Id -- command argument to desugar
632 -> DsM (CoreExpr, -- desugared expression
633 IdSet) -- subset of local vars that occur free
634 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
635 (meth_binds, meth_ids) <- mkCmdEnv ids
636 (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
637 stack_id <- newSysLocalDs stack_ty
638 trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
639 let
640 in_ty = envStackType env_ids stack_ty
641 in_ty' = envStackType env_ids' stack_ty
642 arg_code = if env_ids' == env_ids then core_cmd else
643 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
644 return (mkLets meth_binds arg_code, free_vars)
645
646 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
647 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
648
649 dsfixCmd
650 :: DsCmdEnv -- arrow combinators
651 -> IdSet -- set of local vars available to this command
652 -> Type -- type of the stack (right-nested tuple)
653 -> Type -- return type of the command
654 -> LHsCmd Id -- command to desugar
655 -> DsM (CoreExpr, -- desugared expression
656 IdSet, -- subset of local vars that occur free
657 [Id]) -- the same local vars as a list, fed back
658 dsfixCmd ids local_vars stk_ty cmd_ty cmd
659 = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
660
661 -- Feed back the list of local variables actually used a command,
662 -- for use as the input tuple of the generated arrow.
663
664 trimInput
665 :: ([Id] -> DsM (CoreExpr, IdSet))
666 -> DsM (CoreExpr, -- desugared expression
667 IdSet, -- subset of local vars that occur free
668 [Id]) -- same local vars as a list, fed back to
669 -- the inner function to form the tuple of
670 -- inputs to the arrow.
671 trimInput build_arrow
672 = fixDs (\ ~(_,_,env_ids) -> do
673 (core_cmd, free_vars) <- build_arrow env_ids
674 return (core_cmd, free_vars, varSetElems free_vars))
675
676 {-
677 Translation of command judgements of the form
678
679 D |-a do { ss } : t
680 -}
681
682 dsCmdDo :: DsCmdEnv -- arrow combinators
683 -> IdSet -- set of local vars available to this statement
684 -> Type -- return type of the statement
685 -> [CmdLStmt Id] -- statements to desugar
686 -> [Id] -- list of vars in the input to this statement
687 -- This is typically fed back,
688 -- so don't pull on it too early
689 -> DsM (CoreExpr, -- desugared expression
690 IdSet) -- subset of local vars that occur free
691
692 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
693
694 -- D; xs |-a c : () --> t
695 -- --------------------------
696 -- D; xs |-a do { c } : t
697 --
698 -- ---> premap (\ (xs) -> ((xs), ())) c
699
700 dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do
701 (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
702 let env_ty = mkBigCoreVarTupTy env_ids
703 env_var <- newSysLocalDs env_ty
704 let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
705 return (do_premap ids
706 env_ty
707 (mkCorePairTy env_ty unitTy)
708 res_ty
709 core_map
710 core_body,
711 env_ids')
712
713 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
714 let
715 bound_vars = mkVarSet (collectLStmtBinders stmt)
716 local_vars' = bound_vars `unionVarSet` local_vars
717 (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
718 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
719 return (do_compose ids
720 (mkBigCoreVarTupTy env_ids)
721 (mkBigCoreVarTupTy env_ids')
722 res_ty
723 core_stmt
724 core_stmts,
725 fv_stmt)
726
727 {-
728 A statement maps one local environment to another, and is represented
729 as an arrow from one tuple type to another. A statement sequence is
730 translated to a composition of such arrows.
731 -}
732
733 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]
734 -> DsM (CoreExpr, IdSet)
735 dsCmdLStmt ids local_vars out_ids cmd env_ids
736 = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
737
738 dsCmdStmt
739 :: DsCmdEnv -- arrow combinators
740 -> IdSet -- set of local vars available to this statement
741 -> [Id] -- list of vars in the output of this statement
742 -> CmdStmt Id -- statement to desugar
743 -> [Id] -- list of vars in the input to this statement
744 -- This is typically fed back,
745 -- so don't pull on it too early
746 -> DsM (CoreExpr, -- desugared expression
747 IdSet) -- subset of local vars that occur free
748
749 -- D; xs1 |-a c : () --> t
750 -- D; xs' |-a do { ss } : t'
751 -- ------------------------------
752 -- D; xs |-a do { c; ss } : t'
753 --
754 -- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
755 -- (first c >>> arr snd) >>> ss
756
757 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
758 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
759 core_mux <- matchEnv env_ids
760 (mkCorePairExpr
761 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
762 (mkBigCoreVarTup out_ids))
763 let
764 in_ty = mkBigCoreVarTupTy env_ids
765 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
766 out_ty = mkBigCoreVarTupTy out_ids
767 before_c_ty = mkCorePairTy in_ty1 out_ty
768 after_c_ty = mkCorePairTy c_ty out_ty
769 snd_fn <- mkSndExpr c_ty out_ty
770 return (do_premap ids in_ty before_c_ty out_ty core_mux $
771 do_compose ids before_c_ty after_c_ty out_ty
772 (do_first ids in_ty1 c_ty out_ty core_cmd) $
773 do_arr ids after_c_ty out_ty snd_fn,
774 extendVarSetList fv_cmd out_ids)
775
776 -- D; xs1 |-a c : () --> t
777 -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
778 -- -----------------------------------
779 -- D; xs |-a do { p <- c; ss } : t'
780 --
781 -- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
782 -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
783 --
784 -- It would be simpler and more consistent to do this using second,
785 -- but that's likely to be defined in terms of first.
786
787 dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
788 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd
789 let
790 pat_ty = hsLPatType pat
791 pat_vars = mkVarSet (collectPatBinders pat)
792 env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
793 env_ty2 = mkBigCoreVarTupTy env_ids2
794
795 -- multiplexing function
796 -- \ (xs) -> (((xs1),()),(xs2))
797
798 core_mux <- matchEnv env_ids
799 (mkCorePairExpr
800 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
801 (mkBigCoreVarTup env_ids2))
802
803 -- projection function
804 -- \ (p, (xs2)) -> (zs)
805
806 env_id <- newSysLocalDs env_ty2
807 uniqs <- newUniqueSupply
808 let
809 after_c_ty = mkCorePairTy pat_ty env_ty2
810 out_ty = mkBigCoreVarTupTy out_ids
811 body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
812
813 fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
814 pat_id <- selectSimpleMatchVarL pat
815 match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
816 pair_id <- newSysLocalDs after_c_ty
817 let
818 proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
819
820 -- put it all together
821 let
822 in_ty = mkBigCoreVarTupTy env_ids
823 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
824 in_ty2 = mkBigCoreVarTupTy env_ids2
825 before_c_ty = mkCorePairTy in_ty1 in_ty2
826 return (do_premap ids in_ty before_c_ty out_ty core_mux $
827 do_compose ids before_c_ty after_c_ty out_ty
828 (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
829 do_arr ids after_c_ty out_ty proj_expr,
830 fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
831
832 -- D; xs' |-a do { ss } : t
833 -- --------------------------------------
834 -- D; xs |-a do { let binds; ss } : t
835 --
836 -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
837
838 dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do
839 -- build a new environment using the let bindings
840 core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
841 -- match the old environment against the input
842 core_map <- matchEnv env_ids core_binds
843 return (do_arr ids
844 (mkBigCoreVarTupTy env_ids)
845 (mkBigCoreVarTupTy out_ids)
846 core_map,
847 exprFreeIds core_binds `intersectVarSet` local_vars)
848
849 -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
850 -- D; xs' |-a do { ss' } : t
851 -- ------------------------------------
852 -- D; xs |-a do { rec ss; ss' } : t
853 --
854 -- xs1 = xs' /\ defs(ss)
855 -- xs2 = xs' - defs(ss)
856 -- ys1 = ys - defs(ss)
857 -- ys2 = ys /\ defs(ss)
858 --
859 -- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
860 -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
861 -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
862
863 dsCmdStmt ids local_vars out_ids
864 (RecStmt { recS_stmts = stmts
865 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
866 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
867 env_ids = do
868 let
869 env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
870 env2_ids = varSetElems env2_id_set
871 env2_ty = mkBigCoreVarTupTy env2_ids
872
873 -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
874
875 uniqs <- newUniqueSupply
876 env2_id <- newSysLocalDs env2_ty
877 let
878 later_ty = mkBigCoreVarTupTy later_ids
879 post_pair_ty = mkCorePairTy later_ty env2_ty
880 post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
881
882 post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
883
884 --- loop (...)
885
886 (core_loop, env1_id_set, env1_ids)
887 <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
888
889 -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
890
891 let
892 env1_ty = mkBigCoreVarTupTy env1_ids
893 pre_pair_ty = mkCorePairTy env1_ty env2_ty
894 pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
895 (mkBigCoreVarTup env2_ids)
896
897 pre_loop_fn <- matchEnv env_ids pre_loop_body
898
899 -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
900
901 let
902 env_ty = mkBigCoreVarTupTy env_ids
903 out_ty = mkBigCoreVarTupTy out_ids
904 core_body = do_premap ids env_ty pre_pair_ty out_ty
905 pre_loop_fn
906 (do_compose ids pre_pair_ty post_pair_ty out_ty
907 (do_first ids env1_ty later_ty env2_ty
908 core_loop)
909 (do_arr ids post_pair_ty out_ty
910 post_loop_fn))
911
912 return (core_body, env1_id_set `unionVarSet` env2_id_set)
913
914 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
915
916 -- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
917 -- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
918
919 dsRecCmd
920 :: DsCmdEnv -- arrow combinators
921 -> IdSet -- set of local vars available to this statement
922 -> [CmdLStmt Id] -- list of statements inside the RecCmd
923 -> [Id] -- list of vars defined here and used later
924 -> [HsExpr Id] -- expressions corresponding to later_ids
925 -> [Id] -- list of vars fed back through the loop
926 -> [HsExpr Id] -- expressions corresponding to rec_ids
927 -> DsM (CoreExpr, -- desugared statement
928 IdSet, -- subset of local vars that occur free
929 [Id]) -- same local vars as a list
930
931 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
932 let
933 later_id_set = mkVarSet later_ids
934 rec_id_set = mkVarSet rec_ids
935 local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
936
937 -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
938
939 core_later_rets <- mapM dsExpr later_rets
940 core_rec_rets <- mapM dsExpr rec_rets
941 let
942 -- possibly polymorphic version of vars of later_ids and rec_ids
943 out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
944 out_ty = mkBigCoreVarTupTy out_ids
945
946 later_tuple = mkBigCoreTup core_later_rets
947 later_ty = mkBigCoreVarTupTy later_ids
948
949 rec_tuple = mkBigCoreTup core_rec_rets
950 rec_ty = mkBigCoreVarTupTy rec_ids
951
952 out_pair = mkCorePairExpr later_tuple rec_tuple
953 out_pair_ty = mkCorePairTy later_ty rec_ty
954
955 mk_pair_fn <- matchEnv out_ids out_pair
956
957 -- ss
958
959 (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
960
961 -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
962
963 rec_id <- newSysLocalDs rec_ty
964 let
965 env1_id_set = fv_stmts `minusVarSet` rec_id_set
966 env1_ids = varSetElems env1_id_set
967 env1_ty = mkBigCoreVarTupTy env1_ids
968 in_pair_ty = mkCorePairTy env1_ty rec_ty
969 core_body = mkBigCoreTup (map selectVar env_ids)
970 where
971 selectVar v
972 | v `elemVarSet` rec_id_set
973 = mkTupleSelector rec_ids v rec_id (Var rec_id)
974 | otherwise = Var v
975
976 squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
977
978 -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
979
980 let
981 env_ty = mkBigCoreVarTupTy env_ids
982 core_loop = do_loop ids env1_ty later_ty rec_ty
983 (do_premap ids in_pair_ty env_ty out_pair_ty
984 squash_pair_fn
985 (do_compose ids env_ty out_ty out_pair_ty
986 core_stmts
987 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
988
989 return (core_loop, env1_id_set, env1_ids)
990
991 {-
992 A sequence of statements (as in a rec) is desugared to an arrow between
993 two environments (no stack)
994 -}
995
996 dsfixCmdStmts
997 :: DsCmdEnv -- arrow combinators
998 -> IdSet -- set of local vars available to this statement
999 -> [Id] -- output vars of these statements
1000 -> [CmdLStmt Id] -- statements to desugar
1001 -> DsM (CoreExpr, -- desugared expression
1002 IdSet, -- subset of local vars that occur free
1003 [Id]) -- same local vars as a list
1004
1005 dsfixCmdStmts ids local_vars out_ids stmts
1006 = trimInput (dsCmdStmts ids local_vars out_ids stmts)
1007
1008 dsCmdStmts
1009 :: DsCmdEnv -- arrow combinators
1010 -> IdSet -- set of local vars available to this statement
1011 -> [Id] -- output vars of these statements
1012 -> [CmdLStmt Id] -- statements to desugar
1013 -> [Id] -- list of vars in the input to these statements
1014 -> DsM (CoreExpr, -- desugared expression
1015 IdSet) -- subset of local vars that occur free
1016
1017 dsCmdStmts ids local_vars out_ids [stmt] env_ids
1018 = dsCmdLStmt ids local_vars out_ids stmt env_ids
1019
1020 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
1021 let
1022 bound_vars = mkVarSet (collectLStmtBinders stmt)
1023 local_vars' = bound_vars `unionVarSet` local_vars
1024 (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
1025 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
1026 return (do_compose ids
1027 (mkBigCoreVarTupTy env_ids)
1028 (mkBigCoreVarTupTy env_ids')
1029 (mkBigCoreVarTupTy out_ids)
1030 core_stmt
1031 core_stmts,
1032 fv_stmt)
1033
1034 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
1035
1036 -- Match a list of expressions against a list of patterns, left-to-right.
1037
1038 matchSimplys :: [CoreExpr] -- Scrutinees
1039 -> HsMatchContext Name -- Match kind
1040 -> [LPat Id] -- Patterns they should match
1041 -> CoreExpr -- Return this if they all match
1042 -> CoreExpr -- Return this if they don't
1043 -> DsM CoreExpr
1044 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
1045 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
1046 match_code <- matchSimplys exps ctxt pats result_expr fail_expr
1047 matchSimply exp ctxt pat match_code fail_expr
1048 matchSimplys _ _ _ _ _ = panic "matchSimplys"
1049
1050 -- List of leaf expressions, with set of variables bound in each
1051
1052 leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
1053 leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
1054 = let
1055 defined_vars = mkVarSet (collectPatsBinders pats)
1056 `unionVarSet`
1057 mkVarSet (collectLocalBinders binds)
1058 in
1059 [(body,
1060 mkVarSet (collectLStmtsBinders stmts)
1061 `unionVarSet` defined_vars)
1062 | L _ (GRHS stmts body) <- grhss]
1063
1064 -- Replace the leaf commands in a match
1065
1066 replaceLeavesMatch
1067 :: Type -- new result type
1068 -> [Located (body' Id)] -- replacement leaf expressions of that type
1069 -> LMatch Id (Located (body Id)) -- the matches of a case command
1070 -> ([Located (body' Id)], -- remaining leaf expressions
1071 LMatch Id (Located (body' Id))) -- updated match
1072 replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
1073 = let
1074 (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1075 in
1076 (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
1077
1078 replaceLeavesGRHS
1079 :: [Located (body' Id)] -- replacement leaf expressions of that type
1080 -> LGRHS Id (Located (body Id)) -- rhss of a case command
1081 -> ([Located (body' Id)], -- remaining leaf expressions
1082 LGRHS Id (Located (body' Id))) -- updated GRHS
1083 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
1084 = (leaves, L loc (GRHS stmts leaf))
1085 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
1086
1087 -- Balanced fold of a non-empty list.
1088
1089 foldb :: (a -> a -> a) -> [a] -> a
1090 foldb _ [] = error "foldb of empty list"
1091 foldb _ [x] = x
1092 foldb f xs = foldb f (fold_pairs xs)
1093 where
1094 fold_pairs [] = []
1095 fold_pairs [x] = [x]
1096 fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1097
1098 {-
1099 Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
1100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1101 The following functions to collect value variables from patterns are
1102 copied from HsUtils, with one change: we also collect the dictionary
1103 bindings (pat_binds) from ConPatOut. We need them for cases like
1104
1105 h :: Arrow a => Int -> a (Int,Int) Int
1106 h x = proc (y,z) -> case compare x y of
1107 GT -> returnA -< z+x
1108
1109 The type checker turns the case into
1110
1111 case compare x y of
1112 GT { p77 = plusInt } -> returnA -< p77 z x
1113
1114 Here p77 is a local binding for the (+) operation.
1115
1116 See comments in HsUtils for why the other version does not include
1117 these bindings.
1118 -}
1119
1120 collectPatBinders :: LPat Id -> [Id]
1121 collectPatBinders pat = collectl pat []
1122
1123 collectPatsBinders :: [LPat Id] -> [Id]
1124 collectPatsBinders pats = foldr collectl [] pats
1125
1126 ---------------------
1127 collectl :: LPat Id -> [Id] -> [Id]
1128 -- See Note [Dictionary binders in ConPatOut]
1129 collectl (L _ pat) bndrs
1130 = go pat
1131 where
1132 go (VarPat (L _ var)) = var : bndrs
1133 go (WildPat _) = bndrs
1134 go (LazyPat pat) = collectl pat bndrs
1135 go (BangPat pat) = collectl pat bndrs
1136 go (AsPat (L _ a) pat) = a : collectl pat bndrs
1137 go (ParPat pat) = collectl pat bndrs
1138
1139 go (ListPat pats _ _) = foldr collectl bndrs pats
1140 go (PArrPat pats _) = foldr collectl bndrs pats
1141 go (TuplePat pats _ _) = foldr collectl bndrs pats
1142
1143 go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
1144 go (ConPatOut {pat_args=ps, pat_binds=ds}) =
1145 collectEvBinders ds
1146 ++ foldr collectl bndrs (hsConPatArgs ps)
1147 go (LitPat _) = bndrs
1148 go (NPat _ _ _) = bndrs
1149 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
1150
1151 go (SigPatIn pat _) = collectl pat bndrs
1152 go (SigPatOut pat _) = collectl pat bndrs
1153 go (CoPat _ pat _) = collectl (noLoc pat) bndrs
1154 go (ViewPat _ pat _) = collectl pat bndrs
1155 go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
1156
1157 collectEvBinders :: TcEvBinds -> [Id]
1158 collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
1159 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1160
1161 add_ev_bndr :: EvBind -> [Id] -> [Id]
1162 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1163 | otherwise = bs
1164 -- A worry: what about coercion variable binders??
1165
1166 collectLStmtsBinders :: [LStmt Id body] -> [Id]
1167 collectLStmtsBinders = concatMap collectLStmtBinders
1168
1169 collectLStmtBinders :: LStmt Id body -> [Id]
1170 collectLStmtBinders = collectStmtBinders . unLoc
1171
1172 collectStmtBinders :: Stmt Id body -> [Id]
1173 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
1174 collectStmtBinders stmt = HsUtils.collectStmtBinders stmt