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