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