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