TTG3 Combined Step 1 and 3 for Trees That Grow
[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 (CmdTopTc _unitTy cmd_ty ids) cmd)) = 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 dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
332
333 {-
334 Translation of a command judgement of the form
335
336 D; xs |-a c : stk --> t
337
338 to an expression e such that
339
340 D |- e :: a (xs, stk) t
341 -}
342
343 dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
344 -> DsM (CoreExpr, DIdSet)
345 dsLCmd ids local_vars stk_ty res_ty cmd env_ids
346 = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
347
348 dsCmd :: DsCmdEnv -- arrow combinators
349 -> IdSet -- set of local vars available to this command
350 -> Type -- type of the stack (right-nested tuple)
351 -> Type -- return type of the command
352 -> HsCmd GhcTc -- command to desugar
353 -> [Id] -- list of vars in the input to this command
354 -- This is typically fed back,
355 -- so don't pull on it too early
356 -> DsM (CoreExpr, -- desugared expression
357 DIdSet) -- subset of local vars that occur free
358
359 -- D |- fun :: a t1 t2
360 -- D, xs |- arg :: t1
361 -- -----------------------------
362 -- D; xs |-a fun -< arg : stk --> t2
363 --
364 -- ---> premap (\ ((xs), _stk) -> arg) fun
365
366 dsCmd ids local_vars stack_ty res_ty
367 (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
368 env_ids = do
369 let
370 (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
371 (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
372 core_arrow <- dsLExprNoLP arrow
373 core_arg <- dsLExpr arg
374 stack_id <- newSysLocalDs stack_ty
375 core_make_arg <- matchEnvStack env_ids stack_id core_arg
376 return (do_premap ids
377 (envStackType env_ids stack_ty)
378 arg_ty
379 res_ty
380 core_make_arg
381 core_arrow,
382 exprFreeIdsDSet core_arg `udfmIntersectUFM` (getUniqSet local_vars))
383
384 -- D, xs |- fun :: a t1 t2
385 -- D, xs |- arg :: t1
386 -- ------------------------------
387 -- D; xs |-a fun -<< arg : stk --> t2
388 --
389 -- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
390
391 dsCmd ids local_vars stack_ty res_ty
392 (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
393 env_ids = do
394 let
395 (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
396 (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
397
398 core_arrow <- dsLExpr arrow
399 core_arg <- dsLExpr arg
400 stack_id <- newSysLocalDs stack_ty
401 core_make_pair <- matchEnvStack env_ids stack_id
402 (mkCorePairExpr core_arrow core_arg)
403
404 return (do_premap ids
405 (envStackType env_ids stack_ty)
406 (mkCorePairTy arrow_ty arg_ty)
407 res_ty
408 core_make_pair
409 (do_app ids arg_ty res_ty),
410 (exprsFreeIdsDSet [core_arrow, core_arg])
411 `udfmIntersectUFM` getUniqSet local_vars)
412
413 -- D; ys |-a cmd : (t,stk) --> t'
414 -- D, xs |- exp :: t
415 -- ------------------------
416 -- D; xs |-a cmd exp : stk --> t'
417 --
418 -- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
419
420 dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
421 core_arg <- dsLExpr arg
422 let
423 arg_ty = exprType core_arg
424 stack_ty' = mkCorePairTy arg_ty stack_ty
425 (core_cmd, free_vars, env_ids')
426 <- dsfixCmd ids local_vars stack_ty' res_ty cmd
427 stack_id <- newSysLocalDs stack_ty
428 arg_id <- newSysLocalDsNoLP arg_ty
429 -- push the argument expression onto the stack
430 let
431 stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
432 core_body = bindNonRec arg_id core_arg
433 (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
434
435 -- match the environment and stack against the input
436 core_map <- matchEnvStack env_ids stack_id core_body
437 return (do_premap ids
438 (envStackType env_ids stack_ty)
439 (envStackType env_ids' stack_ty')
440 res_ty
441 core_map
442 core_cmd,
443 free_vars `unionDVarSet`
444 (exprFreeIdsDSet core_arg `udfmIntersectUFM` getUniqSet local_vars))
445
446 -- D; ys |-a cmd : stk t'
447 -- -----------------------------------------------
448 -- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
449 --
450 -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
451
452 dsCmd ids local_vars stack_ty res_ty
453 (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats
454 , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
455 env_ids = do
456 let pat_vars = mkVarSet (collectPatsBinders pats)
457 let
458 local_vars' = pat_vars `unionVarSet` local_vars
459 (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
460 (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body
461 param_ids <- mapM newSysLocalDsNoLP pat_tys
462 stack_id' <- newSysLocalDs stack_ty'
463
464 -- the expression is built from the inside out, so the actions
465 -- are presented in reverse order
466
467 let
468 -- build a new environment, plus what's left of the stack
469 core_expr = buildEnvStack env_ids' stack_id'
470 in_ty = envStackType env_ids stack_ty
471 in_ty' = envStackType env_ids' stack_ty'
472
473 fail_expr <- mkFailExpr LambdaExpr in_ty'
474 -- match the patterns against the parameters
475 match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr
476 -- match the parameters against the top of the old stack
477 (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
478 -- match the old environment and stack against the input
479 select_code <- matchEnvStack env_ids stack_id param_code
480 return (do_premap ids in_ty in_ty' res_ty select_code core_body,
481 free_vars `udfmMinusUFM` getUniqSet pat_vars)
482
483 dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
484 = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
485
486 -- D, xs |- e :: Bool
487 -- D; xs1 |-a c1 : stk --> t
488 -- D; xs2 |-a c2 : stk --> t
489 -- ----------------------------------------
490 -- D; xs |-a if e then c1 else c2 : stk --> t
491 --
492 -- ---> premap (\ ((xs),stk) ->
493 -- if e then Left ((xs1),stk) else Right ((xs2),stk))
494 -- (c1 ||| c2)
495
496 dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
497 env_ids = do
498 core_cond <- dsLExpr cond
499 (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
500 (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
501 stack_id <- newSysLocalDs stack_ty
502 either_con <- dsLookupTyCon eitherTyConName
503 left_con <- dsLookupDataCon leftDataConName
504 right_con <- dsLookupDataCon rightDataConName
505
506 let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e]
507 mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e]
508
509 in_ty = envStackType env_ids stack_ty
510 then_ty = envStackType then_ids stack_ty
511 else_ty = envStackType else_ids stack_ty
512 sum_ty = mkTyConApp either_con [then_ty, else_ty]
513 fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` getUniqSet local_vars
514
515 core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id)
516 core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
517
518 core_if <- case mb_fun of
519 Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right]
520 ; matchEnvStack env_ids stack_id fun_apps }
521 Nothing -> matchEnvStack env_ids stack_id $
522 mkIfThenElse core_cond core_left core_right
523
524 return (do_premap ids in_ty sum_ty res_ty
525 core_if
526 (do_choice ids then_ty else_ty res_ty core_then core_else),
527 fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
528
529 {-
530 Case commands are treated in much the same way as if commands
531 (see above) except that there are more alternatives. For example
532
533 case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
534
535 is translated to
536
537 premap (\ ((xs)*ts) -> case e of
538 p1 -> (Left (Left (xs1)*ts))
539 p2 -> Left ((Right (xs2)*ts))
540 p3 -> Right ((xs3)*ts))
541 ((c1 ||| c2) ||| c3)
542
543 The idea is to extract the commands from the case, build a balanced tree
544 of choices, and replace the commands with expressions that build tagged
545 tuples, obtaining a case expression that can be desugared normally.
546 To build all this, we use triples describing segments of the list of
547 case bodies, containing the following fields:
548 * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
549 into the case replacing the commands
550 * a sum type that is the common type of these expressions, and also the
551 input type of the arrow
552 * a CoreExpr for an arrow built by combining the translated command
553 bodies with |||.
554 -}
555
556 dsCmd ids local_vars stack_ty res_ty
557 (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
558 , mg_origin = origin }))
559 env_ids = do
560 stack_id <- newSysLocalDs stack_ty
561
562 -- Extract and desugar the leaf commands in the case, building tuple
563 -- expressions that will (after tagging) replace these leaves
564
565 let
566 leaves = concatMap leavesMatch matches
567 make_branch (leaf, bound_vars) = do
568 (core_leaf, _fvs, leaf_ids) <-
569 dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf
570 return ([mkHsEnvStackExpr leaf_ids stack_id],
571 envStackType leaf_ids stack_ty,
572 core_leaf)
573
574 branches <- mapM make_branch leaves
575 either_con <- dsLookupTyCon eitherTyConName
576 left_con <- dsLookupDataCon leftDataConName
577 right_con <- dsLookupDataCon rightDataConName
578 let
579 left_id = HsConLikeOut noExt (RealDataCon left_con)
580 right_id = HsConLikeOut noExt (RealDataCon right_con)
581 left_expr ty1 ty2 e = noLoc $ HsApp noExt
582 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
583 right_expr ty1 ty2 e = noLoc $ HsApp noExt
584 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
585
586 -- Prefix each tuple with a distinct series of Left's and Right's,
587 -- in a balanced way, keeping track of the types.
588
589 merge_branches (builds1, in_ty1, core_exp1)
590 (builds2, in_ty2, core_exp2)
591 = (map (left_expr in_ty1 in_ty2) builds1 ++
592 map (right_expr in_ty1 in_ty2) builds2,
593 mkTyConApp either_con [in_ty1, in_ty2],
594 do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
595 (leaves', sum_ty, core_choices) = foldb merge_branches branches
596
597 -- Replace the commands in the case with these tagged tuples,
598 -- yielding a HsExpr Id we can feed to dsExpr.
599
600 (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
601 in_ty = envStackType env_ids stack_ty
602
603 core_body <- dsExpr (HsCase noExt exp
604 (MG { mg_alts = L l matches'
605 , mg_arg_tys = arg_tys
606 , mg_res_ty = sum_ty, mg_origin = origin }))
607 -- Note that we replace the HsCase result type by sum_ty,
608 -- which is the type of matches'
609
610 core_matches <- matchEnvStack env_ids stack_id core_body
611 return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
612 exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars)
613
614 -- D; ys |-a cmd : stk --> t
615 -- ----------------------------------
616 -- D; xs |-a let binds in cmd : stk --> t
617 --
618 -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
619
620 dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
621 env_ids = do
622 let
623 defined_vars = mkVarSet (collectLocalBinders binds)
624 local_vars' = defined_vars `unionVarSet` local_vars
625
626 (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
627 stack_id <- newSysLocalDs stack_ty
628 -- build a new environment, plus the stack, using the let bindings
629 core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
630 -- match the old environment and stack against the input
631 core_map <- matchEnvStack env_ids stack_id core_binds
632 return (do_premap ids
633 (envStackType env_ids stack_ty)
634 (envStackType env_ids' stack_ty)
635 res_ty
636 core_map
637 core_body,
638 exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
639
640 -- D; xs |-a ss : t
641 -- ----------------------------------
642 -- D; xs |-a do { ss } : () --> t
643 --
644 -- ---> premap (\ (env,stk) -> env) c
645
646 dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
647 env_ids = do
648 putSrcSpanDs loc $
649 dsNoLevPoly stmts_ty
650 (text "In the do-command:" <+> ppr do_block)
651 (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
652 let env_ty = mkBigCoreVarTupTy env_ids
653 core_fst <- mkFstExpr env_ty stack_ty
654 return (do_premap ids
655 (mkCorePairTy env_ty stack_ty)
656 env_ty
657 res_ty
658 core_fst
659 core_stmts,
660 env_ids')
661
662 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
663 -- D; xs |-a ci :: stki --> ti
664 -- -----------------------------------
665 -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
666
667 dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
668 let env_ty = mkBigCoreVarTupTy env_ids
669 core_op <- dsLExpr op
670 (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
671 return (mkApps (App core_op (Type env_ty)) core_args,
672 unionDVarSets fv_sets)
673
674 dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
675 (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
676 core_wrap <- dsHsWrapper wrap
677 return (core_wrap core_cmd, env_ids')
678
679 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
680
681 -- D; ys |-a c : stk --> t (ys <= xs)
682 -- ---------------------
683 -- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
684
685 dsTrimCmdArg
686 :: IdSet -- set of local vars available to this command
687 -> [Id] -- list of vars in the input to this command
688 -> LHsCmdTop GhcTc -- command argument to desugar
689 -> DsM (CoreExpr, -- desugared expression
690 DIdSet) -- subset of local vars that occur free
691 dsTrimCmdArg local_vars env_ids
692 (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
693 (meth_binds, meth_ids) <- mkCmdEnv ids
694 (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
695 stack_id <- newSysLocalDs stack_ty
696 trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
697 let
698 in_ty = envStackType env_ids stack_ty
699 in_ty' = envStackType env_ids' stack_ty
700 arg_code = if env_ids' == env_ids then core_cmd else
701 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
702 return (mkLets meth_binds arg_code, free_vars)
703 dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
704
705 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
706 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
707
708 dsfixCmd
709 :: DsCmdEnv -- arrow combinators
710 -> IdSet -- set of local vars available to this command
711 -> Type -- type of the stack (right-nested tuple)
712 -> Type -- return type of the command
713 -> LHsCmd GhcTc -- command to desugar
714 -> DsM (CoreExpr, -- desugared expression
715 DIdSet, -- subset of local vars that occur free
716 [Id]) -- the same local vars as a list, fed back
717 dsfixCmd ids local_vars stk_ty cmd_ty cmd
718 = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
719 (text "When desugaring the command:" <+> ppr cmd)
720 ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
721
722 -- Feed back the list of local variables actually used a command,
723 -- for use as the input tuple of the generated arrow.
724
725 trimInput
726 :: ([Id] -> DsM (CoreExpr, DIdSet))
727 -> DsM (CoreExpr, -- desugared expression
728 DIdSet, -- subset of local vars that occur free
729 [Id]) -- same local vars as a list, fed back to
730 -- the inner function to form the tuple of
731 -- inputs to the arrow.
732 trimInput build_arrow
733 = fixDs (\ ~(_,_,env_ids) -> do
734 (core_cmd, free_vars) <- build_arrow env_ids
735 return (core_cmd, free_vars, dVarSetElems free_vars))
736
737 {-
738 Translation of command judgements of the form
739
740 D |-a do { ss } : t
741 -}
742
743 dsCmdDo :: DsCmdEnv -- arrow combinators
744 -> IdSet -- set of local vars available to this statement
745 -> Type -- return type of the statement
746 -> [CmdLStmt GhcTc] -- statements to desugar
747 -> [Id] -- list of vars in the input to this statement
748 -- This is typically fed back,
749 -- so don't pull on it too early
750 -> DsM (CoreExpr, -- desugared expression
751 DIdSet) -- subset of local vars that occur free
752
753 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
754
755 -- D; xs |-a c : () --> t
756 -- --------------------------
757 -- D; xs |-a do { c } : t
758 --
759 -- ---> premap (\ (xs) -> ((xs), ())) c
760
761 dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do
762 putSrcSpanDs loc $ dsNoLevPoly res_ty
763 (text "In the command:" <+> ppr body)
764 (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
765 let env_ty = mkBigCoreVarTupTy env_ids
766 env_var <- newSysLocalDs env_ty
767 let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
768 return (do_premap ids
769 env_ty
770 (mkCorePairTy env_ty unitTy)
771 res_ty
772 core_map
773 core_body,
774 env_ids')
775
776 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
777 let bound_vars = mkVarSet (collectLStmtBinders stmt)
778 let local_vars' = bound_vars `unionVarSet` local_vars
779 (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
780 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
781 return (do_compose ids
782 (mkBigCoreVarTupTy env_ids)
783 (mkBigCoreVarTupTy env_ids')
784 res_ty
785 core_stmt
786 core_stmts,
787 fv_stmt)
788
789 {-
790 A statement maps one local environment to another, and is represented
791 as an arrow from one tuple type to another. A statement sequence is
792 translated to a composition of such arrows.
793 -}
794
795 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
796 -> DsM (CoreExpr, DIdSet)
797 dsCmdLStmt ids local_vars out_ids cmd env_ids
798 = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
799
800 dsCmdStmt
801 :: DsCmdEnv -- arrow combinators
802 -> IdSet -- set of local vars available to this statement
803 -> [Id] -- list of vars in the output of this statement
804 -> CmdStmt GhcTc -- statement to desugar
805 -> [Id] -- list of vars in the input to this statement
806 -- This is typically fed back,
807 -- so don't pull on it too early
808 -> DsM (CoreExpr, -- desugared expression
809 DIdSet) -- subset of local vars that occur free
810
811 -- D; xs1 |-a c : () --> t
812 -- D; xs' |-a do { ss } : t'
813 -- ------------------------------
814 -- D; xs |-a do { c; ss } : t'
815 --
816 -- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
817 -- (first c >>> arr snd) >>> ss
818
819 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
820 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
821 core_mux <- matchEnv env_ids
822 (mkCorePairExpr
823 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
824 (mkBigCoreVarTup out_ids))
825 let
826 in_ty = mkBigCoreVarTupTy env_ids
827 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
828 out_ty = mkBigCoreVarTupTy out_ids
829 before_c_ty = mkCorePairTy in_ty1 out_ty
830 after_c_ty = mkCorePairTy c_ty out_ty
831 dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
832 snd_fn <- mkSndExpr c_ty out_ty
833 return (do_premap ids in_ty before_c_ty out_ty core_mux $
834 do_compose ids before_c_ty after_c_ty out_ty
835 (do_first ids in_ty1 c_ty out_ty core_cmd) $
836 do_arr ids after_c_ty out_ty snd_fn,
837 extendDVarSetList fv_cmd out_ids)
838
839 -- D; xs1 |-a c : () --> t
840 -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
841 -- -----------------------------------
842 -- D; xs |-a do { p <- c; ss } : t'
843 --
844 -- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
845 -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
846 --
847 -- It would be simpler and more consistent to do this using second,
848 -- but that's likely to be defined in terms of first.
849
850 dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
851 let pat_ty = hsLPatType pat
852 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
853 let pat_vars = mkVarSet (collectPatBinders pat)
854 let
855 env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
856 env_ty2 = mkBigCoreVarTupTy env_ids2
857
858 -- multiplexing function
859 -- \ (xs) -> (((xs1),()),(xs2))
860
861 core_mux <- matchEnv env_ids
862 (mkCorePairExpr
863 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
864 (mkBigCoreVarTup env_ids2))
865
866 -- projection function
867 -- \ (p, (xs2)) -> (zs)
868
869 env_id <- newSysLocalDs env_ty2
870 uniqs <- newUniqueSupply
871 let
872 after_c_ty = mkCorePairTy pat_ty env_ty2
873 out_ty = mkBigCoreVarTupTy out_ids
874 body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
875
876 fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
877 pat_id <- selectSimpleMatchVarL pat
878 match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
879 pair_id <- newSysLocalDs after_c_ty
880 let
881 proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
882
883 -- put it all together
884 let
885 in_ty = mkBigCoreVarTupTy env_ids
886 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
887 in_ty2 = mkBigCoreVarTupTy env_ids2
888 before_c_ty = mkCorePairTy in_ty1 in_ty2
889 return (do_premap ids in_ty before_c_ty out_ty core_mux $
890 do_compose ids before_c_ty after_c_ty out_ty
891 (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
892 do_arr ids after_c_ty out_ty proj_expr,
893 fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars))
894
895 -- D; xs' |-a do { ss } : t
896 -- --------------------------------------
897 -- D; xs |-a do { let binds; ss } : t
898 --
899 -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
900
901 dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
902 -- build a new environment using the let bindings
903 core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
904 -- match the old environment against the input
905 core_map <- matchEnv env_ids core_binds
906 return (do_arr ids
907 (mkBigCoreVarTupTy env_ids)
908 (mkBigCoreVarTupTy out_ids)
909 core_map,
910 exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
911
912 -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
913 -- D; xs' |-a do { ss' } : t
914 -- ------------------------------------
915 -- D; xs |-a do { rec ss; ss' } : t
916 --
917 -- xs1 = xs' /\ defs(ss)
918 -- xs2 = xs' - defs(ss)
919 -- ys1 = ys - defs(ss)
920 -- ys2 = ys /\ defs(ss)
921 --
922 -- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
923 -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
924 -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
925
926 dsCmdStmt ids local_vars out_ids
927 (RecStmt { recS_stmts = stmts
928 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
929 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
930 env_ids = do
931 let
932 later_ids_set = mkVarSet later_ids
933 env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
934 env2_id_set = mkDVarSet env2_ids
935 env2_ty = mkBigCoreVarTupTy env2_ids
936
937 -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
938
939 uniqs <- newUniqueSupply
940 env2_id <- newSysLocalDs env2_ty
941 let
942 later_ty = mkBigCoreVarTupTy later_ids
943 post_pair_ty = mkCorePairTy later_ty env2_ty
944 post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
945
946 post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
947
948 --- loop (...)
949
950 (core_loop, env1_id_set, env1_ids)
951 <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
952
953 -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
954
955 let
956 env1_ty = mkBigCoreVarTupTy env1_ids
957 pre_pair_ty = mkCorePairTy env1_ty env2_ty
958 pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
959 (mkBigCoreVarTup env2_ids)
960
961 pre_loop_fn <- matchEnv env_ids pre_loop_body
962
963 -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
964
965 let
966 env_ty = mkBigCoreVarTupTy env_ids
967 out_ty = mkBigCoreVarTupTy out_ids
968 core_body = do_premap ids env_ty pre_pair_ty out_ty
969 pre_loop_fn
970 (do_compose ids pre_pair_ty post_pair_ty out_ty
971 (do_first ids env1_ty later_ty env2_ty
972 core_loop)
973 (do_arr ids post_pair_ty out_ty
974 post_loop_fn))
975
976 return (core_body, env1_id_set `unionDVarSet` env2_id_set)
977
978 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
979
980 -- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
981 -- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
982
983 dsRecCmd
984 :: DsCmdEnv -- arrow combinators
985 -> IdSet -- set of local vars available to this statement
986 -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd
987 -> [Id] -- list of vars defined here and used later
988 -> [HsExpr GhcTc] -- expressions corresponding to later_ids
989 -> [Id] -- list of vars fed back through the loop
990 -> [HsExpr GhcTc] -- expressions corresponding to rec_ids
991 -> DsM (CoreExpr, -- desugared statement
992 DIdSet, -- subset of local vars that occur free
993 [Id]) -- same local vars as a list
994
995 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
996 let
997 later_id_set = mkVarSet later_ids
998 rec_id_set = mkVarSet rec_ids
999 local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
1000
1001 -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
1002
1003 core_later_rets <- mapM dsExpr later_rets
1004 core_rec_rets <- mapM dsExpr rec_rets
1005 let
1006 -- possibly polymorphic version of vars of later_ids and rec_ids
1007 out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
1008 out_ty = mkBigCoreVarTupTy out_ids
1009
1010 later_tuple = mkBigCoreTup core_later_rets
1011 later_ty = mkBigCoreVarTupTy later_ids
1012
1013 rec_tuple = mkBigCoreTup core_rec_rets
1014 rec_ty = mkBigCoreVarTupTy rec_ids
1015
1016 out_pair = mkCorePairExpr later_tuple rec_tuple
1017 out_pair_ty = mkCorePairTy later_ty rec_ty
1018
1019 mk_pair_fn <- matchEnv out_ids out_pair
1020
1021 -- ss
1022
1023 (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
1024
1025 -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
1026
1027 rec_id <- newSysLocalDs rec_ty
1028 let
1029 env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set
1030 env1_ids = dVarSetElems env1_id_set
1031 env1_ty = mkBigCoreVarTupTy env1_ids
1032 in_pair_ty = mkCorePairTy env1_ty rec_ty
1033 core_body = mkBigCoreTup (map selectVar env_ids)
1034 where
1035 selectVar v
1036 | v `elemVarSet` rec_id_set
1037 = mkTupleSelector rec_ids v rec_id (Var rec_id)
1038 | otherwise = Var v
1039
1040 squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
1041
1042 -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
1043
1044 let
1045 env_ty = mkBigCoreVarTupTy env_ids
1046 core_loop = do_loop ids env1_ty later_ty rec_ty
1047 (do_premap ids in_pair_ty env_ty out_pair_ty
1048 squash_pair_fn
1049 (do_compose ids env_ty out_ty out_pair_ty
1050 core_stmts
1051 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
1052
1053 return (core_loop, env1_id_set, env1_ids)
1054
1055 {-
1056 A sequence of statements (as in a rec) is desugared to an arrow between
1057 two environments (no stack)
1058 -}
1059
1060 dsfixCmdStmts
1061 :: DsCmdEnv -- arrow combinators
1062 -> IdSet -- set of local vars available to this statement
1063 -> [Id] -- output vars of these statements
1064 -> [CmdLStmt GhcTc] -- statements to desugar
1065 -> DsM (CoreExpr, -- desugared expression
1066 DIdSet, -- subset of local vars that occur free
1067 [Id]) -- same local vars as a list
1068
1069 dsfixCmdStmts ids local_vars out_ids stmts
1070 = trimInput (dsCmdStmts ids local_vars out_ids stmts)
1071 -- TODO: Add levity polymorphism check for the resulting expression.
1072 -- But I (Richard E.) don't know enough about arrows to do so.
1073
1074 dsCmdStmts
1075 :: DsCmdEnv -- arrow combinators
1076 -> IdSet -- set of local vars available to this statement
1077 -> [Id] -- output vars of these statements
1078 -> [CmdLStmt GhcTc] -- statements to desugar
1079 -> [Id] -- list of vars in the input to these statements
1080 -> DsM (CoreExpr, -- desugared expression
1081 DIdSet) -- subset of local vars that occur free
1082
1083 dsCmdStmts ids local_vars out_ids [stmt] env_ids
1084 = dsCmdLStmt ids local_vars out_ids stmt env_ids
1085
1086 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
1087 let bound_vars = mkVarSet (collectLStmtBinders stmt)
1088 let local_vars' = bound_vars `unionVarSet` local_vars
1089 (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
1090 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
1091 return (do_compose ids
1092 (mkBigCoreVarTupTy env_ids)
1093 (mkBigCoreVarTupTy env_ids')
1094 (mkBigCoreVarTupTy out_ids)
1095 core_stmt
1096 core_stmts,
1097 fv_stmt)
1098
1099 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
1100
1101 -- Match a list of expressions against a list of patterns, left-to-right.
1102
1103 matchSimplys :: [CoreExpr] -- Scrutinees
1104 -> HsMatchContext Name -- Match kind
1105 -> [LPat GhcTc] -- Patterns they should match
1106 -> CoreExpr -- Return this if they all match
1107 -> CoreExpr -- Return this if they don't
1108 -> DsM CoreExpr
1109 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
1110 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
1111 match_code <- matchSimplys exps ctxt pats result_expr fail_expr
1112 matchSimply exp ctxt pat match_code fail_expr
1113 matchSimplys _ _ _ _ _ = panic "matchSimplys"
1114
1115 -- List of leaf expressions, with set of variables bound in each
1116
1117 leavesMatch :: LMatch GhcTc (Located (body GhcTc))
1118 -> [(Located (body GhcTc), IdSet)]
1119 leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) }))
1120 = let
1121 defined_vars = mkVarSet (collectPatsBinders pats)
1122 `unionVarSet`
1123 mkVarSet (collectLocalBinders binds)
1124 in
1125 [(body,
1126 mkVarSet (collectLStmtsBinders stmts)
1127 `unionVarSet` defined_vars)
1128 | L _ (GRHS stmts body) <- grhss]
1129
1130 -- Replace the leaf commands in a match
1131
1132 replaceLeavesMatch
1133 :: Type -- new result type
1134 -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
1135 -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
1136 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1137 LMatch GhcTc (Located (body' GhcTc))) -- updated match
1138 replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds }))
1139 = let
1140 (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1141 in
1142 (leaves', L loc (match { m_grhss = GRHSs grhss' binds }))
1143
1144 replaceLeavesGRHS
1145 :: [Located (body' GhcTc)] -- replacement leaf expressions of that type
1146 -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
1147 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1148 LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
1149 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
1150 = (leaves, L loc (GRHS stmts leaf))
1151 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
1152
1153 -- Balanced fold of a non-empty list.
1154
1155 foldb :: (a -> a -> a) -> [a] -> a
1156 foldb _ [] = error "foldb of empty list"
1157 foldb _ [x] = x
1158 foldb f xs = foldb f (fold_pairs xs)
1159 where
1160 fold_pairs [] = []
1161 fold_pairs [x] = [x]
1162 fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1163
1164 {-
1165 Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
1166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1167 The following functions to collect value variables from patterns are
1168 copied from HsUtils, with one change: we also collect the dictionary
1169 bindings (pat_binds) from ConPatOut. We need them for cases like
1170
1171 h :: Arrow a => Int -> a (Int,Int) Int
1172 h x = proc (y,z) -> case compare x y of
1173 GT -> returnA -< z+x
1174
1175 The type checker turns the case into
1176
1177 case compare x y of
1178 GT { p77 = plusInt } -> returnA -< p77 z x
1179
1180 Here p77 is a local binding for the (+) operation.
1181
1182 See comments in HsUtils for why the other version does not include
1183 these bindings.
1184 -}
1185
1186 collectPatBinders :: LPat GhcTc -> [Id]
1187 collectPatBinders pat = collectl pat []
1188
1189 collectPatsBinders :: [LPat GhcTc] -> [Id]
1190 collectPatsBinders pats = foldr collectl [] pats
1191
1192 ---------------------
1193 collectl :: LPat GhcTc -> [Id] -> [Id]
1194 -- See Note [Dictionary binders in ConPatOut]
1195 collectl (L _ pat) bndrs
1196 = go pat
1197 where
1198 go (VarPat _ (L _ var)) = var : bndrs
1199 go (WildPat _) = bndrs
1200 go (LazyPat _ pat) = collectl pat bndrs
1201 go (BangPat _ pat) = collectl pat bndrs
1202 go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
1203 go (ParPat _ pat) = collectl pat bndrs
1204
1205 go (ListPat _ pats _ _) = foldr collectl bndrs pats
1206 go (PArrPat _ pats) = foldr collectl bndrs pats
1207 go (TuplePat _ pats _) = foldr collectl bndrs pats
1208 go (SumPat _ pat _ _) = collectl pat bndrs
1209
1210 go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
1211 go (ConPatOut {pat_args=ps, pat_binds=ds}) =
1212 collectEvBinders ds
1213 ++ foldr collectl bndrs (hsConPatArgs ps)
1214 go (LitPat _ _) = bndrs
1215 go (NPat {}) = bndrs
1216 go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
1217
1218 go (SigPat _ pat) = collectl pat bndrs
1219 go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
1220 go (ViewPat _ _ pat) = collectl pat bndrs
1221 go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
1222 go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
1223
1224 collectEvBinders :: TcEvBinds -> [Id]
1225 collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
1226 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1227
1228 add_ev_bndr :: EvBind -> [Id] -> [Id]
1229 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1230 | otherwise = bs
1231 -- A worry: what about coercion variable binders??
1232
1233 collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
1234 collectLStmtsBinders = concatMap collectLStmtBinders
1235
1236 collectLStmtBinders :: LStmt GhcTc body -> [Id]
1237 collectLStmtBinders = collectStmtBinders . unLoc
1238
1239 collectStmtBinders :: Stmt GhcTc body -> [Id]
1240 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
1241 collectStmtBinders stmt = HsUtils.collectStmtBinders stmt