c9c0a089c791c871af5b5e904cefd10198c36281
[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 noExt (RealDataCon left_con)
579 right_id = HsConLikeOut noExt (RealDataCon right_con)
580 left_expr ty1 ty2 e = noLoc $ HsApp noExt
581 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
582 right_expr ty1 ty2 e = noLoc $ HsApp noExt
583 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
584
585 -- Prefix each tuple with a distinct series of Left's and Right's,
586 -- in a balanced way, keeping track of the types.
587
588 merge_branches (builds1, in_ty1, core_exp1)
589 (builds2, in_ty2, core_exp2)
590 = (map (left_expr in_ty1 in_ty2) builds1 ++
591 map (right_expr in_ty1 in_ty2) builds2,
592 mkTyConApp either_con [in_ty1, in_ty2],
593 do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
594 (leaves', sum_ty, core_choices) = foldb merge_branches branches
595
596 -- Replace the commands in the case with these tagged tuples,
597 -- yielding a HsExpr Id we can feed to dsExpr.
598
599 (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
600 in_ty = envStackType env_ids stack_ty
601
602 core_body <- dsExpr (HsCase noExt exp
603 (MG { mg_alts = L l matches'
604 , mg_arg_tys = arg_tys
605 , mg_res_ty = sum_ty, mg_origin = origin }))
606 -- Note that we replace the HsCase result type by sum_ty,
607 -- which is the type of matches'
608
609 core_matches <- matchEnvStack env_ids stack_id core_body
610 return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
611 exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars)
612
613 -- D; ys |-a cmd : stk --> t
614 -- ----------------------------------
615 -- D; xs |-a let binds in cmd : stk --> t
616 --
617 -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
618
619 dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
620 let
621 defined_vars = mkVarSet (collectLocalBinders binds)
622 local_vars' = defined_vars `unionVarSet` local_vars
623
624 (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
625 stack_id <- newSysLocalDs stack_ty
626 -- build a new environment, plus the stack, using the let bindings
627 core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
628 -- match the old environment and stack against the input
629 core_map <- matchEnvStack env_ids stack_id core_binds
630 return (do_premap ids
631 (envStackType env_ids stack_ty)
632 (envStackType env_ids' stack_ty)
633 res_ty
634 core_map
635 core_body,
636 exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
637
638 -- D; xs |-a ss : t
639 -- ----------------------------------
640 -- D; xs |-a do { ss } : () --> t
641 --
642 -- ---> premap (\ (env,stk) -> env) c
643
644 dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
645 putSrcSpanDs loc $
646 dsNoLevPoly stmts_ty
647 (text "In the do-command:" <+> ppr do_block)
648 (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
649 let env_ty = mkBigCoreVarTupTy env_ids
650 core_fst <- mkFstExpr env_ty stack_ty
651 return (do_premap ids
652 (mkCorePairTy env_ty stack_ty)
653 env_ty
654 res_ty
655 core_fst
656 core_stmts,
657 env_ids')
658
659 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
660 -- D; xs |-a ci :: stki --> ti
661 -- -----------------------------------
662 -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
663
664 dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
665 let env_ty = mkBigCoreVarTupTy env_ids
666 core_op <- dsLExpr op
667 (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
668 return (mkApps (App core_op (Type env_ty)) core_args,
669 unionDVarSets fv_sets)
670
671 dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
672 (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
673 core_wrap <- dsHsWrapper wrap
674 return (core_wrap core_cmd, env_ids')
675
676 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
677
678 -- D; ys |-a c : stk --> t (ys <= xs)
679 -- ---------------------
680 -- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
681
682 dsTrimCmdArg
683 :: IdSet -- set of local vars available to this command
684 -> [Id] -- list of vars in the input to this command
685 -> LHsCmdTop GhcTc -- command argument to desugar
686 -> DsM (CoreExpr, -- desugared expression
687 DIdSet) -- subset of local vars that occur free
688 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
689 (meth_binds, meth_ids) <- mkCmdEnv ids
690 (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
691 stack_id <- newSysLocalDs stack_ty
692 trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
693 let
694 in_ty = envStackType env_ids stack_ty
695 in_ty' = envStackType env_ids' stack_ty
696 arg_code = if env_ids' == env_ids then core_cmd else
697 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
698 return (mkLets meth_binds arg_code, free_vars)
699
700 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
701 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
702
703 dsfixCmd
704 :: DsCmdEnv -- arrow combinators
705 -> IdSet -- set of local vars available to this command
706 -> Type -- type of the stack (right-nested tuple)
707 -> Type -- return type of the command
708 -> LHsCmd GhcTc -- command to desugar
709 -> DsM (CoreExpr, -- desugared expression
710 DIdSet, -- subset of local vars that occur free
711 [Id]) -- the same local vars as a list, fed back
712 dsfixCmd ids local_vars stk_ty cmd_ty cmd
713 = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
714 (text "When desugaring the command:" <+> ppr cmd)
715 ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
716
717 -- Feed back the list of local variables actually used a command,
718 -- for use as the input tuple of the generated arrow.
719
720 trimInput
721 :: ([Id] -> DsM (CoreExpr, DIdSet))
722 -> DsM (CoreExpr, -- desugared expression
723 DIdSet, -- subset of local vars that occur free
724 [Id]) -- same local vars as a list, fed back to
725 -- the inner function to form the tuple of
726 -- inputs to the arrow.
727 trimInput build_arrow
728 = fixDs (\ ~(_,_,env_ids) -> do
729 (core_cmd, free_vars) <- build_arrow env_ids
730 return (core_cmd, free_vars, dVarSetElems free_vars))
731
732 {-
733 Translation of command judgements of the form
734
735 D |-a do { ss } : t
736 -}
737
738 dsCmdDo :: DsCmdEnv -- arrow combinators
739 -> IdSet -- set of local vars available to this statement
740 -> Type -- return type of the statement
741 -> [CmdLStmt GhcTc] -- statements 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 DIdSet) -- subset of local vars that occur free
747
748 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
749
750 -- D; xs |-a c : () --> t
751 -- --------------------------
752 -- D; xs |-a do { c } : t
753 --
754 -- ---> premap (\ (xs) -> ((xs), ())) c
755
756 dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do
757 putSrcSpanDs loc $ dsNoLevPoly res_ty
758 (text "In the command:" <+> ppr body)
759 (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
760 let env_ty = mkBigCoreVarTupTy env_ids
761 env_var <- newSysLocalDs env_ty
762 let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
763 return (do_premap ids
764 env_ty
765 (mkCorePairTy env_ty unitTy)
766 res_ty
767 core_map
768 core_body,
769 env_ids')
770
771 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
772 let bound_vars = mkVarSet (collectLStmtBinders stmt)
773 let local_vars' = bound_vars `unionVarSet` local_vars
774 (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
775 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
776 return (do_compose ids
777 (mkBigCoreVarTupTy env_ids)
778 (mkBigCoreVarTupTy env_ids')
779 res_ty
780 core_stmt
781 core_stmts,
782 fv_stmt)
783
784 {-
785 A statement maps one local environment to another, and is represented
786 as an arrow from one tuple type to another. A statement sequence is
787 translated to a composition of such arrows.
788 -}
789
790 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
791 -> DsM (CoreExpr, DIdSet)
792 dsCmdLStmt ids local_vars out_ids cmd env_ids
793 = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
794
795 dsCmdStmt
796 :: DsCmdEnv -- arrow combinators
797 -> IdSet -- set of local vars available to this statement
798 -> [Id] -- list of vars in the output of this statement
799 -> CmdStmt GhcTc -- statement to desugar
800 -> [Id] -- list of vars in the input to this statement
801 -- This is typically fed back,
802 -- so don't pull on it too early
803 -> DsM (CoreExpr, -- desugared expression
804 DIdSet) -- subset of local vars that occur free
805
806 -- D; xs1 |-a c : () --> t
807 -- D; xs' |-a do { ss } : t'
808 -- ------------------------------
809 -- D; xs |-a do { c; ss } : t'
810 --
811 -- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
812 -- (first c >>> arr snd) >>> ss
813
814 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
815 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
816 core_mux <- matchEnv env_ids
817 (mkCorePairExpr
818 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
819 (mkBigCoreVarTup out_ids))
820 let
821 in_ty = mkBigCoreVarTupTy env_ids
822 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
823 out_ty = mkBigCoreVarTupTy out_ids
824 before_c_ty = mkCorePairTy in_ty1 out_ty
825 after_c_ty = mkCorePairTy c_ty out_ty
826 dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
827 snd_fn <- mkSndExpr c_ty out_ty
828 return (do_premap ids in_ty before_c_ty out_ty core_mux $
829 do_compose ids before_c_ty after_c_ty out_ty
830 (do_first ids in_ty1 c_ty out_ty core_cmd) $
831 do_arr ids after_c_ty out_ty snd_fn,
832 extendDVarSetList fv_cmd out_ids)
833
834 -- D; xs1 |-a c : () --> t
835 -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
836 -- -----------------------------------
837 -- D; xs |-a do { p <- c; ss } : t'
838 --
839 -- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
840 -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
841 --
842 -- It would be simpler and more consistent to do this using second,
843 -- but that's likely to be defined in terms of first.
844
845 dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
846 let pat_ty = hsLPatType pat
847 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
848 let pat_vars = mkVarSet (collectPatBinders pat)
849 let
850 env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
851 env_ty2 = mkBigCoreVarTupTy env_ids2
852
853 -- multiplexing function
854 -- \ (xs) -> (((xs1),()),(xs2))
855
856 core_mux <- matchEnv env_ids
857 (mkCorePairExpr
858 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
859 (mkBigCoreVarTup env_ids2))
860
861 -- projection function
862 -- \ (p, (xs2)) -> (zs)
863
864 env_id <- newSysLocalDs env_ty2
865 uniqs <- newUniqueSupply
866 let
867 after_c_ty = mkCorePairTy pat_ty env_ty2
868 out_ty = mkBigCoreVarTupTy out_ids
869 body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
870
871 fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
872 pat_id <- selectSimpleMatchVarL pat
873 match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
874 pair_id <- newSysLocalDs after_c_ty
875 let
876 proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
877
878 -- put it all together
879 let
880 in_ty = mkBigCoreVarTupTy env_ids
881 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
882 in_ty2 = mkBigCoreVarTupTy env_ids2
883 before_c_ty = mkCorePairTy in_ty1 in_ty2
884 return (do_premap ids in_ty before_c_ty out_ty core_mux $
885 do_compose ids before_c_ty after_c_ty out_ty
886 (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
887 do_arr ids after_c_ty out_ty proj_expr,
888 fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars))
889
890 -- D; xs' |-a do { ss } : t
891 -- --------------------------------------
892 -- D; xs |-a do { let binds; ss } : t
893 --
894 -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
895
896 dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
897 -- build a new environment using the let bindings
898 core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
899 -- match the old environment against the input
900 core_map <- matchEnv env_ids core_binds
901 return (do_arr ids
902 (mkBigCoreVarTupTy env_ids)
903 (mkBigCoreVarTupTy out_ids)
904 core_map,
905 exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
906
907 -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
908 -- D; xs' |-a do { ss' } : t
909 -- ------------------------------------
910 -- D; xs |-a do { rec ss; ss' } : t
911 --
912 -- xs1 = xs' /\ defs(ss)
913 -- xs2 = xs' - defs(ss)
914 -- ys1 = ys - defs(ss)
915 -- ys2 = ys /\ defs(ss)
916 --
917 -- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
918 -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
919 -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
920
921 dsCmdStmt ids local_vars out_ids
922 (RecStmt { recS_stmts = stmts
923 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
924 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
925 env_ids = do
926 let
927 later_ids_set = mkVarSet later_ids
928 env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
929 env2_id_set = mkDVarSet env2_ids
930 env2_ty = mkBigCoreVarTupTy env2_ids
931
932 -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
933
934 uniqs <- newUniqueSupply
935 env2_id <- newSysLocalDs env2_ty
936 let
937 later_ty = mkBigCoreVarTupTy later_ids
938 post_pair_ty = mkCorePairTy later_ty env2_ty
939 post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
940
941 post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
942
943 --- loop (...)
944
945 (core_loop, env1_id_set, env1_ids)
946 <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
947
948 -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
949
950 let
951 env1_ty = mkBigCoreVarTupTy env1_ids
952 pre_pair_ty = mkCorePairTy env1_ty env2_ty
953 pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
954 (mkBigCoreVarTup env2_ids)
955
956 pre_loop_fn <- matchEnv env_ids pre_loop_body
957
958 -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
959
960 let
961 env_ty = mkBigCoreVarTupTy env_ids
962 out_ty = mkBigCoreVarTupTy out_ids
963 core_body = do_premap ids env_ty pre_pair_ty out_ty
964 pre_loop_fn
965 (do_compose ids pre_pair_ty post_pair_ty out_ty
966 (do_first ids env1_ty later_ty env2_ty
967 core_loop)
968 (do_arr ids post_pair_ty out_ty
969 post_loop_fn))
970
971 return (core_body, env1_id_set `unionDVarSet` env2_id_set)
972
973 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
974
975 -- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
976 -- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
977
978 dsRecCmd
979 :: DsCmdEnv -- arrow combinators
980 -> IdSet -- set of local vars available to this statement
981 -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd
982 -> [Id] -- list of vars defined here and used later
983 -> [HsExpr GhcTc] -- expressions corresponding to later_ids
984 -> [Id] -- list of vars fed back through the loop
985 -> [HsExpr GhcTc] -- expressions corresponding to rec_ids
986 -> DsM (CoreExpr, -- desugared statement
987 DIdSet, -- subset of local vars that occur free
988 [Id]) -- same local vars as a list
989
990 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
991 let
992 later_id_set = mkVarSet later_ids
993 rec_id_set = mkVarSet rec_ids
994 local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
995
996 -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
997
998 core_later_rets <- mapM dsExpr later_rets
999 core_rec_rets <- mapM dsExpr rec_rets
1000 let
1001 -- possibly polymorphic version of vars of later_ids and rec_ids
1002 out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
1003 out_ty = mkBigCoreVarTupTy out_ids
1004
1005 later_tuple = mkBigCoreTup core_later_rets
1006 later_ty = mkBigCoreVarTupTy later_ids
1007
1008 rec_tuple = mkBigCoreTup core_rec_rets
1009 rec_ty = mkBigCoreVarTupTy rec_ids
1010
1011 out_pair = mkCorePairExpr later_tuple rec_tuple
1012 out_pair_ty = mkCorePairTy later_ty rec_ty
1013
1014 mk_pair_fn <- matchEnv out_ids out_pair
1015
1016 -- ss
1017
1018 (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
1019
1020 -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
1021
1022 rec_id <- newSysLocalDs rec_ty
1023 let
1024 env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set
1025 env1_ids = dVarSetElems env1_id_set
1026 env1_ty = mkBigCoreVarTupTy env1_ids
1027 in_pair_ty = mkCorePairTy env1_ty rec_ty
1028 core_body = mkBigCoreTup (map selectVar env_ids)
1029 where
1030 selectVar v
1031 | v `elemVarSet` rec_id_set
1032 = mkTupleSelector rec_ids v rec_id (Var rec_id)
1033 | otherwise = Var v
1034
1035 squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
1036
1037 -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
1038
1039 let
1040 env_ty = mkBigCoreVarTupTy env_ids
1041 core_loop = do_loop ids env1_ty later_ty rec_ty
1042 (do_premap ids in_pair_ty env_ty out_pair_ty
1043 squash_pair_fn
1044 (do_compose ids env_ty out_ty out_pair_ty
1045 core_stmts
1046 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
1047
1048 return (core_loop, env1_id_set, env1_ids)
1049
1050 {-
1051 A sequence of statements (as in a rec) is desugared to an arrow between
1052 two environments (no stack)
1053 -}
1054
1055 dsfixCmdStmts
1056 :: DsCmdEnv -- arrow combinators
1057 -> IdSet -- set of local vars available to this statement
1058 -> [Id] -- output vars of these statements
1059 -> [CmdLStmt GhcTc] -- statements to desugar
1060 -> DsM (CoreExpr, -- desugared expression
1061 DIdSet, -- subset of local vars that occur free
1062 [Id]) -- same local vars as a list
1063
1064 dsfixCmdStmts ids local_vars out_ids stmts
1065 = trimInput (dsCmdStmts ids local_vars out_ids stmts)
1066 -- TODO: Add levity polymorphism check for the resulting expression.
1067 -- But I (Richard E.) don't know enough about arrows to do so.
1068
1069 dsCmdStmts
1070 :: DsCmdEnv -- arrow combinators
1071 -> IdSet -- set of local vars available to this statement
1072 -> [Id] -- output vars of these statements
1073 -> [CmdLStmt GhcTc] -- statements to desugar
1074 -> [Id] -- list of vars in the input to these statements
1075 -> DsM (CoreExpr, -- desugared expression
1076 DIdSet) -- subset of local vars that occur free
1077
1078 dsCmdStmts ids local_vars out_ids [stmt] env_ids
1079 = dsCmdLStmt ids local_vars out_ids stmt env_ids
1080
1081 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
1082 let bound_vars = mkVarSet (collectLStmtBinders stmt)
1083 let local_vars' = bound_vars `unionVarSet` local_vars
1084 (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
1085 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
1086 return (do_compose ids
1087 (mkBigCoreVarTupTy env_ids)
1088 (mkBigCoreVarTupTy env_ids')
1089 (mkBigCoreVarTupTy out_ids)
1090 core_stmt
1091 core_stmts,
1092 fv_stmt)
1093
1094 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
1095
1096 -- Match a list of expressions against a list of patterns, left-to-right.
1097
1098 matchSimplys :: [CoreExpr] -- Scrutinees
1099 -> HsMatchContext Name -- Match kind
1100 -> [LPat GhcTc] -- Patterns they should match
1101 -> CoreExpr -- Return this if they all match
1102 -> CoreExpr -- Return this if they don't
1103 -> DsM CoreExpr
1104 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
1105 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
1106 match_code <- matchSimplys exps ctxt pats result_expr fail_expr
1107 matchSimply exp ctxt pat match_code fail_expr
1108 matchSimplys _ _ _ _ _ = panic "matchSimplys"
1109
1110 -- List of leaf expressions, with set of variables bound in each
1111
1112 leavesMatch :: LMatch GhcTc (Located (body GhcTc))
1113 -> [(Located (body GhcTc), IdSet)]
1114 leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) }))
1115 = let
1116 defined_vars = mkVarSet (collectPatsBinders pats)
1117 `unionVarSet`
1118 mkVarSet (collectLocalBinders binds)
1119 in
1120 [(body,
1121 mkVarSet (collectLStmtsBinders stmts)
1122 `unionVarSet` defined_vars)
1123 | L _ (GRHS stmts body) <- grhss]
1124
1125 -- Replace the leaf commands in a match
1126
1127 replaceLeavesMatch
1128 :: Type -- new result type
1129 -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
1130 -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
1131 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1132 LMatch GhcTc (Located (body' GhcTc))) -- updated match
1133 replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds }))
1134 = let
1135 (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1136 in
1137 (leaves', L loc (match { m_grhss = GRHSs grhss' binds }))
1138
1139 replaceLeavesGRHS
1140 :: [Located (body' GhcTc)] -- replacement leaf expressions of that type
1141 -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
1142 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1143 LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
1144 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
1145 = (leaves, L loc (GRHS stmts leaf))
1146 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
1147
1148 -- Balanced fold of a non-empty list.
1149
1150 foldb :: (a -> a -> a) -> [a] -> a
1151 foldb _ [] = error "foldb of empty list"
1152 foldb _ [x] = x
1153 foldb f xs = foldb f (fold_pairs xs)
1154 where
1155 fold_pairs [] = []
1156 fold_pairs [x] = [x]
1157 fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1158
1159 {-
1160 Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
1161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1162 The following functions to collect value variables from patterns are
1163 copied from HsUtils, with one change: we also collect the dictionary
1164 bindings (pat_binds) from ConPatOut. We need them for cases like
1165
1166 h :: Arrow a => Int -> a (Int,Int) Int
1167 h x = proc (y,z) -> case compare x y of
1168 GT -> returnA -< z+x
1169
1170 The type checker turns the case into
1171
1172 case compare x y of
1173 GT { p77 = plusInt } -> returnA -< p77 z x
1174
1175 Here p77 is a local binding for the (+) operation.
1176
1177 See comments in HsUtils for why the other version does not include
1178 these bindings.
1179 -}
1180
1181 collectPatBinders :: LPat GhcTc -> [Id]
1182 collectPatBinders pat = collectl pat []
1183
1184 collectPatsBinders :: [LPat GhcTc] -> [Id]
1185 collectPatsBinders pats = foldr collectl [] pats
1186
1187 ---------------------
1188 collectl :: LPat GhcTc -> [Id] -> [Id]
1189 -- See Note [Dictionary binders in ConPatOut]
1190 collectl (L _ pat) bndrs
1191 = go pat
1192 where
1193 go (VarPat _ (L _ var)) = var : bndrs
1194 go (WildPat _) = bndrs
1195 go (LazyPat _ pat) = collectl pat bndrs
1196 go (BangPat _ pat) = collectl pat bndrs
1197 go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
1198 go (ParPat _ pat) = collectl pat bndrs
1199
1200 go (ListPat _ pats _ _) = foldr collectl bndrs pats
1201 go (PArrPat _ pats) = foldr collectl bndrs pats
1202 go (TuplePat _ pats _) = foldr collectl bndrs pats
1203 go (SumPat _ pat _ _) = collectl pat bndrs
1204
1205 go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
1206 go (ConPatOut {pat_args=ps, pat_binds=ds}) =
1207 collectEvBinders ds
1208 ++ foldr collectl bndrs (hsConPatArgs ps)
1209 go (LitPat _ _) = bndrs
1210 go (NPat {}) = bndrs
1211 go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
1212
1213 go (SigPat _ pat) = collectl pat bndrs
1214 go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
1215 go (ViewPat _ _ pat) = collectl pat bndrs
1216 go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
1217 go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
1218
1219 collectEvBinders :: TcEvBinds -> [Id]
1220 collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
1221 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1222
1223 add_ev_bndr :: EvBind -> [Id] -> [Id]
1224 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1225 | otherwise = bs
1226 -- A worry: what about coercion variable binders??
1227
1228 collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
1229 collectLStmtsBinders = concatMap collectLStmtBinders
1230
1231 collectLStmtBinders :: LStmt GhcTc body -> [Id]
1232 collectLStmtBinders = collectStmtBinders . unLoc
1233
1234 collectStmtBinders :: Stmt GhcTc body -> [Id]
1235 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
1236 collectStmtBinders stmt = HsUtils.collectStmtBinders stmt