Refactor lookupFixityRn-related code following D1744
[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 let 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 pat_vars = mkVarSet (collectPatsBinders pats)
407 let
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 (HsCmdWrap wrap cmd) env_ids = do
618 (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
619 wrapped_cmd <- dsHsWrapper wrap 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 bound_vars = mkVarSet (collectLStmtBinders stmt)
715 let local_vars' = bound_vars `unionVarSet` local_vars
716 (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
717 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
718 return (do_compose ids
719 (mkBigCoreVarTupTy env_ids)
720 (mkBigCoreVarTupTy env_ids')
721 res_ty
722 core_stmt
723 core_stmts,
724 fv_stmt)
725
726 {-
727 A statement maps one local environment to another, and is represented
728 as an arrow from one tuple type to another. A statement sequence is
729 translated to a composition of such arrows.
730 -}
731
732 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]
733 -> DsM (CoreExpr, IdSet)
734 dsCmdLStmt ids local_vars out_ids cmd env_ids
735 = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
736
737 dsCmdStmt
738 :: DsCmdEnv -- arrow combinators
739 -> IdSet -- set of local vars available to this statement
740 -> [Id] -- list of vars in the output of this statement
741 -> CmdStmt Id -- statement to desugar
742 -> [Id] -- list of vars in the input to this statement
743 -- This is typically fed back,
744 -- so don't pull on it too early
745 -> DsM (CoreExpr, -- desugared expression
746 IdSet) -- subset of local vars that occur free
747
748 -- D; xs1 |-a c : () --> t
749 -- D; xs' |-a do { ss } : t'
750 -- ------------------------------
751 -- D; xs |-a do { c; ss } : t'
752 --
753 -- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
754 -- (first c >>> arr snd) >>> ss
755
756 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
757 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
758 core_mux <- matchEnv env_ids
759 (mkCorePairExpr
760 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
761 (mkBigCoreVarTup out_ids))
762 let
763 in_ty = mkBigCoreVarTupTy env_ids
764 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
765 out_ty = mkBigCoreVarTupTy out_ids
766 before_c_ty = mkCorePairTy in_ty1 out_ty
767 after_c_ty = mkCorePairTy c_ty out_ty
768 snd_fn <- mkSndExpr c_ty out_ty
769 return (do_premap ids in_ty before_c_ty out_ty core_mux $
770 do_compose ids before_c_ty after_c_ty out_ty
771 (do_first ids in_ty1 c_ty out_ty core_cmd) $
772 do_arr ids after_c_ty out_ty snd_fn,
773 extendVarSetList fv_cmd out_ids)
774
775 -- D; xs1 |-a c : () --> t
776 -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
777 -- -----------------------------------
778 -- D; xs |-a do { p <- c; ss } : t'
779 --
780 -- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
781 -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
782 --
783 -- It would be simpler and more consistent to do this using second,
784 -- but that's likely to be defined in terms of first.
785
786 dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
787 let pat_ty = hsLPatType pat
788 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
789 let pat_vars = mkVarSet (collectPatBinders pat)
790 let
791 env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
792 env_ty2 = mkBigCoreVarTupTy env_ids2
793
794 -- multiplexing function
795 -- \ (xs) -> (((xs1),()),(xs2))
796
797 core_mux <- matchEnv env_ids
798 (mkCorePairExpr
799 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
800 (mkBigCoreVarTup env_ids2))
801
802 -- projection function
803 -- \ (p, (xs2)) -> (zs)
804
805 env_id <- newSysLocalDs env_ty2
806 uniqs <- newUniqueSupply
807 let
808 after_c_ty = mkCorePairTy pat_ty env_ty2
809 out_ty = mkBigCoreVarTupTy out_ids
810 body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
811
812 fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
813 pat_id <- selectSimpleMatchVarL pat
814 match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
815 pair_id <- newSysLocalDs after_c_ty
816 let
817 proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
818
819 -- put it all together
820 let
821 in_ty = mkBigCoreVarTupTy env_ids
822 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
823 in_ty2 = mkBigCoreVarTupTy env_ids2
824 before_c_ty = mkCorePairTy in_ty1 in_ty2
825 return (do_premap ids in_ty before_c_ty out_ty core_mux $
826 do_compose ids before_c_ty after_c_ty out_ty
827 (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
828 do_arr ids after_c_ty out_ty proj_expr,
829 fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
830
831 -- D; xs' |-a do { ss } : t
832 -- --------------------------------------
833 -- D; xs |-a do { let binds; ss } : t
834 --
835 -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
836
837 dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do
838 -- build a new environment using the let bindings
839 core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
840 -- match the old environment against the input
841 core_map <- matchEnv env_ids core_binds
842 return (do_arr ids
843 (mkBigCoreVarTupTy env_ids)
844 (mkBigCoreVarTupTy out_ids)
845 core_map,
846 exprFreeIds core_binds `intersectVarSet` local_vars)
847
848 -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
849 -- D; xs' |-a do { ss' } : t
850 -- ------------------------------------
851 -- D; xs |-a do { rec ss; ss' } : t
852 --
853 -- xs1 = xs' /\ defs(ss)
854 -- xs2 = xs' - defs(ss)
855 -- ys1 = ys - defs(ss)
856 -- ys2 = ys /\ defs(ss)
857 --
858 -- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
859 -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
860 -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
861
862 dsCmdStmt ids local_vars out_ids
863 (RecStmt { recS_stmts = stmts
864 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
865 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
866 env_ids = do
867 let
868 env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
869 env2_ids = varSetElems env2_id_set
870 env2_ty = mkBigCoreVarTupTy env2_ids
871
872 -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
873
874 uniqs <- newUniqueSupply
875 env2_id <- newSysLocalDs env2_ty
876 let
877 later_ty = mkBigCoreVarTupTy later_ids
878 post_pair_ty = mkCorePairTy later_ty env2_ty
879 post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
880
881 post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
882
883 --- loop (...)
884
885 (core_loop, env1_id_set, env1_ids)
886 <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
887
888 -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
889
890 let
891 env1_ty = mkBigCoreVarTupTy env1_ids
892 pre_pair_ty = mkCorePairTy env1_ty env2_ty
893 pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
894 (mkBigCoreVarTup env2_ids)
895
896 pre_loop_fn <- matchEnv env_ids pre_loop_body
897
898 -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
899
900 let
901 env_ty = mkBigCoreVarTupTy env_ids
902 out_ty = mkBigCoreVarTupTy out_ids
903 core_body = do_premap ids env_ty pre_pair_ty out_ty
904 pre_loop_fn
905 (do_compose ids pre_pair_ty post_pair_ty out_ty
906 (do_first ids env1_ty later_ty env2_ty
907 core_loop)
908 (do_arr ids post_pair_ty out_ty
909 post_loop_fn))
910
911 return (core_body, env1_id_set `unionVarSet` env2_id_set)
912
913 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
914
915 -- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
916 -- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
917
918 dsRecCmd
919 :: DsCmdEnv -- arrow combinators
920 -> IdSet -- set of local vars available to this statement
921 -> [CmdLStmt Id] -- list of statements inside the RecCmd
922 -> [Id] -- list of vars defined here and used later
923 -> [HsExpr Id] -- expressions corresponding to later_ids
924 -> [Id] -- list of vars fed back through the loop
925 -> [HsExpr Id] -- expressions corresponding to rec_ids
926 -> DsM (CoreExpr, -- desugared statement
927 IdSet, -- subset of local vars that occur free
928 [Id]) -- same local vars as a list
929
930 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
931 let
932 later_id_set = mkVarSet later_ids
933 rec_id_set = mkVarSet rec_ids
934 local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
935
936 -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
937
938 core_later_rets <- mapM dsExpr later_rets
939 core_rec_rets <- mapM dsExpr rec_rets
940 let
941 -- possibly polymorphic version of vars of later_ids and rec_ids
942 out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
943 out_ty = mkBigCoreVarTupTy out_ids
944
945 later_tuple = mkBigCoreTup core_later_rets
946 later_ty = mkBigCoreVarTupTy later_ids
947
948 rec_tuple = mkBigCoreTup core_rec_rets
949 rec_ty = mkBigCoreVarTupTy rec_ids
950
951 out_pair = mkCorePairExpr later_tuple rec_tuple
952 out_pair_ty = mkCorePairTy later_ty rec_ty
953
954 mk_pair_fn <- matchEnv out_ids out_pair
955
956 -- ss
957
958 (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
959
960 -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
961
962 rec_id <- newSysLocalDs rec_ty
963 let
964 env1_id_set = fv_stmts `minusVarSet` rec_id_set
965 env1_ids = varSetElems env1_id_set
966 env1_ty = mkBigCoreVarTupTy env1_ids
967 in_pair_ty = mkCorePairTy env1_ty rec_ty
968 core_body = mkBigCoreTup (map selectVar env_ids)
969 where
970 selectVar v
971 | v `elemVarSet` rec_id_set
972 = mkTupleSelector rec_ids v rec_id (Var rec_id)
973 | otherwise = Var v
974
975 squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
976
977 -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
978
979 let
980 env_ty = mkBigCoreVarTupTy env_ids
981 core_loop = do_loop ids env1_ty later_ty rec_ty
982 (do_premap ids in_pair_ty env_ty out_pair_ty
983 squash_pair_fn
984 (do_compose ids env_ty out_ty out_pair_ty
985 core_stmts
986 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
987
988 return (core_loop, env1_id_set, env1_ids)
989
990 {-
991 A sequence of statements (as in a rec) is desugared to an arrow between
992 two environments (no stack)
993 -}
994
995 dsfixCmdStmts
996 :: DsCmdEnv -- arrow combinators
997 -> IdSet -- set of local vars available to this statement
998 -> [Id] -- output vars of these statements
999 -> [CmdLStmt Id] -- statements to desugar
1000 -> DsM (CoreExpr, -- desugared expression
1001 IdSet, -- subset of local vars that occur free
1002 [Id]) -- same local vars as a list
1003
1004 dsfixCmdStmts ids local_vars out_ids stmts
1005 = trimInput (dsCmdStmts ids local_vars out_ids stmts)
1006
1007 dsCmdStmts
1008 :: DsCmdEnv -- arrow combinators
1009 -> IdSet -- set of local vars available to this statement
1010 -> [Id] -- output vars of these statements
1011 -> [CmdLStmt Id] -- statements to desugar
1012 -> [Id] -- list of vars in the input to these statements
1013 -> DsM (CoreExpr, -- desugared expression
1014 IdSet) -- subset of local vars that occur free
1015
1016 dsCmdStmts ids local_vars out_ids [stmt] env_ids
1017 = dsCmdLStmt ids local_vars out_ids stmt env_ids
1018
1019 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
1020 let bound_vars = mkVarSet (collectLStmtBinders stmt)
1021 let local_vars' = bound_vars `unionVarSet` local_vars
1022 (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
1023 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
1024 return (do_compose ids
1025 (mkBigCoreVarTupTy env_ids)
1026 (mkBigCoreVarTupTy env_ids')
1027 (mkBigCoreVarTupTy out_ids)
1028 core_stmt
1029 core_stmts,
1030 fv_stmt)
1031
1032 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
1033
1034 -- Match a list of expressions against a list of patterns, left-to-right.
1035
1036 matchSimplys :: [CoreExpr] -- Scrutinees
1037 -> HsMatchContext Name -- Match kind
1038 -> [LPat Id] -- Patterns they should match
1039 -> CoreExpr -- Return this if they all match
1040 -> CoreExpr -- Return this if they don't
1041 -> DsM CoreExpr
1042 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
1043 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
1044 match_code <- matchSimplys exps ctxt pats result_expr fail_expr
1045 matchSimply exp ctxt pat match_code fail_expr
1046 matchSimplys _ _ _ _ _ = panic "matchSimplys"
1047
1048 -- List of leaf expressions, with set of variables bound in each
1049
1050 leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
1051 leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
1052 = let
1053 defined_vars = mkVarSet (collectPatsBinders pats)
1054 `unionVarSet`
1055 mkVarSet (collectLocalBinders binds)
1056 in
1057 [(body,
1058 mkVarSet (collectLStmtsBinders stmts)
1059 `unionVarSet` defined_vars)
1060 | L _ (GRHS stmts body) <- grhss]
1061
1062 -- Replace the leaf commands in a match
1063
1064 replaceLeavesMatch
1065 :: Type -- new result type
1066 -> [Located (body' Id)] -- replacement leaf expressions of that type
1067 -> LMatch Id (Located (body Id)) -- the matches of a case command
1068 -> ([Located (body' Id)], -- remaining leaf expressions
1069 LMatch Id (Located (body' Id))) -- updated match
1070 replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
1071 = let
1072 (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1073 in
1074 (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
1075
1076 replaceLeavesGRHS
1077 :: [Located (body' Id)] -- replacement leaf expressions of that type
1078 -> LGRHS Id (Located (body Id)) -- rhss of a case command
1079 -> ([Located (body' Id)], -- remaining leaf expressions
1080 LGRHS Id (Located (body' Id))) -- updated GRHS
1081 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
1082 = (leaves, L loc (GRHS stmts leaf))
1083 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
1084
1085 -- Balanced fold of a non-empty list.
1086
1087 foldb :: (a -> a -> a) -> [a] -> a
1088 foldb _ [] = error "foldb of empty list"
1089 foldb _ [x] = x
1090 foldb f xs = foldb f (fold_pairs xs)
1091 where
1092 fold_pairs [] = []
1093 fold_pairs [x] = [x]
1094 fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1095
1096 {-
1097 Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
1098 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1099 The following functions to collect value variables from patterns are
1100 copied from HsUtils, with one change: we also collect the dictionary
1101 bindings (pat_binds) from ConPatOut. We need them for cases like
1102
1103 h :: Arrow a => Int -> a (Int,Int) Int
1104 h x = proc (y,z) -> case compare x y of
1105 GT -> returnA -< z+x
1106
1107 The type checker turns the case into
1108
1109 case compare x y of
1110 GT { p77 = plusInt } -> returnA -< p77 z x
1111
1112 Here p77 is a local binding for the (+) operation.
1113
1114 See comments in HsUtils for why the other version does not include
1115 these bindings.
1116 -}
1117
1118 collectPatBinders :: LPat Id -> [Id]
1119 collectPatBinders pat = collectl pat []
1120
1121 collectPatsBinders :: [LPat Id] -> [Id]
1122 collectPatsBinders pats = foldr collectl [] pats
1123
1124 ---------------------
1125 collectl :: LPat Id -> [Id] -> [Id]
1126 -- See Note [Dictionary binders in ConPatOut]
1127 collectl (L _ pat) bndrs
1128 = go pat
1129 where
1130 go (VarPat (L _ var)) = var : bndrs
1131 go (WildPat _) = bndrs
1132 go (LazyPat pat) = collectl pat bndrs
1133 go (BangPat pat) = collectl pat bndrs
1134 go (AsPat (L _ a) pat) = a : collectl pat bndrs
1135 go (ParPat pat) = collectl pat bndrs
1136
1137 go (ListPat pats _ _) = foldr collectl bndrs pats
1138 go (PArrPat pats _) = foldr collectl bndrs pats
1139 go (TuplePat pats _ _) = foldr collectl bndrs pats
1140
1141 go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
1142 go (ConPatOut {pat_args=ps, pat_binds=ds}) =
1143 collectEvBinders ds
1144 ++ foldr collectl bndrs (hsConPatArgs ps)
1145 go (LitPat _) = bndrs
1146 go (NPat _ _ _) = bndrs
1147 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
1148
1149 go (SigPatIn pat _) = collectl pat bndrs
1150 go (SigPatOut pat _) = collectl pat bndrs
1151 go (CoPat _ pat _) = collectl (noLoc pat) bndrs
1152 go (ViewPat _ pat _) = collectl pat bndrs
1153 go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
1154
1155 collectEvBinders :: TcEvBinds -> [Id]
1156 collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
1157 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1158
1159 add_ev_bndr :: EvBind -> [Id] -> [Id]
1160 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1161 | otherwise = bs
1162 -- A worry: what about coercion variable binders??
1163
1164 collectLStmtsBinders :: [LStmt Id body] -> [Id]
1165 collectLStmtsBinders = concatMap collectLStmtBinders
1166
1167 collectLStmtBinders :: LStmt Id body -> [Id]
1168 collectLStmtBinders = collectStmtBinders . unLoc
1169
1170 collectStmtBinders :: Stmt Id body -> [Id]
1171 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
1172 collectStmtBinders stmt = HsUtils.collectStmtBinders stmt