Fix unused-import warnings
[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 UniqDSet
56
57 data DsCmdEnv = DsCmdEnv {
58 arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
59 }
60
61 mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
62 -- See Note [CmdSyntaxTable] in HsExpr
63 mkCmdEnv tc_meths
64 = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
65
66 -- NB: Some of these lookups might fail, but that's OK if the
67 -- symbol is never used. That's why we use Maybe first and then
68 -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
69 ; let the_arr_id = assocMaybe prs arrAName
70 the_compose_id = assocMaybe prs composeAName
71 the_first_id = assocMaybe prs firstAName
72 the_app_id = assocMaybe prs appAName
73 the_choice_id = assocMaybe prs choiceAName
74 the_loop_id = assocMaybe prs loopAName
75
76 -- used as an argument in, e.g., do_premap
77 ; check_lev_poly 3 the_arr_id
78
79 -- used as an argument in, e.g., dsCmdStmt/BodyStmt
80 ; check_lev_poly 5 the_compose_id
81
82 -- used as an argument in, e.g., dsCmdStmt/BodyStmt
83 ; check_lev_poly 4 the_first_id
84
85 -- the result of the_app_id is used as an argument in, e.g.,
86 -- dsCmd/HsCmdArrApp/HsHigherOrderApp
87 ; check_lev_poly 2 the_app_id
88
89 -- used as an argument in, e.g., HsCmdIf
90 ; check_lev_poly 5 the_choice_id
91
92 -- used as an argument in, e.g., RecStmt
93 ; check_lev_poly 4 the_loop_id
94
95 ; return (meth_binds, DsCmdEnv {
96 arr_id = Var (unmaybe the_arr_id arrAName),
97 compose_id = Var (unmaybe the_compose_id composeAName),
98 first_id = Var (unmaybe the_first_id firstAName),
99 app_id = Var (unmaybe the_app_id appAName),
100 choice_id = Var (unmaybe the_choice_id choiceAName),
101 loop_id = Var (unmaybe the_loop_id loopAName)
102 }) }
103 where
104 mk_bind (std_name, expr)
105 = do { rhs <- dsExpr expr
106 ; id <- newSysLocalDs (exprType rhs) -- no check needed; these are functions
107 ; return (NonRec id rhs, (std_name, id)) }
108
109 unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
110 unmaybe (Just id) _ = id
111
112 -- returns the result type of a pi-type (that is, a forall or a function)
113 -- Note that this result type may be ill-scoped.
114 res_type :: Type -> Type
115 res_type ty = res_ty
116 where
117 (_, res_ty) = splitPiTy ty
118
119 check_lev_poly :: Int -- arity
120 -> Maybe Id -> DsM ()
121 check_lev_poly _ Nothing = return ()
122 check_lev_poly arity (Just id)
123 = dsNoLevPoly (nTimes arity res_type (idType id))
124 (text "In the result of the function" <+> quotes (ppr id))
125
126
127 -- arr :: forall b c. (b -> c) -> a b c
128 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
129 do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
130
131 -- (>>>) :: forall b c d. a b c -> a c d -> a b d
132 do_compose :: DsCmdEnv -> Type -> Type -> Type ->
133 CoreExpr -> CoreExpr -> CoreExpr
134 do_compose ids b_ty c_ty d_ty f g
135 = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
136
137 -- first :: forall b c d. a b c -> a (b,d) (c,d)
138 do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
139 do_first ids b_ty c_ty d_ty f
140 = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
141
142 -- app :: forall b c. a (a b c, b) c
143 do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
144 do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
145
146 -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
147 -- note the swapping of d and c
148 do_choice :: DsCmdEnv -> Type -> Type -> Type ->
149 CoreExpr -> CoreExpr -> CoreExpr
150 do_choice ids b_ty c_ty d_ty f g
151 = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
152
153 -- loop :: forall b d c. a (b,d) (c,d) -> a b c
154 -- note the swapping of d and c
155 do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
156 do_loop ids b_ty c_ty d_ty f
157 = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
158
159 -- premap :: forall b c d. (b -> c) -> a c d -> a b d
160 -- premap f g = arr f >>> g
161 do_premap :: DsCmdEnv -> Type -> Type -> Type ->
162 CoreExpr -> CoreExpr -> CoreExpr
163 do_premap ids b_ty c_ty d_ty f g
164 = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
165
166 mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
167 mkFailExpr ctxt ty
168 = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
169
170 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
171 mkFstExpr :: Type -> Type -> DsM CoreExpr
172 mkFstExpr a_ty b_ty = do
173 a_var <- newSysLocalDs a_ty
174 b_var <- newSysLocalDs b_ty
175 pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
176 return (Lam pair_var
177 (coreCasePair pair_var a_var b_var (Var a_var)))
178
179 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
180 mkSndExpr :: Type -> Type -> DsM CoreExpr
181 mkSndExpr a_ty b_ty = do
182 a_var <- newSysLocalDs a_ty
183 b_var <- newSysLocalDs b_ty
184 pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
185 return (Lam pair_var
186 (coreCasePair pair_var a_var b_var (Var b_var)))
187
188 {-
189 Build case analysis of a tuple. This cannot be done in the DsM monad,
190 because the list of variables is typically not yet defined.
191 -}
192
193 -- coreCaseTuple [u1..] v [x1..xn] body
194 -- = case v of v { (x1, .., xn) -> body }
195 -- But the matching may be nested if the tuple is very big
196
197 coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
198 coreCaseTuple uniqs scrut_var vars body
199 = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
200
201 coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
202 coreCasePair scrut_var var1 var2 body
203 = Case (Var scrut_var) scrut_var (exprType body)
204 [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
205
206 mkCorePairTy :: Type -> Type -> Type
207 mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
208
209 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
210 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
211
212 mkCoreUnitExpr :: CoreExpr
213 mkCoreUnitExpr = mkCoreTup []
214
215 {-
216 The input is divided into a local environment, which is a flat tuple
217 (unless it's too big), and a stack, which is a right-nested pair.
218 In general, the input has the form
219
220 ((x1,...,xn), (s1,...(sk,())...))
221
222 where xi are the environment values, and si the ones on the stack,
223 with s1 being the "top", the first one to be matched with a lambda.
224 -}
225
226 envStackType :: [Id] -> Type -> Type
227 envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
228
229 -- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
230 splitTypeAt :: Int -> Type -> ([Type], Type)
231 splitTypeAt n ty
232 | n == 0 = ([], ty)
233 | otherwise = case tcTyConAppArgs ty of
234 [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
235 _ -> pprPanic "splitTypeAt" (ppr ty)
236
237 ----------------------------------------------
238 -- buildEnvStack
239 --
240 -- ((x1,...,xn),stk)
241
242 buildEnvStack :: [Id] -> Id -> CoreExpr
243 buildEnvStack env_ids stack_id
244 = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
245
246 ----------------------------------------------
247 -- matchEnvStack
248 --
249 -- \ ((x1,...,xn),stk) -> body
250 -- =>
251 -- \ pair ->
252 -- case pair of (tup,stk) ->
253 -- case tup of (x1,...,xn) ->
254 -- body
255
256 matchEnvStack :: [Id] -- x1..xn
257 -> Id -- stk
258 -> CoreExpr -- e
259 -> DsM CoreExpr
260 matchEnvStack env_ids stack_id body = do
261 uniqs <- newUniqueSupply
262 tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
263 let match_env = coreCaseTuple uniqs tup_var env_ids body
264 pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
265 return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
266
267 ----------------------------------------------
268 -- matchEnv
269 --
270 -- \ (x1,...,xn) -> body
271 -- =>
272 -- \ tup ->
273 -- case tup of (x1,...,xn) ->
274 -- body
275
276 matchEnv :: [Id] -- x1..xn
277 -> CoreExpr -- e
278 -> DsM CoreExpr
279 matchEnv env_ids body = do
280 uniqs <- newUniqueSupply
281 tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
282 return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
283
284 ----------------------------------------------
285 -- matchVarStack
286 --
287 -- case (x1, ...(xn, s)...) -> e
288 -- =>
289 -- case z0 of (x1,z1) ->
290 -- case zn-1 of (xn,s) ->
291 -- e
292 matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
293 matchVarStack [] stack_id body = return (stack_id, body)
294 matchVarStack (param_id:param_ids) stack_id body = do
295 (tail_id, tail_code) <- matchVarStack param_ids stack_id body
296 pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
297 return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
298
299 mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
300 mkHsEnvStackExpr env_ids stack_id
301 = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
302
303 -- Translation of arrow abstraction
304
305 -- D; xs |-a c : () --> t' ---> c'
306 -- --------------------------
307 -- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'
308 --
309 -- where (xs) is the tuple of variables bound by p
310
311 dsProcExpr
312 :: LPat GhcTc
313 -> LHsCmdTop GhcTc
314 -> DsM CoreExpr
315 dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
316 (meth_binds, meth_ids) <- mkCmdEnv ids
317 let locals = mkVarSet (collectPatBinders pat)
318 (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
319 let env_ty = mkBigCoreVarTupTy env_ids
320 let env_stk_ty = mkCorePairTy env_ty unitTy
321 let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
322 fail_expr <- mkFailExpr ProcExpr env_stk_ty
323 var <- selectSimpleMatchVarL pat
324 match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
325 let pat_ty = hsLPatType pat
326 let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
327 (Lam var match_code)
328 core_cmd
329 return (mkLets meth_binds proc_code)
330 dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
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_ty arrow arg 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 `uniqDSetIntersectUniqSet` 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_ty arrow arg 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 `uniqDSetIntersectUniqSet` 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 `uniqDSetIntersectUniqSet` 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
453 = 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 `uniqDSetMinusUniqSet` 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 `uniqDSetIntersectUniqSet` 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
558 , mg_ext = MatchGroupTc arg_tys _
559 , mg_origin = origin }))
560 env_ids = do
561 stack_id <- newSysLocalDs stack_ty
562
563 -- Extract and desugar the leaf commands in the case, building tuple
564 -- expressions that will (after tagging) replace these leaves
565
566 let
567 leaves = concatMap leavesMatch matches
568 make_branch (leaf, bound_vars) = do
569 (core_leaf, _fvs, leaf_ids) <-
570 dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf
571 return ([mkHsEnvStackExpr leaf_ids stack_id],
572 envStackType leaf_ids stack_ty,
573 core_leaf)
574
575 branches <- mapM make_branch leaves
576 either_con <- dsLookupTyCon eitherTyConName
577 left_con <- dsLookupDataCon leftDataConName
578 right_con <- dsLookupDataCon rightDataConName
579 let
580 left_id = HsConLikeOut noExt (RealDataCon left_con)
581 right_id = HsConLikeOut noExt (RealDataCon right_con)
582 left_expr ty1 ty2 e = noLoc $ HsApp noExt
583 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
584 right_expr ty1 ty2 e = noLoc $ HsApp noExt
585 (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
586
587 -- Prefix each tuple with a distinct series of Left's and Right's,
588 -- in a balanced way, keeping track of the types.
589
590 merge_branches (builds1, in_ty1, core_exp1)
591 (builds2, in_ty2, core_exp2)
592 = (map (left_expr in_ty1 in_ty2) builds1 ++
593 map (right_expr in_ty1 in_ty2) builds2,
594 mkTyConApp either_con [in_ty1, in_ty2],
595 do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
596 (leaves', sum_ty, core_choices) = foldb merge_branches branches
597
598 -- Replace the commands in the case with these tagged tuples,
599 -- yielding a HsExpr Id we can feed to dsExpr.
600
601 (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
602 in_ty = envStackType env_ids stack_ty
603
604 core_body <- dsExpr (HsCase noExt exp
605 (MG { mg_alts = L l matches'
606 , mg_ext = MatchGroupTc arg_tys sum_ty
607 , mg_origin = origin }))
608 -- Note that we replace the HsCase result type by sum_ty,
609 -- which is the type of matches'
610
611 core_matches <- matchEnvStack env_ids stack_id core_body
612 return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
613 exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
614
615 -- D; ys |-a cmd : stk --> t
616 -- ----------------------------------
617 -- D; xs |-a let binds in cmd : stk --> t
618 --
619 -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
620
621 dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
622 env_ids = do
623 let
624 defined_vars = mkVarSet (collectLocalBinders binds)
625 local_vars' = defined_vars `unionVarSet` local_vars
626
627 (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
628 stack_id <- newSysLocalDs stack_ty
629 -- build a new environment, plus the stack, using the let bindings
630 core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
631 -- match the old environment and stack against the input
632 core_map <- matchEnvStack env_ids stack_id core_binds
633 return (do_premap ids
634 (envStackType env_ids stack_ty)
635 (envStackType env_ids' stack_ty)
636 res_ty
637 core_map
638 core_body,
639 exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
640
641 -- D; xs |-a ss : t
642 -- ----------------------------------
643 -- D; xs |-a do { ss } : () --> t
644 --
645 -- ---> premap (\ (env,stk) -> env) c
646
647 dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
648 env_ids = do
649 putSrcSpanDs loc $
650 dsNoLevPoly stmts_ty
651 (text "In the do-command:" <+> ppr do_block)
652 (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
653 let env_ty = mkBigCoreVarTupTy env_ids
654 core_fst <- mkFstExpr env_ty stack_ty
655 return (do_premap ids
656 (mkCorePairTy env_ty stack_ty)
657 env_ty
658 res_ty
659 core_fst
660 core_stmts,
661 env_ids')
662
663 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
664 -- D; xs |-a ci :: stki --> ti
665 -- -----------------------------------
666 -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
667
668 dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
669 let env_ty = mkBigCoreVarTupTy env_ids
670 core_op <- dsLExpr op
671 (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
672 return (mkApps (App core_op (Type env_ty)) core_args,
673 unionDVarSets fv_sets)
674
675 dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
676 (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
677 core_wrap <- dsHsWrapper wrap
678 return (core_wrap core_cmd, env_ids')
679
680 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
681
682 -- D; ys |-a c : stk --> t (ys <= xs)
683 -- ---------------------
684 -- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
685
686 dsTrimCmdArg
687 :: IdSet -- set of local vars available to this command
688 -> [Id] -- list of vars in the input to this command
689 -> LHsCmdTop GhcTc -- command argument to desugar
690 -> DsM (CoreExpr, -- desugared expression
691 DIdSet) -- subset of local vars that occur free
692 dsTrimCmdArg local_vars env_ids
693 (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
694 (meth_binds, meth_ids) <- mkCmdEnv ids
695 (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
696 stack_id <- newSysLocalDs stack_ty
697 trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
698 let
699 in_ty = envStackType env_ids stack_ty
700 in_ty' = envStackType env_ids' stack_ty
701 arg_code = if env_ids' == env_ids then core_cmd else
702 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
703 return (mkLets meth_binds arg_code, free_vars)
704 dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
705
706 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
707 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
708
709 dsfixCmd
710 :: DsCmdEnv -- arrow combinators
711 -> IdSet -- set of local vars available to this command
712 -> Type -- type of the stack (right-nested tuple)
713 -> Type -- return type of the command
714 -> LHsCmd GhcTc -- command to desugar
715 -> DsM (CoreExpr, -- desugared expression
716 DIdSet, -- subset of local vars that occur free
717 [Id]) -- the same local vars as a list, fed back
718 dsfixCmd ids local_vars stk_ty cmd_ty cmd
719 = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
720 (text "When desugaring the command:" <+> ppr cmd)
721 ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
722
723 -- Feed back the list of local variables actually used a command,
724 -- for use as the input tuple of the generated arrow.
725
726 trimInput
727 :: ([Id] -> DsM (CoreExpr, DIdSet))
728 -> DsM (CoreExpr, -- desugared expression
729 DIdSet, -- subset of local vars that occur free
730 [Id]) -- same local vars as a list, fed back to
731 -- the inner function to form the tuple of
732 -- inputs to the arrow.
733 trimInput build_arrow
734 = fixDs (\ ~(_,_,env_ids) -> do
735 (core_cmd, free_vars) <- build_arrow env_ids
736 return (core_cmd, free_vars, dVarSetElems free_vars))
737
738 {-
739 Translation of command judgements of the form
740
741 D |-a do { ss } : t
742 -}
743
744 dsCmdDo :: DsCmdEnv -- arrow combinators
745 -> IdSet -- set of local vars available to this statement
746 -> Type -- return type of the statement
747 -> [CmdLStmt GhcTc] -- statements to desugar
748 -> [Id] -- list of vars in the input to this statement
749 -- This is typically fed back,
750 -- so don't pull on it too early
751 -> DsM (CoreExpr, -- desugared expression
752 DIdSet) -- subset of local vars that occur free
753
754 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
755
756 -- D; xs |-a c : () --> t
757 -- --------------------------
758 -- D; xs |-a do { c } : t
759 --
760 -- ---> premap (\ (xs) -> ((xs), ())) c
761
762 dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
763 putSrcSpanDs loc $ dsNoLevPoly res_ty
764 (text "In the command:" <+> ppr body)
765 (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
766 let env_ty = mkBigCoreVarTupTy env_ids
767 env_var <- newSysLocalDs env_ty
768 let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
769 return (do_premap ids
770 env_ty
771 (mkCorePairTy env_ty unitTy)
772 res_ty
773 core_map
774 core_body,
775 env_ids')
776
777 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
778 let bound_vars = mkVarSet (collectLStmtBinders stmt)
779 let local_vars' = bound_vars `unionVarSet` local_vars
780 (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
781 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
782 return (do_compose ids
783 (mkBigCoreVarTupTy env_ids)
784 (mkBigCoreVarTupTy env_ids')
785 res_ty
786 core_stmt
787 core_stmts,
788 fv_stmt)
789
790 {-
791 A statement maps one local environment to another, and is represented
792 as an arrow from one tuple type to another. A statement sequence is
793 translated to a composition of such arrows.
794 -}
795
796 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
797 -> DsM (CoreExpr, DIdSet)
798 dsCmdLStmt ids local_vars out_ids cmd env_ids
799 = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
800
801 dsCmdStmt
802 :: DsCmdEnv -- arrow combinators
803 -> IdSet -- set of local vars available to this statement
804 -> [Id] -- list of vars in the output of this statement
805 -> CmdStmt GhcTc -- statement to desugar
806 -> [Id] -- list of vars in the input to this statement
807 -- This is typically fed back,
808 -- so don't pull on it too early
809 -> DsM (CoreExpr, -- desugared expression
810 DIdSet) -- subset of local vars that occur free
811
812 -- D; xs1 |-a c : () --> t
813 -- D; xs' |-a do { ss } : t'
814 -- ------------------------------
815 -- D; xs |-a do { c; ss } : t'
816 --
817 -- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
818 -- (first c >>> arr snd) >>> ss
819
820 dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
821 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
822 core_mux <- matchEnv env_ids
823 (mkCorePairExpr
824 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
825 (mkBigCoreVarTup out_ids))
826 let
827 in_ty = mkBigCoreVarTupTy env_ids
828 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
829 out_ty = mkBigCoreVarTupTy out_ids
830 before_c_ty = mkCorePairTy in_ty1 out_ty
831 after_c_ty = mkCorePairTy c_ty out_ty
832 dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
833 snd_fn <- mkSndExpr c_ty out_ty
834 return (do_premap ids in_ty before_c_ty out_ty core_mux $
835 do_compose ids before_c_ty after_c_ty out_ty
836 (do_first ids in_ty1 c_ty out_ty core_cmd) $
837 do_arr ids after_c_ty out_ty snd_fn,
838 extendDVarSetList fv_cmd out_ids)
839
840 -- D; xs1 |-a c : () --> t
841 -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
842 -- -----------------------------------
843 -- D; xs |-a do { p <- c; ss } : t'
844 --
845 -- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
846 -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
847 --
848 -- It would be simpler and more consistent to do this using second,
849 -- but that's likely to be defined in terms of first.
850
851 dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
852 let pat_ty = hsLPatType pat
853 (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
854 let pat_vars = mkVarSet (collectPatBinders pat)
855 let
856 env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
857 env_ty2 = mkBigCoreVarTupTy env_ids2
858
859 -- multiplexing function
860 -- \ (xs) -> (((xs1),()),(xs2))
861
862 core_mux <- matchEnv env_ids
863 (mkCorePairExpr
864 (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
865 (mkBigCoreVarTup env_ids2))
866
867 -- projection function
868 -- \ (p, (xs2)) -> (zs)
869
870 env_id <- newSysLocalDs env_ty2
871 uniqs <- newUniqueSupply
872 let
873 after_c_ty = mkCorePairTy pat_ty env_ty2
874 out_ty = mkBigCoreVarTupTy out_ids
875 body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
876
877 fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
878 pat_id <- selectSimpleMatchVarL pat
879 match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
880 pair_id <- newSysLocalDs after_c_ty
881 let
882 proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
883
884 -- put it all together
885 let
886 in_ty = mkBigCoreVarTupTy env_ids
887 in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
888 in_ty2 = mkBigCoreVarTupTy env_ids2
889 before_c_ty = mkCorePairTy in_ty1 in_ty2
890 return (do_premap ids in_ty before_c_ty out_ty core_mux $
891 do_compose ids before_c_ty after_c_ty out_ty
892 (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
893 do_arr ids after_c_ty out_ty proj_expr,
894 fv_cmd `unionDVarSet` (mkDVarSet out_ids `uniqDSetMinusUniqSet` pat_vars))
895
896 -- D; xs' |-a do { ss } : t
897 -- --------------------------------------
898 -- D; xs |-a do { let binds; ss } : t
899 --
900 -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
901
902 dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
903 -- build a new environment using the let bindings
904 core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
905 -- match the old environment against the input
906 core_map <- matchEnv env_ids core_binds
907 return (do_arr ids
908 (mkBigCoreVarTupTy env_ids)
909 (mkBigCoreVarTupTy out_ids)
910 core_map,
911 exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
912
913 -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
914 -- D; xs' |-a do { ss' } : t
915 -- ------------------------------------
916 -- D; xs |-a do { rec ss; ss' } : t
917 --
918 -- xs1 = xs' /\ defs(ss)
919 -- xs2 = xs' - defs(ss)
920 -- ys1 = ys - defs(ss)
921 -- ys2 = ys /\ defs(ss)
922 --
923 -- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
924 -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
925 -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
926
927 dsCmdStmt ids local_vars out_ids
928 (RecStmt { recS_stmts = stmts
929 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
930 , recS_ext = RecStmtTc { recS_later_rets = later_rets
931 , recS_rec_rets = rec_rets } })
932 env_ids = do
933 let
934 later_ids_set = mkVarSet later_ids
935 env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
936 env2_id_set = mkDVarSet env2_ids
937 env2_ty = mkBigCoreVarTupTy env2_ids
938
939 -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
940
941 uniqs <- newUniqueSupply
942 env2_id <- newSysLocalDs env2_ty
943 let
944 later_ty = mkBigCoreVarTupTy later_ids
945 post_pair_ty = mkCorePairTy later_ty env2_ty
946 post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
947
948 post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
949
950 --- loop (...)
951
952 (core_loop, env1_id_set, env1_ids)
953 <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
954
955 -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
956
957 let
958 env1_ty = mkBigCoreVarTupTy env1_ids
959 pre_pair_ty = mkCorePairTy env1_ty env2_ty
960 pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
961 (mkBigCoreVarTup env2_ids)
962
963 pre_loop_fn <- matchEnv env_ids pre_loop_body
964
965 -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
966
967 let
968 env_ty = mkBigCoreVarTupTy env_ids
969 out_ty = mkBigCoreVarTupTy out_ids
970 core_body = do_premap ids env_ty pre_pair_ty out_ty
971 pre_loop_fn
972 (do_compose ids pre_pair_ty post_pair_ty out_ty
973 (do_first ids env1_ty later_ty env2_ty
974 core_loop)
975 (do_arr ids post_pair_ty out_ty
976 post_loop_fn))
977
978 return (core_body, env1_id_set `unionDVarSet` env2_id_set)
979
980 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
981
982 -- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
983 -- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
984
985 dsRecCmd
986 :: DsCmdEnv -- arrow combinators
987 -> IdSet -- set of local vars available to this statement
988 -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd
989 -> [Id] -- list of vars defined here and used later
990 -> [HsExpr GhcTc] -- expressions corresponding to later_ids
991 -> [Id] -- list of vars fed back through the loop
992 -> [HsExpr GhcTc] -- expressions corresponding to rec_ids
993 -> DsM (CoreExpr, -- desugared statement
994 DIdSet, -- subset of local vars that occur free
995 [Id]) -- same local vars as a list
996
997 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
998 let
999 later_id_set = mkVarSet later_ids
1000 rec_id_set = mkVarSet rec_ids
1001 local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
1002
1003 -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
1004
1005 core_later_rets <- mapM dsExpr later_rets
1006 core_rec_rets <- mapM dsExpr rec_rets
1007 let
1008 -- possibly polymorphic version of vars of later_ids and rec_ids
1009 out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
1010 out_ty = mkBigCoreVarTupTy out_ids
1011
1012 later_tuple = mkBigCoreTup core_later_rets
1013 later_ty = mkBigCoreVarTupTy later_ids
1014
1015 rec_tuple = mkBigCoreTup core_rec_rets
1016 rec_ty = mkBigCoreVarTupTy rec_ids
1017
1018 out_pair = mkCorePairExpr later_tuple rec_tuple
1019 out_pair_ty = mkCorePairTy later_ty rec_ty
1020
1021 mk_pair_fn <- matchEnv out_ids out_pair
1022
1023 -- ss
1024
1025 (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
1026
1027 -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
1028
1029 rec_id <- newSysLocalDs rec_ty
1030 let
1031 env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
1032 env1_ids = dVarSetElems env1_id_set
1033 env1_ty = mkBigCoreVarTupTy env1_ids
1034 in_pair_ty = mkCorePairTy env1_ty rec_ty
1035 core_body = mkBigCoreTup (map selectVar env_ids)
1036 where
1037 selectVar v
1038 | v `elemVarSet` rec_id_set
1039 = mkTupleSelector rec_ids v rec_id (Var rec_id)
1040 | otherwise = Var v
1041
1042 squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
1043
1044 -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
1045
1046 let
1047 env_ty = mkBigCoreVarTupTy env_ids
1048 core_loop = do_loop ids env1_ty later_ty rec_ty
1049 (do_premap ids in_pair_ty env_ty out_pair_ty
1050 squash_pair_fn
1051 (do_compose ids env_ty out_ty out_pair_ty
1052 core_stmts
1053 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
1054
1055 return (core_loop, env1_id_set, env1_ids)
1056
1057 {-
1058 A sequence of statements (as in a rec) is desugared to an arrow between
1059 two environments (no stack)
1060 -}
1061
1062 dsfixCmdStmts
1063 :: DsCmdEnv -- arrow combinators
1064 -> IdSet -- set of local vars available to this statement
1065 -> [Id] -- output vars of these statements
1066 -> [CmdLStmt GhcTc] -- statements to desugar
1067 -> DsM (CoreExpr, -- desugared expression
1068 DIdSet, -- subset of local vars that occur free
1069 [Id]) -- same local vars as a list
1070
1071 dsfixCmdStmts ids local_vars out_ids stmts
1072 = trimInput (dsCmdStmts ids local_vars out_ids stmts)
1073 -- TODO: Add levity polymorphism check for the resulting expression.
1074 -- But I (Richard E.) don't know enough about arrows to do so.
1075
1076 dsCmdStmts
1077 :: DsCmdEnv -- arrow combinators
1078 -> IdSet -- set of local vars available to this statement
1079 -> [Id] -- output vars of these statements
1080 -> [CmdLStmt GhcTc] -- statements to desugar
1081 -> [Id] -- list of vars in the input to these statements
1082 -> DsM (CoreExpr, -- desugared expression
1083 DIdSet) -- subset of local vars that occur free
1084
1085 dsCmdStmts ids local_vars out_ids [stmt] env_ids
1086 = dsCmdLStmt ids local_vars out_ids stmt env_ids
1087
1088 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
1089 let bound_vars = mkVarSet (collectLStmtBinders stmt)
1090 let local_vars' = bound_vars `unionVarSet` local_vars
1091 (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
1092 (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
1093 return (do_compose ids
1094 (mkBigCoreVarTupTy env_ids)
1095 (mkBigCoreVarTupTy env_ids')
1096 (mkBigCoreVarTupTy out_ids)
1097 core_stmt
1098 core_stmts,
1099 fv_stmt)
1100
1101 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
1102
1103 -- Match a list of expressions against a list of patterns, left-to-right.
1104
1105 matchSimplys :: [CoreExpr] -- Scrutinees
1106 -> HsMatchContext Name -- Match kind
1107 -> [LPat GhcTc] -- Patterns they should match
1108 -> CoreExpr -- Return this if they all match
1109 -> CoreExpr -- Return this if they don't
1110 -> DsM CoreExpr
1111 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
1112 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
1113 match_code <- matchSimplys exps ctxt pats result_expr fail_expr
1114 matchSimply exp ctxt pat match_code fail_expr
1115 matchSimplys _ _ _ _ _ = panic "matchSimplys"
1116
1117 -- List of leaf expressions, with set of variables bound in each
1118
1119 leavesMatch :: LMatch GhcTc (Located (body GhcTc))
1120 -> [(Located (body GhcTc), IdSet)]
1121 leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) }))
1122 = let
1123 defined_vars = mkVarSet (collectPatsBinders pats)
1124 `unionVarSet`
1125 mkVarSet (collectLocalBinders binds)
1126 in
1127 [(body,
1128 mkVarSet (collectLStmtsBinders stmts)
1129 `unionVarSet` defined_vars)
1130 | L _ (GRHS _ stmts body) <- grhss]
1131 leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch"
1132 leavesMatch (L _ (XMatch _)) = panic "leavesMatch"
1133
1134 -- Replace the leaf commands in a match
1135
1136 replaceLeavesMatch
1137 :: Type -- new result type
1138 -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
1139 -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
1140 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1141 LMatch GhcTc (Located (body' GhcTc))) -- updated match
1142 replaceLeavesMatch _res_ty leaves
1143 (L loc match@(Match { m_grhss = GRHSs x grhss binds }))
1144 = let
1145 (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1146 in
1147 (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
1148 replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _)))
1149 = panic "replaceLeavesMatch"
1150 replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch"
1151
1152 replaceLeavesGRHS
1153 :: [Located (body' GhcTc)] -- replacement leaf expressions of that type
1154 -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
1155 -> ([Located (body' GhcTc)], -- remaining leaf expressions
1156 LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
1157 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
1158 = (leaves, L loc (GRHS x stmts leaf))
1159 replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS"
1160 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
1161
1162 -- Balanced fold of a non-empty list.
1163
1164 foldb :: (a -> a -> a) -> [a] -> a
1165 foldb _ [] = error "foldb of empty list"
1166 foldb _ [x] = x
1167 foldb f xs = foldb f (fold_pairs xs)
1168 where
1169 fold_pairs [] = []
1170 fold_pairs [x] = [x]
1171 fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1172
1173 {-
1174 Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
1175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1176 The following functions to collect value variables from patterns are
1177 copied from HsUtils, with one change: we also collect the dictionary
1178 bindings (pat_binds) from ConPatOut. We need them for cases like
1179
1180 h :: Arrow a => Int -> a (Int,Int) Int
1181 h x = proc (y,z) -> case compare x y of
1182 GT -> returnA -< z+x
1183
1184 The type checker turns the case into
1185
1186 case compare x y of
1187 GT { p77 = plusInt } -> returnA -< p77 z x
1188
1189 Here p77 is a local binding for the (+) operation.
1190
1191 See comments in HsUtils for why the other version does not include
1192 these bindings.
1193 -}
1194
1195 collectPatBinders :: LPat GhcTc -> [Id]
1196 collectPatBinders pat = collectl pat []
1197
1198 collectPatsBinders :: [LPat GhcTc] -> [Id]
1199 collectPatsBinders pats = foldr collectl [] pats
1200
1201 ---------------------
1202 collectl :: LPat GhcTc -> [Id] -> [Id]
1203 -- See Note [Dictionary binders in ConPatOut]
1204 collectl (L _ pat) bndrs
1205 = go pat
1206 where
1207 go (VarPat _ (L _ var)) = var : bndrs
1208 go (WildPat _) = bndrs
1209 go (LazyPat _ pat) = collectl pat bndrs
1210 go (BangPat _ pat) = collectl pat bndrs
1211 go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
1212 go (ParPat _ pat) = collectl pat bndrs
1213
1214 go (ListPat _ pats) = foldr collectl bndrs pats
1215 go (TuplePat _ pats _) = foldr collectl bndrs pats
1216 go (SumPat _ pat _ _) = collectl pat bndrs
1217
1218 go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
1219 go (ConPatOut {pat_args=ps, pat_binds=ds}) =
1220 collectEvBinders ds
1221 ++ foldr collectl bndrs (hsConPatArgs ps)
1222 go (LitPat _ _) = bndrs
1223 go (NPat {}) = bndrs
1224 go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
1225
1226 go (SigPat _ pat _) = collectl pat bndrs
1227 go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
1228 go (ViewPat _ _ pat) = collectl pat bndrs
1229 go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
1230 go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
1231
1232 collectEvBinders :: TcEvBinds -> [Id]
1233 collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
1234 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1235
1236 add_ev_bndr :: EvBind -> [Id] -> [Id]
1237 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1238 | otherwise = bs
1239 -- A worry: what about coercion variable binders??
1240
1241 collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
1242 collectLStmtsBinders = concatMap collectLStmtBinders
1243
1244 collectLStmtBinders :: LStmt GhcTc body -> [Id]
1245 collectLStmtBinders = collectStmtBinders . unLoc
1246
1247 collectStmtBinders :: Stmt GhcTc body -> [Id]
1248 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
1249 collectStmtBinders stmt = HsUtils.collectStmtBinders stmt