<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>deSugar/DsArrows.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Desugaring arrow commands
\begin{code}
<pre><a name="line-1"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>DsArrows</span> <span class='hs-layout'>(</span> <span class='hs-varid'>dsProcExpr</span> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-2"></a>
<a name="line-3"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Match</span>
<a name="line-6"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsUtils</span>
<a name="line-7"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsMonad</span>
<a name="line-8"></a>
<a name="line-9"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>HsSyn</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectPatBinders</span><span class='hs-layout'>,</span> <span class='hs-varid'>collectLocatedPatBinders</span><span class='hs-layout'>,</span> <span class='hs-varid'>collectl</span><span class='hs-layout'>,</span>
<a name="line-10"></a> <span class='hs-varid'>collectPatsBinders</span><span class='hs-layout'>,</span> <span class='hs-varid'>collectLocatedPatsBinders</span><span class='hs-layout'>)</span>
<a name="line-11"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcHsSyn</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-comment'>-- NB: The desugarer, which straddles the source and Core worlds, sometimes</span>
<a name="line-14"></a><span class='hs-comment'>-- needs to see source types (newtypes etc), and sometimes not</span>
<a name="line-15"></a><span class='hs-comment'>-- So WATCH OUT; check each use of split*Ty functions.</span>
<a name="line-16"></a><span class='hs-comment'>-- Sigh. This is a pain.</span>
<a name="line-17"></a>
<a name="line-18"></a><span class='hs-keyword'>import</span> <span class='hs-comment'>{-# SOURCE #-}</span> <span class='hs-conid'>DsExpr</span> <span class='hs-layout'>(</span> <span class='hs-varid'>dsExpr</span><span class='hs-layout'>,</span> <span class='hs-varid'>dsLExpr</span><span class='hs-layout'>,</span> <span class='hs-varid'>dsLocalBinds</span> <span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcType</span>
<a name="line-21"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Type</span>
<a name="line-22"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSyn</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreFVs</span>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreUtils</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MkCore</span>
<a name="line-26"></a>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Name</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Id</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrelInfo</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DataCon</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TysWiredIn</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>BasicTypes</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrelNames</span>
<a name="line-35"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
<a name="line-36"></a>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>VarSet</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>SrcLoc</span>
<a name="line-39"></a>
<a name="line-40"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>List</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="DsCmdEnv"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-layout'>{</span>
<a name="line-2"></a> <span class='hs-varid'>meth_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBind</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-3"></a> <span class='hs-varid'>arr_id</span><span class='hs-layout'>,</span> <span class='hs-varid'>compose_id</span><span class='hs-layout'>,</span> <span class='hs-varid'>first_id</span><span class='hs-layout'>,</span> <span class='hs-varid'>app_id</span><span class='hs-layout'>,</span> <span class='hs-varid'>choice_id</span><span class='hs-layout'>,</span> <span class='hs-varid'>loop_id</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-4"></a> <span class='hs-layout'>}</span>
<a name="line-5"></a>
<a name="line-6"></a><a name="mkCmdEnv"></a><span class='hs-definition'>mkCmdEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SyntaxTable</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>DsCmdEnv</span>
<a name="line-7"></a><span class='hs-definition'>mkCmdEnv</span> <span class='hs-varid'>ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-8"></a> <span class='hs-layout'>(</span><span class='hs-varid'>meth_binds</span><span class='hs-layout'>,</span> <span class='hs-varid'>ds_meths</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsSyntaxTable</span> <span class='hs-varid'>ids</span>
<a name="line-9"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-layout'>{</span>
<a name="line-10"></a> <span class='hs-varid'>meth_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>meth_binds</span><span class='hs-layout'>,</span>
<a name="line-11"></a> <span class='hs-varid'>arr_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>arrAName</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-12"></a> <span class='hs-varid'>compose_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>composeAName</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-13"></a> <span class='hs-varid'>first_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>firstAName</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-14"></a> <span class='hs-varid'>app_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>appAName</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-15"></a> <span class='hs-varid'>choice_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>choiceAName</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-16"></a> <span class='hs-varid'>loop_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupEvidence</span> <span class='hs-varid'>ds_meths</span> <span class='hs-varid'>loopAName</span><span class='hs-layout'>)</span>
<a name="line-17"></a> <span class='hs-layout'>}</span>
<a name="line-18"></a>
<a name="line-19"></a><a name="bindCmdEnv"></a><span class='hs-definition'>bindCmdEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-20"></a><span class='hs-definition'>bindCmdEnv</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-conid'>Let</span> <span class='hs-varid'>body</span> <span class='hs-layout'>(</span><span class='hs-varid'>meth_binds</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span>
<a name="line-21"></a>
<a name="line-22"></a><a name="do_arr"></a><span class='hs-comment'>-- arr :: forall b c. (b -> c) -> a b c</span>
<a name="line-23"></a><span class='hs-definition'>do_arr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-24"></a><span class='hs-definition'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>arr_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>f</span><span class='hs-keyglyph'>]</span>
<a name="line-25"></a>
<a name="line-26"></a><a name="do_compose"></a><span class='hs-comment'>-- (>>>) :: forall b c d. a b c -> a c d -> a b d</span>
<a name="line-27"></a><span class='hs-definition'>do_compose</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span>
<a name="line-28"></a> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-29"></a><span class='hs-definition'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-varid'>f</span> <span class='hs-varid'>g</span>
<a name="line-30"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>compose_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>d_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>f</span><span class='hs-layout'>,</span> <span class='hs-varid'>g</span><span class='hs-keyglyph'>]</span>
<a name="line-31"></a>
<a name="line-32"></a><a name="do_first"></a><span class='hs-comment'>-- first :: forall b c d. a b c -> a (b,d) (c,d)</span>
<a name="line-33"></a><span class='hs-definition'>do_first</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-34"></a><span class='hs-definition'>do_first</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-varid'>f</span>
<a name="line-35"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>first_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>d_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>f</span><span class='hs-keyglyph'>]</span>
<a name="line-36"></a>
<a name="line-37"></a><a name="do_app"></a><span class='hs-comment'>-- app :: forall b c. a (a b c, b) c</span>
<a name="line-38"></a><span class='hs-definition'>do_app</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-39"></a><span class='hs-definition'>do_app</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>app_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-keyglyph'>]</span>
<a name="line-40"></a>
<a name="line-41"></a><a name="do_choice"></a><span class='hs-comment'>-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d</span>
<a name="line-42"></a><span class='hs-comment'>-- note the swapping of d and c</span>
<a name="line-43"></a><span class='hs-definition'>do_choice</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span>
<a name="line-44"></a> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-45"></a><span class='hs-definition'>do_choice</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-varid'>f</span> <span class='hs-varid'>g</span>
<a name="line-46"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>choice_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>d_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>f</span><span class='hs-layout'>,</span> <span class='hs-varid'>g</span><span class='hs-keyglyph'>]</span>
<a name="line-47"></a>
<a name="line-48"></a><a name="do_loop"></a><span class='hs-comment'>-- loop :: forall b d c. a (b,d) (c,d) -> a b c</span>
<a name="line-49"></a><span class='hs-comment'>-- note the swapping of d and c</span>
<a name="line-50"></a><span class='hs-definition'>do_loop</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-51"></a><span class='hs-definition'>do_loop</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-varid'>f</span>
<a name="line-52"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>loop_id</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>d_ty</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>f</span><span class='hs-keyglyph'>]</span>
<a name="line-53"></a>
<a name="line-54"></a><a name="do_map_arrow"></a><span class='hs-comment'>-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d</span>
<a name="line-55"></a><span class='hs-definition'>do_map_arrow</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span>
<a name="line-56"></a> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-57"></a><span class='hs-definition'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-varid'>f</span> <span class='hs-varid'>c</span>
<a name="line-58"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>d_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>b_ty</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varid'>c</span>
<a name="line-59"></a>
<a name="line-60"></a><a name="mkFailExpr"></a><span class='hs-definition'>mkFailExpr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HsMatchContext</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-61"></a><span class='hs-definition'>mkFailExpr</span> <span class='hs-varid'>ctxt</span> <span class='hs-varid'>ty</span>
<a name="line-62"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkErrorAppDs</span> <span class='hs-varid'>pAT_ERROR_ID</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>matchContextErrString</span> <span class='hs-varid'>ctxt</span><span class='hs-layout'>)</span>
<a name="line-63"></a>
<a name="line-64"></a><a name="mkSndExpr"></a><span class='hs-comment'>-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b</span>
<a name="line-65"></a><span class='hs-definition'>mkSndExpr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-66"></a><span class='hs-definition'>mkSndExpr</span> <span class='hs-varid'>a_ty</span> <span class='hs-varid'>b_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-67"></a> <span class='hs-varid'>a_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>a_ty</span>
<a name="line-68"></a> <span class='hs-varid'>b_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>b_ty</span>
<a name="line-69"></a> <span class='hs-varid'>pair_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>a_ty</span> <span class='hs-varid'>b_ty</span><span class='hs-layout'>)</span>
<a name="line-70"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>pair_var</span>
<a name="line-71"></a> <span class='hs-layout'>(</span><span class='hs-varid'>coreCasePair</span> <span class='hs-varid'>pair_var</span> <span class='hs-varid'>a_var</span> <span class='hs-varid'>b_var</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>b_var</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
</pre>\end{code}
Build case analysis of a tuple. This cannot be done in the DsM monad,
because the list of variables is typically not yet defined.
\begin{code}
<pre><a name="line-1"></a><span class='hs-comment'>-- coreCaseTuple [u1..] v [x1..xn] body</span>
<a name="line-2"></a><span class='hs-comment'>-- = case v of v { (x1, .., xn) -> body }</span>
<a name="line-3"></a><span class='hs-comment'>-- But the matching may be nested if the tuple is very big</span>
<a name="line-4"></a>
<a name="line-5"></a><a name="coreCaseTuple"></a><span class='hs-definition'>coreCaseTuple</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>UniqSupply</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-6"></a><span class='hs-definition'>coreCaseTuple</span> <span class='hs-varid'>uniqs</span> <span class='hs-varid'>scrut_var</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>body</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTupleCase</span> <span class='hs-varid'>uniqs</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>body</span> <span class='hs-varid'>scrut_var</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>scrut_var</span><span class='hs-layout'>)</span>
<a name="line-8"></a>
<a name="line-9"></a><a name="coreCasePair"></a><span class='hs-definition'>coreCasePair</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-10"></a><span class='hs-definition'>coreCasePair</span> <span class='hs-varid'>scrut_var</span> <span class='hs-varid'>var1</span> <span class='hs-varid'>var2</span> <span class='hs-varid'>body</span>
<a name="line-11"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Case</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>scrut_var</span><span class='hs-layout'>)</span> <span class='hs-varid'>scrut_var</span> <span class='hs-layout'>(</span><span class='hs-varid'>exprType</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-12"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>tupleCon</span> <span class='hs-conid'>Boxed</span> <span class='hs-num'>2</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>var1</span><span class='hs-layout'>,</span> <span class='hs-varid'>var2</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="mkCorePairTy"></a><span class='hs-definition'>mkCorePairTy</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-2"></a><span class='hs-definition'>mkCorePairTy</span> <span class='hs-varid'>t1</span> <span class='hs-varid'>t2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCoreTupTy</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>t1</span><span class='hs-layout'>,</span> <span class='hs-varid'>t2</span><span class='hs-keyglyph'>]</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="mkCorePairExpr"></a><span class='hs-definition'>mkCorePairExpr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-5"></a><span class='hs-definition'>mkCorePairExpr</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCoreTup</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>e1</span><span class='hs-layout'>,</span> <span class='hs-varid'>e2</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, each element of which is paired
with the stack in turn. In general, the input has the form
(...((x1,...,xn),s1),...sk)
where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.
\begin{code}
<pre><a name="line-1"></a><a name="envStackType"></a><span class='hs-definition'>envStackType</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-2"></a><span class='hs-definition'>envStackType</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>stack_tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-varid'>stack_tys</span>
<a name="line-3"></a>
<a name="line-4"></a><span class='hs-comment'>----------------------------------------------</span>
<a name="line-5"></a><span class='hs-comment'>-- buildEnvStack</span>
<a name="line-6"></a><span class='hs-comment'>--</span>
<a name="line-7"></a><span class='hs-comment'>-- (...((x1,...,xn),s1),...sk)</span>
<a name="line-8"></a>
<a name="line-9"></a><a name="buildEnvStack"></a><span class='hs-definition'>buildEnvStack</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-10"></a><span class='hs-definition'>buildEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span>
<a name="line-11"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl</span> <span class='hs-varid'>mkCorePairExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-comment'>----------------------------------------------</span>
<a name="line-14"></a><span class='hs-comment'>-- matchEnvStack</span>
<a name="line-15"></a><span class='hs-comment'>--</span>
<a name="line-16"></a><span class='hs-comment'>-- \ (...((x1,...,xn),s1),...sk) -> e</span>
<a name="line-17"></a><span class='hs-comment'>-- =></span>
<a name="line-18"></a><span class='hs-comment'>-- \ zk -></span>
<a name="line-19"></a><span class='hs-comment'>-- case zk of (zk-1,sk) -></span>
<a name="line-20"></a><span class='hs-comment'>-- ...</span>
<a name="line-21"></a><span class='hs-comment'>-- case z1 of (z0,s1) -></span>
<a name="line-22"></a><span class='hs-comment'>-- case z0 of (x1,...,xn) -></span>
<a name="line-23"></a><span class='hs-comment'>-- e</span>
<a name="line-24"></a>
<a name="line-25"></a><a name="matchEnvStack"></a><span class='hs-definition'>matchEnvStack</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- x1..xn</span>
<a name="line-26"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- s1..sk</span>
<a name="line-27"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- e</span>
<a name="line-28"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-29"></a><span class='hs-definition'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-30"></a> <span class='hs-varid'>uniqs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUniqueSupply</span>
<a name="line-31"></a> <span class='hs-varid'>tup_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-varid'>matchVarStack</span> <span class='hs-varid'>tup_var</span> <span class='hs-varid'>stack_ids</span>
<a name="line-33"></a> <span class='hs-layout'>(</span><span class='hs-varid'>coreCaseTuple</span> <span class='hs-varid'>uniqs</span> <span class='hs-varid'>tup_var</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-34"></a>
<a name="line-35"></a>
<a name="line-36"></a><span class='hs-comment'>----------------------------------------------</span>
<a name="line-37"></a><span class='hs-comment'>-- matchVarStack</span>
<a name="line-38"></a><span class='hs-comment'>--</span>
<a name="line-39"></a><span class='hs-comment'>-- \ (...(z0,s1),...sk) -> e</span>
<a name="line-40"></a><span class='hs-comment'>-- =></span>
<a name="line-41"></a><span class='hs-comment'>-- \ zk -></span>
<a name="line-42"></a><span class='hs-comment'>-- case zk of (zk-1,sk) -></span>
<a name="line-43"></a><span class='hs-comment'>-- ...</span>
<a name="line-44"></a><span class='hs-comment'>-- case z1 of (z0,s1) -></span>
<a name="line-45"></a><span class='hs-comment'>-- e</span>
<a name="line-46"></a>
<a name="line-47"></a><a name="matchVarStack"></a><span class='hs-definition'>matchVarStack</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- z0</span>
<a name="line-48"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- s1..sk</span>
<a name="line-49"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- e</span>
<a name="line-50"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-51"></a><span class='hs-definition'>matchVarStack</span> <span class='hs-varid'>env_id</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>body</span>
<a name="line-52"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>env_id</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-53"></a><span class='hs-definition'>matchVarStack</span> <span class='hs-varid'>env_id</span> <span class='hs-layout'>(</span><span class='hs-varid'>stack_id</span><span class='hs-conop'>:</span><span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-54"></a> <span class='hs-varid'>pair_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>env_id</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>stack_id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-55"></a> <span class='hs-varid'>matchVarStack</span> <span class='hs-varid'>pair_id</span> <span class='hs-varid'>stack_ids</span>
<a name="line-56"></a> <span class='hs-layout'>(</span><span class='hs-varid'>coreCasePair</span> <span class='hs-varid'>pair_id</span> <span class='hs-varid'>env_id</span> <span class='hs-varid'>stack_id</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="mkHsEnvStackExpr"></a><span class='hs-definition'>mkHsEnvStackExpr</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a><span class='hs-definition'>mkHsEnvStackExpr</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mkLHsTupleExpr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkLHsVarTuple</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span>
</pre>\end{code}
Translation of arrow abstraction
\begin{code}
<pre><a name="line-1"></a>
<a name="line-2"></a><span class='hs-comment'>-- A | xs |- c :: [] t' ---> c'</span>
<a name="line-3"></a><span class='hs-comment'>-- --------------------------</span>
<a name="line-4"></a><span class='hs-comment'>-- A |- proc p -> c :: a t t' ---> arr (\ p -> (xs)) >>> c'</span>
<a name="line-5"></a><span class='hs-comment'>--</span>
<a name="line-6"></a><span class='hs-comment'>-- where (xs) is the tuple of variables bound by p</span>
<a name="line-7"></a>
<a name="line-8"></a><a name="dsProcExpr"></a><span class='hs-definition'>dsProcExpr</span>
<a name="line-9"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span>
<a name="line-10"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsCmdTop</span> <span class='hs-conid'>Id</span>
<a name="line-11"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-12"></a><span class='hs-definition'>dsProcExpr</span> <span class='hs-varid'>pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsCmdTop</span> <span class='hs-varid'>cmd</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-13"></a> <span class='hs-varid'>meth_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkCmdEnv</span> <span class='hs-varid'>ids</span>
<a name="line-14"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>locals</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectPatBinders</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-sel'>_free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>locals</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-16"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>env_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-17"></a> <span class='hs-varid'>fail_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkFailExpr</span> <span class='hs-conid'>ProcExpr</span> <span class='hs-varid'>env_ty</span>
<a name="line-18"></a> <span class='hs-varid'>var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>selectSimpleMatchVarL</span> <span class='hs-varid'>pat</span>
<a name="line-19"></a> <span class='hs-varid'>match_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchSimply</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span> <span class='hs-conid'>ProcExpr</span> <span class='hs-varid'>pat</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-varid'>fail_expr</span>
<a name="line-20"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>pat_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>hsLPatType</span> <span class='hs-varid'>pat</span>
<a name="line-21"></a> <span class='hs-varid'>proc_code</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>pat_ty</span> <span class='hs-varid'>env_ty</span> <span class='hs-varid'>cmd_ty</span>
<a name="line-22"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>var</span> <span class='hs-varid'>match_code</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-varid'>core_cmd</span>
<a name="line-24"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>bindCmdEnv</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>proc_code</span><span class='hs-layout'>)</span>
<a name="line-25"></a><span class='hs-definition'>dsProcExpr</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>c</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"dsProcExpr"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>c</span><span class='hs-layout'>)</span>
</pre>\end{code}
Translation of command judgements of the form
A | xs |- c :: [ts] t
\begin{code}
<pre><a name="line-1"></a><a name="dsLCmd"></a><span class='hs-definition'>dsLCmd</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsCmd</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span>
<a name="line-3"></a><span class='hs-definition'>dsLCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>)</span>
<a name="line-5"></a>
<a name="line-6"></a><a name="dsCmd"></a><span class='hs-definition'>dsCmd</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-7"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this command</span>
<a name="line-8"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the input to this command</span>
<a name="line-9"></a> <span class='hs-comment'>-- This is typically fed back,</span>
<a name="line-10"></a> <span class='hs-comment'>-- so don't pull on it too early</span>
<a name="line-11"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- type of the stack</span>
<a name="line-12"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- return type of the command</span>
<a name="line-13"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>HsCmd</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- command to desugar</span>
<a name="line-14"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-15"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-16"></a>
<a name="line-17"></a><span class='hs-comment'>-- A |- f :: a (t*ts) t'</span>
<a name="line-18"></a><span class='hs-comment'>-- A, xs |- arg :: t</span>
<a name="line-19"></a><span class='hs-comment'>-- -----------------------------</span>
<a name="line-20"></a><span class='hs-comment'>-- A | xs |- f -< arg :: [ts] t'</span>
<a name="line-21"></a><span class='hs-comment'>--</span>
<a name="line-22"></a><span class='hs-comment'>-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f</span>
<a name="line-23"></a>
<a name="line-24"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span>
<a name="line-25"></a> <span class='hs-layout'>(</span><span class='hs-conid'>HsArrApp</span> <span class='hs-varid'>arrow</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arrow_ty</span> <span class='hs-conid'>HsFirstOrderApp</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-26"></a> <span class='hs-keyword'>let</span>
<a name="line-27"></a> <span class='hs-layout'>(</span><span class='hs-varid'>a_arg_ty</span><span class='hs-layout'>,</span> <span class='hs-sel'>_res_ty'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcSplitAppTy</span> <span class='hs-varid'>arrow_ty</span>
<a name="line-28"></a> <span class='hs-layout'>(</span><span class='hs-sel'>_a_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_ty</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcSplitAppTy</span> <span class='hs-varid'>a_arg_ty</span>
<a name="line-29"></a> <span class='hs-varid'>core_arrow</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>arrow</span>
<a name="line-30"></a> <span class='hs-varid'>core_arg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>arg</span>
<a name="line-31"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-32"></a> <span class='hs-varid'>core_make_arg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span>
<a name="line-33"></a> <span class='hs-layout'>(</span><span class='hs-varid'>foldl</span> <span class='hs-varid'>mkCorePairExpr</span> <span class='hs-varid'>core_arg</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span>
<a name="line-35"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-varid'>arg_ty</span>
<a name="line-37"></a> <span class='hs-varid'>res_ty</span>
<a name="line-38"></a> <span class='hs-varid'>core_make_arg</span>
<a name="line-39"></a> <span class='hs-varid'>core_arrow</span><span class='hs-layout'>,</span>
<a name="line-40"></a> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_arg</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span><span class='hs-layout'>)</span>
<a name="line-41"></a>
<a name="line-42"></a><span class='hs-comment'>-- A, xs |- f :: a (t*ts) t'</span>
<a name="line-43"></a><span class='hs-comment'>-- A, xs |- arg :: t</span>
<a name="line-44"></a><span class='hs-comment'>-- ------------------------------</span>
<a name="line-45"></a><span class='hs-comment'>-- A | xs |- f -<< arg :: [ts] t'</span>
<a name="line-46"></a><span class='hs-comment'>--</span>
<a name="line-47"></a><span class='hs-comment'>-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app</span>
<a name="line-48"></a>
<a name="line-49"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span>
<a name="line-50"></a> <span class='hs-layout'>(</span><span class='hs-conid'>HsArrApp</span> <span class='hs-varid'>arrow</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arrow_ty</span> <span class='hs-conid'>HsHigherOrderApp</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-51"></a> <span class='hs-keyword'>let</span>
<a name="line-52"></a> <span class='hs-layout'>(</span><span class='hs-varid'>a_arg_ty</span><span class='hs-layout'>,</span> <span class='hs-sel'>_res_ty'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcSplitAppTy</span> <span class='hs-varid'>arrow_ty</span>
<a name="line-53"></a> <span class='hs-layout'>(</span><span class='hs-sel'>_a_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_ty</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcSplitAppTy</span> <span class='hs-varid'>a_arg_ty</span>
<a name="line-54"></a>
<a name="line-55"></a> <span class='hs-varid'>core_arrow</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>arrow</span>
<a name="line-56"></a> <span class='hs-varid'>core_arg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>arg</span>
<a name="line-57"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-58"></a> <span class='hs-varid'>core_make_pair</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span>
<a name="line-59"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairExpr</span> <span class='hs-varid'>core_arrow</span>
<a name="line-60"></a> <span class='hs-layout'>(</span><span class='hs-varid'>foldl</span> <span class='hs-varid'>mkCorePairExpr</span> <span class='hs-varid'>core_arg</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-61"></a>
<a name="line-62"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span>
<a name="line-63"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span><span class='hs-layout'>)</span>
<a name="line-64"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>arrow_ty</span> <span class='hs-varid'>arg_ty</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-varid'>res_ty</span>
<a name="line-66"></a> <span class='hs-varid'>core_make_pair</span>
<a name="line-67"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_app</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>arg_ty</span> <span class='hs-varid'>res_ty</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-68"></a> <span class='hs-layout'>(</span><span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_arrow</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_arg</span><span class='hs-layout'>)</span>
<a name="line-69"></a> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span><span class='hs-layout'>)</span>
<a name="line-70"></a>
<a name="line-71"></a><span class='hs-comment'>-- A | ys |- c :: [t:ts] t'</span>
<a name="line-72"></a><span class='hs-comment'>-- A, xs |- e :: t</span>
<a name="line-73"></a><span class='hs-comment'>-- ------------------------</span>
<a name="line-74"></a><span class='hs-comment'>-- A | xs |- c e :: [ts] t'</span>
<a name="line-75"></a><span class='hs-comment'>--</span>
<a name="line-76"></a><span class='hs-comment'>-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c</span>
<a name="line-77"></a>
<a name="line-78"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsApp</span> <span class='hs-varid'>cmd</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-79"></a> <span class='hs-varid'>core_arg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>arg</span>
<a name="line-80"></a> <span class='hs-keyword'>let</span>
<a name="line-81"></a> <span class='hs-varid'>arg_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>core_arg</span>
<a name="line-82"></a> <span class='hs-varid'>stack'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>arg_ty</span><span class='hs-conop'>:</span><span class='hs-varid'>stack</span>
<a name="line-83"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span>
<a name="line-84"></a> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stack'</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-85"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-86"></a> <span class='hs-varid'>arg_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>arg_ty</span>
<a name="line-87"></a> <span class='hs-comment'>-- push the argument expression onto the stack</span>
<a name="line-88"></a> <span class='hs-keyword'>let</span>
<a name="line-89"></a> <span class='hs-varid'>core_body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bindNonRec</span> <span class='hs-varid'>arg_id</span> <span class='hs-varid'>core_arg</span>
<a name="line-90"></a> <span class='hs-layout'>(</span><span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>env_ids'</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_id</span><span class='hs-conop'>:</span><span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-91"></a> <span class='hs-comment'>-- match the environment and stack against the input</span>
<a name="line-92"></a> <span class='hs-varid'>core_map</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-varid'>core_body</span>
<a name="line-93"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span>
<a name="line-94"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span><span class='hs-layout'>)</span>
<a name="line-95"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack'</span><span class='hs-layout'>)</span>
<a name="line-96"></a> <span class='hs-varid'>res_ty</span>
<a name="line-97"></a> <span class='hs-varid'>core_map</span>
<a name="line-98"></a> <span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span>
<a name="line-99"></a> <span class='hs-layout'>(</span><span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_arg</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span><span class='hs-layout'>)</span>
<a name="line-100"></a> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>)</span>
<a name="line-101"></a>
<a name="line-102"></a><span class='hs-comment'>-- A | ys |- c :: [ts] t'</span>
<a name="line-103"></a><span class='hs-comment'>-- -----------------------------------------------</span>
<a name="line-104"></a><span class='hs-comment'>-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'</span>
<a name="line-105"></a><span class='hs-comment'>--</span>
<a name="line-106"></a><span class='hs-comment'>-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c</span>
<a name="line-107"></a>
<a name="line-108"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span>
<a name="line-109"></a> <span class='hs-layout'>(</span><span class='hs-conid'>HsLam</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchGroup</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>pats</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHSs</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHS</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-110"></a> <span class='hs-keyword'>let</span>
<a name="line-111"></a> <span class='hs-varid'>pat_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectPatsBinders</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span>
<a name="line-112"></a> <span class='hs-varid'>local_vars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>pat_vars</span>
<a name="line-113"></a> <span class='hs-varid'>stack'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>drop</span> <span class='hs-layout'>(</span><span class='hs-varid'>length</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-varid'>stack</span>
<a name="line-114"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_body</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars'</span> <span class='hs-varid'>stack'</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>body</span>
<a name="line-115"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-116"></a>
<a name="line-117"></a> <span class='hs-comment'>-- the expression is built from the inside out, so the actions</span>
<a name="line-118"></a> <span class='hs-comment'>-- are presented in reverse order</span>
<a name="line-119"></a>
<a name="line-120"></a> <span class='hs-keyword'>let</span>
<a name="line-121"></a> <span class='hs-layout'>(</span><span class='hs-varid'>actual_ids</span><span class='hs-layout'>,</span> <span class='hs-varid'>stack_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>splitAt</span> <span class='hs-layout'>(</span><span class='hs-varid'>length</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-varid'>stack_ids</span>
<a name="line-122"></a> <span class='hs-comment'>-- build a new environment, plus what's left of the stack</span>
<a name="line-123"></a> <span class='hs-varid'>core_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack_ids'</span>
<a name="line-124"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span>
<a name="line-125"></a> <span class='hs-varid'>in_ty'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack'</span>
<a name="line-126"></a>
<a name="line-127"></a> <span class='hs-varid'>fail_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkFailExpr</span> <span class='hs-conid'>LambdaExpr</span> <span class='hs-varid'>in_ty'</span>
<a name="line-128"></a> <span class='hs-comment'>-- match the patterns against the top of the old stack</span>
<a name="line-129"></a> <span class='hs-varid'>match_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchSimplys</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>actual_ids</span><span class='hs-layout'>)</span> <span class='hs-conid'>LambdaExpr</span> <span class='hs-varid'>pats</span> <span class='hs-varid'>core_expr</span> <span class='hs-varid'>fail_expr</span>
<a name="line-130"></a> <span class='hs-comment'>-- match the old environment and stack against the input</span>
<a name="line-131"></a> <span class='hs-varid'>select_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-varid'>match_code</span>
<a name="line-132"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>in_ty'</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>select_code</span> <span class='hs-varid'>core_body</span><span class='hs-layout'>,</span>
<a name="line-133"></a> <span class='hs-varid'>free_vars</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>pat_vars</span><span class='hs-layout'>)</span>
<a name="line-134"></a>
<a name="line-135"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsPar</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>)</span>
<a name="line-136"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsLCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-137"></a>
<a name="line-138"></a><span class='hs-comment'>-- A, xs |- e :: Bool</span>
<a name="line-139"></a><span class='hs-comment'>-- A | xs1 |- c1 :: [ts] t</span>
<a name="line-140"></a><span class='hs-comment'>-- A | xs2 |- c2 :: [ts] t</span>
<a name="line-141"></a><span class='hs-comment'>-- ----------------------------------------</span>
<a name="line-142"></a><span class='hs-comment'>-- A | xs |- if e then c1 else c2 :: [ts] t</span>
<a name="line-143"></a><span class='hs-comment'>--</span>
<a name="line-144"></a><span class='hs-comment'>-- ---> arr (\ ((xs)*ts) -></span>
<a name="line-145"></a><span class='hs-comment'>-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>></span>
<a name="line-146"></a><span class='hs-comment'>-- c1 ||| c2</span>
<a name="line-147"></a>
<a name="line-148"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsIf</span> <span class='hs-varid'>cond</span> <span class='hs-varid'>then_cmd</span> <span class='hs-varid'>else_cmd</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-149"></a> <span class='hs-varid'>core_cond</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>cond</span>
<a name="line-150"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_then</span><span class='hs-layout'>,</span> <span class='hs-varid'>fvs_then</span><span class='hs-layout'>,</span> <span class='hs-varid'>then_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>then_cmd</span>
<a name="line-151"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_else</span><span class='hs-layout'>,</span> <span class='hs-varid'>fvs_else</span><span class='hs-layout'>,</span> <span class='hs-varid'>else_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>else_cmd</span>
<a name="line-152"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-153"></a> <span class='hs-varid'>either_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupTyCon</span> <span class='hs-varid'>eitherTyConName</span>
<a name="line-154"></a> <span class='hs-varid'>left_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupDataCon</span> <span class='hs-varid'>leftDataConName</span>
<a name="line-155"></a> <span class='hs-varid'>right_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupDataCon</span> <span class='hs-varid'>rightDataConName</span>
<a name="line-156"></a> <span class='hs-keyword'>let</span>
<a name="line-157"></a> <span class='hs-varid'>left_expr</span> <span class='hs-varid'>ty1</span> <span class='hs-varid'>ty2</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkConApp</span> <span class='hs-varid'>left_con</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>ty1</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>ty2</span><span class='hs-layout'>,</span> <span class='hs-varid'>e</span><span class='hs-keyglyph'>]</span>
<a name="line-158"></a> <span class='hs-varid'>right_expr</span> <span class='hs-varid'>ty1</span> <span class='hs-varid'>ty2</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkConApp</span> <span class='hs-varid'>right_con</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>ty1</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>ty2</span><span class='hs-layout'>,</span> <span class='hs-varid'>e</span><span class='hs-keyglyph'>]</span>
<a name="line-159"></a>
<a name="line-160"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span>
<a name="line-161"></a> <span class='hs-varid'>then_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>then_ids</span> <span class='hs-varid'>stack</span>
<a name="line-162"></a> <span class='hs-varid'>else_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>else_ids</span> <span class='hs-varid'>stack</span>
<a name="line-163"></a> <span class='hs-varid'>sum_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTyConApp</span> <span class='hs-varid'>either_con</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>then_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>else_ty</span><span class='hs-keyglyph'>]</span>
<a name="line-164"></a> <span class='hs-varid'>fvs_cond</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_cond</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span>
<a name="line-165"></a>
<a name="line-166"></a> <span class='hs-varid'>core_if</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span>
<a name="line-167"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkIfThenElse</span> <span class='hs-varid'>core_cond</span>
<a name="line-168"></a> <span class='hs-layout'>(</span><span class='hs-varid'>left_expr</span> <span class='hs-varid'>then_ty</span> <span class='hs-varid'>else_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>then_ids</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-169"></a> <span class='hs-layout'>(</span><span class='hs-varid'>right_expr</span> <span class='hs-varid'>then_ty</span> <span class='hs-varid'>else_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>else_ids</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-170"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>sum_ty</span> <span class='hs-varid'>res_ty</span>
<a name="line-171"></a> <span class='hs-varid'>core_if</span>
<a name="line-172"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_choice</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>then_ty</span> <span class='hs-varid'>else_ty</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>core_then</span> <span class='hs-varid'>core_else</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-173"></a> <span class='hs-varid'>fvs_cond</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>fvs_then</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>fvs_else</span><span class='hs-layout'>)</span>
</pre>\end{code}
Case commands are treated in much the same way as if commands
(see above) except that there are more alternatives. For example
case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
is translated to
arr (\ ((xs)*ts) -> case e of
p1 -> (Left (Left (xs1)*ts))
p2 -> Left ((Right (xs2)*ts))
p3 -> Right ((xs3)*ts)) >>>
(c1 ||| c2) ||| c3
The idea is to extract the commands from the case, build a balanced tree
of choices, and replace the commands with expressions that build tagged
tuples, obtaining a case expression that can be desugared normally.
To build all this, we use quadruples decribing segments of the list of
case bodies, containing the following fields:
1. an IdSet containing the environment variables free in the case bodies
2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
into the case replacing the commands
3. a sum type that is the common type of these expressions, and also the
input type of the arrow
4. a CoreExpr for an arrow built by combining the translated command
bodies with |||.
\begin{code}
<pre><a name="line-1"></a><a name="dsCmd"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsCase</span> <span class='hs-varid'>exp</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchGroup</span> <span class='hs-varid'>matches</span> <span class='hs-varid'>match_ty</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-2"></a> <span class='hs-varid'>core_exp</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>exp</span>
<a name="line-3"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-4"></a>
<a name="line-5"></a> <span class='hs-comment'>-- Extract and desugar the leaf commands in the case, building tuple</span>
<a name="line-6"></a> <span class='hs-comment'>-- expressions that will (after tagging) replace these leaves</span>
<a name="line-7"></a>
<a name="line-8"></a> <span class='hs-keyword'>let</span>
<a name="line-9"></a> <span class='hs-varid'>leaves</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>concatMap</span> <span class='hs-varid'>leavesMatch</span> <span class='hs-varid'>matches</span>
<a name="line-10"></a> <span class='hs-varid'>make_branch</span> <span class='hs-layout'>(</span><span class='hs-varid'>leaf</span><span class='hs-layout'>,</span> <span class='hs-varid'>bound_vars</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-11"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_leaf</span><span class='hs-layout'>,</span> <span class='hs-varid'>fvs</span><span class='hs-layout'>,</span> <span class='hs-varid'>leaf_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span>
<a name="line-12"></a> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-layout'>(</span><span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>bound_vars</span><span class='hs-layout'>)</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>leaf</span>
<a name="line-13"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>fvs</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>bound_vars</span><span class='hs-layout'>,</span>
<a name="line-14"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkHsEnvStackExpr</span> <span class='hs-varid'>leaf_ids</span> <span class='hs-varid'>stack_ids</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-15"></a> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>leaf_ids</span> <span class='hs-varid'>stack</span><span class='hs-layout'>,</span>
<a name="line-16"></a> <span class='hs-varid'>core_leaf</span><span class='hs-layout'>)</span>
<a name="line-17"></a>
<a name="line-18"></a> <span class='hs-varid'>branches</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>make_branch</span> <span class='hs-varid'>leaves</span>
<a name="line-19"></a> <span class='hs-varid'>either_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupTyCon</span> <span class='hs-varid'>eitherTyConName</span>
<a name="line-20"></a> <span class='hs-varid'>left_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupDataCon</span> <span class='hs-varid'>leftDataConName</span>
<a name="line-21"></a> <span class='hs-varid'>right_con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupDataCon</span> <span class='hs-varid'>rightDataConName</span>
<a name="line-22"></a> <span class='hs-keyword'>let</span>
<a name="line-23"></a> <span class='hs-varid'>left_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>HsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConWrapId</span> <span class='hs-varid'>left_con</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-varid'>right_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>HsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConWrapId</span> <span class='hs-varid'>right_con</span><span class='hs-layout'>)</span>
<a name="line-25"></a> <span class='hs-varid'>left_expr</span> <span class='hs-varid'>ty1</span> <span class='hs-varid'>ty2</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-conid'>HsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-conid'>HsWrap</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkWpTyApps</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ty1</span><span class='hs-layout'>,</span> <span class='hs-varid'>ty2</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varid'>left_id</span> <span class='hs-layout'>)</span> <span class='hs-varid'>e</span>
<a name="line-26"></a> <span class='hs-varid'>right_expr</span> <span class='hs-varid'>ty1</span> <span class='hs-varid'>ty2</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-conid'>HsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-conid'>HsWrap</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkWpTyApps</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ty1</span><span class='hs-layout'>,</span> <span class='hs-varid'>ty2</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varid'>right_id</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span>
<a name="line-27"></a>
<a name="line-28"></a> <span class='hs-comment'>-- Prefix each tuple with a distinct series of Left's and Right's,</span>
<a name="line-29"></a> <span class='hs-comment'>-- in a balanced way, keeping track of the types.</span>
<a name="line-30"></a>
<a name="line-31"></a> <span class='hs-varid'>merge_branches</span> <span class='hs-layout'>(</span><span class='hs-varid'>fvs1</span><span class='hs-layout'>,</span> <span class='hs-varid'>builds1</span><span class='hs-layout'>,</span> <span class='hs-varid'>in_ty1</span><span class='hs-layout'>,</span> <span class='hs-varid'>core_exp1</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-layout'>(</span><span class='hs-varid'>fvs2</span><span class='hs-layout'>,</span> <span class='hs-varid'>builds2</span><span class='hs-layout'>,</span> <span class='hs-varid'>in_ty2</span><span class='hs-layout'>,</span> <span class='hs-varid'>core_exp2</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>fvs1</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>fvs2</span><span class='hs-layout'>,</span>
<a name="line-34"></a> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>left_expr</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>in_ty2</span><span class='hs-layout'>)</span> <span class='hs-varid'>builds1</span> <span class='hs-varop'>++</span>
<a name="line-35"></a> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>right_expr</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>in_ty2</span><span class='hs-layout'>)</span> <span class='hs-varid'>builds2</span><span class='hs-layout'>,</span>
<a name="line-36"></a> <span class='hs-varid'>mkTyConApp</span> <span class='hs-varid'>either_con</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>in_ty1</span><span class='hs-layout'>,</span> <span class='hs-varid'>in_ty2</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-37"></a> <span class='hs-varid'>do_choice</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>in_ty2</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>core_exp1</span> <span class='hs-varid'>core_exp2</span><span class='hs-layout'>)</span>
<a name="line-38"></a> <span class='hs-layout'>(</span><span class='hs-varid'>fvs_alts</span><span class='hs-layout'>,</span> <span class='hs-varid'>leaves'</span><span class='hs-layout'>,</span> <span class='hs-varid'>sum_ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>core_choices</span><span class='hs-layout'>)</span>
<a name="line-39"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldb</span> <span class='hs-varid'>merge_branches</span> <span class='hs-varid'>branches</span>
<a name="line-40"></a>
<a name="line-41"></a> <span class='hs-comment'>-- Replace the commands in the case with these tagged tuples,</span>
<a name="line-42"></a> <span class='hs-comment'>-- yielding a HsExpr Id we can feed to dsExpr.</span>
<a name="line-43"></a>
<a name="line-44"></a> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>matches'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mapAccumL</span> <span class='hs-layout'>(</span><span class='hs-varid'>replaceLeavesMatch</span> <span class='hs-varid'>res_ty</span><span class='hs-layout'>)</span> <span class='hs-varid'>leaves'</span> <span class='hs-varid'>matches</span>
<a name="line-45"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span>
<a name="line-46"></a> <span class='hs-varid'>fvs_exp</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_exp</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-varid'>pat_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>funArgTy</span> <span class='hs-varid'>match_ty</span>
<a name="line-49"></a> <span class='hs-varid'>match_ty'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkFunTy</span> <span class='hs-varid'>pat_ty</span> <span class='hs-varid'>sum_ty</span>
<a name="line-50"></a> <span class='hs-comment'>-- Note that we replace the HsCase result type by sum_ty,</span>
<a name="line-51"></a> <span class='hs-comment'>-- which is the type of matches'</span>
<a name="line-52"></a>
<a name="line-53"></a> <span class='hs-varid'>core_body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsExpr</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsCase</span> <span class='hs-varid'>exp</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchGroup</span> <span class='hs-varid'>matches'</span> <span class='hs-varid'>match_ty'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-varid'>core_matches</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-varid'>core_body</span>
<a name="line-55"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>sum_ty</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>core_matches</span> <span class='hs-varid'>core_choices</span><span class='hs-layout'>,</span>
<a name="line-56"></a> <span class='hs-varid'>fvs_exp</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>fvs_alts</span><span class='hs-layout'>)</span>
<a name="line-57"></a>
<a name="line-58"></a><span class='hs-comment'>-- A | ys |- c :: [ts] t</span>
<a name="line-59"></a><span class='hs-comment'>-- ----------------------------------</span>
<a name="line-60"></a><span class='hs-comment'>-- A | xs |- let binds in c :: [ts] t</span>
<a name="line-61"></a><span class='hs-comment'>--</span>
<a name="line-62"></a><span class='hs-comment'>-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c</span>
<a name="line-63"></a>
<a name="line-64"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsLet</span> <span class='hs-varid'>binds</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-65"></a> <span class='hs-keyword'>let</span>
<a name="line-66"></a> <span class='hs-varid'>defined_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLocalBinders</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-varid'>local_vars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>defined_vars</span>
<a name="line-68"></a>
<a name="line-69"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_body</span><span class='hs-layout'>,</span> <span class='hs-sel'>_free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars'</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>body</span>
<a name="line-70"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-71"></a> <span class='hs-comment'>-- build a new environment, plus the stack, using the let bindings</span>
<a name="line-72"></a> <span class='hs-varid'>core_binds</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLocalBinds</span> <span class='hs-varid'>binds</span> <span class='hs-layout'>(</span><span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span>
<a name="line-73"></a> <span class='hs-comment'>-- match the old environment and stack against the input</span>
<a name="line-74"></a> <span class='hs-varid'>core_map</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-varid'>core_binds</span>
<a name="line-75"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span>
<a name="line-76"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span><span class='hs-layout'>)</span>
<a name="line-77"></a> <span class='hs-layout'>(</span><span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack</span><span class='hs-layout'>)</span>
<a name="line-78"></a> <span class='hs-varid'>res_ty</span>
<a name="line-79"></a> <span class='hs-varid'>core_map</span>
<a name="line-80"></a> <span class='hs-varid'>core_body</span><span class='hs-layout'>,</span>
<a name="line-81"></a> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_binds</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span><span class='hs-layout'>)</span>
<a name="line-82"></a>
<a name="line-83"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsDo</span> <span class='hs-sel'>_ctxt</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>body</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span>
<a name="line-84"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsCmdDo</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>body</span>
<a name="line-85"></a>
<a name="line-86"></a><span class='hs-comment'>-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t</span>
<a name="line-87"></a><span class='hs-comment'>-- A | xs |- ci :: [tsi] ti</span>
<a name="line-88"></a><span class='hs-comment'>-- -----------------------------------</span>
<a name="line-89"></a><span class='hs-comment'>-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn</span>
<a name="line-90"></a>
<a name="line-91"></a><span class='hs-definition'>dsCmd</span> <span class='hs-sel'>_ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-sel'>_stack</span> <span class='hs-sel'>_res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsArrForm</span> <span class='hs-varid'>op</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-92"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>env_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-93"></a> <span class='hs-varid'>core_op</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLExpr</span> <span class='hs-varid'>op</span>
<a name="line-94"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_args</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_sets</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>dsTrimCmdArg</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span>
<a name="line-95"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>App</span> <span class='hs-varid'>core_op</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-varid'>env_ty</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>core_args</span><span class='hs-layout'>,</span>
<a name="line-96"></a> <span class='hs-varid'>unionVarSets</span> <span class='hs-varid'>fv_sets</span><span class='hs-layout'>)</span>
<a name="line-97"></a>
<a name="line-98"></a>
<a name="line-99"></a><span class='hs-definition'>dsCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsTick</span> <span class='hs-varid'>ix</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-100"></a> <span class='hs-layout'>(</span><span class='hs-varid'>expr1</span><span class='hs-layout'>,</span><span class='hs-varid'>id_set</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>expr</span>
<a name="line-101"></a> <span class='hs-varid'>expr2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkTickBox</span> <span class='hs-varid'>ix</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>expr1</span>
<a name="line-102"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>expr2</span><span class='hs-layout'>,</span><span class='hs-varid'>id_set</span><span class='hs-layout'>)</span>
<a name="line-103"></a>
<a name="line-104"></a><span class='hs-definition'>dsCmd</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>c</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"dsCmd"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>c</span><span class='hs-layout'>)</span>
<a name="line-105"></a>
<a name="line-106"></a><span class='hs-comment'>-- A | ys |- c :: [ts] t (ys <= xs)</span>
<a name="line-107"></a><span class='hs-comment'>-- ---------------------</span>
<a name="line-108"></a><span class='hs-comment'>-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c</span>
<a name="line-109"></a>
<a name="line-110"></a><a name="dsTrimCmdArg"></a><span class='hs-definition'>dsTrimCmdArg</span>
<a name="line-111"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this command</span>
<a name="line-112"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the input to this command</span>
<a name="line-113"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsCmdTop</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- command argument to desugar</span>
<a name="line-114"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-115"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-116"></a><span class='hs-definition'>dsTrimCmdArg</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsCmdTop</span> <span class='hs-varid'>cmd</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-117"></a> <span class='hs-varid'>meth_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkCmdEnv</span> <span class='hs-varid'>ids</span>
<a name="line-118"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-119"></a> <span class='hs-varid'>stack_ids</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>stack</span>
<a name="line-120"></a> <span class='hs-varid'>trim_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack_ids</span> <span class='hs-layout'>(</span><span class='hs-varid'>buildEnvStack</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack_ids</span><span class='hs-layout'>)</span>
<a name="line-121"></a> <span class='hs-keyword'>let</span>
<a name="line-122"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>stack</span>
<a name="line-123"></a> <span class='hs-varid'>in_ty'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>envStackType</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack</span>
<a name="line-124"></a> <span class='hs-varid'>arg_code</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varop'>==</span> <span class='hs-varid'>env_ids</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>core_cmd</span> <span class='hs-keyword'>else</span>
<a name="line-125"></a> <span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>in_ty'</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>trim_code</span> <span class='hs-varid'>core_cmd</span>
<a name="line-126"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>bindCmdEnv</span> <span class='hs-varid'>meth_ids</span> <span class='hs-varid'>arg_code</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>)</span>
<a name="line-127"></a>
<a name="line-128"></a><span class='hs-comment'>-- Given A | xs |- c :: [ts] t, builds c with xs fed back.</span>
<a name="line-129"></a><span class='hs-comment'>-- Typically needs to be prefixed with arr (\p -> ((xs)*ts))</span>
<a name="line-130"></a>
<a name="line-131"></a><a name="dsfixCmd"></a><span class='hs-definition'>dsfixCmd</span>
<a name="line-132"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-133"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this command</span>
<a name="line-134"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- type of the stack</span>
<a name="line-135"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- return type of the command</span>
<a name="line-136"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsCmd</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- command to desugar</span>
<a name="line-137"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-138"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-139"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set as a list, fed back</span>
<a name="line-140"></a><span class='hs-definition'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-141"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fixDs</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span> <span class='hs-keyglyph'>~</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-142"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stack</span> <span class='hs-varid'>cmd_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-143"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>,</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>free_vars</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-144"></a>
</pre>\end{code}
Translation of command judgements of the form
A | xs |- do { ss } :: [] t
\begin{code}
<pre><a name="line-1"></a>
<a name="line-2"></a><a name="dsCmdDo"></a><span class='hs-definition'>dsCmdDo</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this statement</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the input to this statement</span>
<a name="line-5"></a> <span class='hs-comment'>-- This is typically fed back,</span>
<a name="line-6"></a> <span class='hs-comment'>-- so don't pull on it too early</span>
<a name="line-7"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- return type of the statement</span>
<a name="line-8"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LStmt</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- statements to desugar</span>
<a name="line-9"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- body</span>
<a name="line-10"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-11"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-comment'>-- A | xs |- c :: [] t</span>
<a name="line-14"></a><span class='hs-comment'>-- --------------------------</span>
<a name="line-15"></a><span class='hs-comment'>-- A | xs |- do { c } :: [] t</span>
<a name="line-16"></a>
<a name="line-17"></a><span class='hs-definition'>dsCmdDo</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>res_ty</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>body</span>
<a name="line-18"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsLCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>body</span>
<a name="line-19"></a>
<a name="line-20"></a><span class='hs-definition'>dsCmdDo</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>res_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>stmt</span><span class='hs-conop'>:</span><span class='hs-varid'>stmts</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-21"></a> <span class='hs-keyword'>let</span>
<a name="line-22"></a> <span class='hs-varid'>bound_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLStmtBinders</span> <span class='hs-varid'>stmt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-varid'>local_vars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>bound_vars</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>fixDs</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span> <span class='hs-keyglyph'>~</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-25"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsCmdDo</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars'</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>res_ty</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>body</span>
<a name="line-26"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-27"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmt</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmt</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsCmdLStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stmt</span>
<a name="line-28"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span>
<a name="line-29"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-30"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span>
<a name="line-31"></a> <span class='hs-varid'>res_ty</span>
<a name="line-32"></a> <span class='hs-varid'>core_stmt</span>
<a name="line-33"></a> <span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span>
<a name="line-34"></a> <span class='hs-varid'>fv_stmt</span><span class='hs-layout'>)</span>
<a name="line-35"></a>
</pre>\end{code}
A statement maps one local environment to another, and is represented
as an arrow from one tuple type to another. A statement sequence is
translated to a composition of such arrows.
\begin{code}
<pre><a name="line-1"></a><a name="dsCmdLStmt"></a><span class='hs-definition'>dsCmdLStmt</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LStmt</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span>
<a name="line-3"></a><span class='hs-definition'>dsCmdLStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>cmd</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsCmdStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>)</span>
<a name="line-5"></a>
<a name="line-6"></a><a name="dsCmdStmt"></a><span class='hs-definition'>dsCmdStmt</span>
<a name="line-7"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-8"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this statement</span>
<a name="line-9"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the input to this statement</span>
<a name="line-10"></a> <span class='hs-comment'>-- This is typically fed back,</span>
<a name="line-11"></a> <span class='hs-comment'>-- so don't pull on it too early</span>
<a name="line-12"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the output of this statement</span>
<a name="line-13"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Stmt</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- statement to desugar</span>
<a name="line-14"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-15"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-16"></a>
<a name="line-17"></a><span class='hs-comment'>-- A | xs1 |- c :: [] t</span>
<a name="line-18"></a><span class='hs-comment'>-- A | xs' |- do { ss } :: [] t'</span>
<a name="line-19"></a><span class='hs-comment'>-- ------------------------------</span>
<a name="line-20"></a><span class='hs-comment'>-- A | xs |- do { c; ss } :: [] t'</span>
<a name="line-21"></a><span class='hs-comment'>--</span>
<a name="line-22"></a><span class='hs-comment'>-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>></span>
<a name="line-23"></a><span class='hs-comment'>-- arr snd >>> ss</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-definition'>dsCmdStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-layout'>(</span><span class='hs-conid'>ExprStmt</span> <span class='hs-varid'>cmd</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>c_ty</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-26"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>cmd</span>
<a name="line-27"></a> <span class='hs-varid'>core_mux</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span>
<a name="line-28"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env_ids1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-29"></a> <span class='hs-keyword'>let</span>
<a name="line-30"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-31"></a> <span class='hs-varid'>in_ty1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids1</span>
<a name="line-32"></a> <span class='hs-varid'>out_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span>
<a name="line-33"></a> <span class='hs-varid'>before_c_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>out_ty</span>
<a name="line-34"></a> <span class='hs-varid'>after_c_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-35"></a> <span class='hs-varid'>snd_fn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkSndExpr</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-36"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>before_c_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>core_mux</span> <span class='hs-varop'>$</span>
<a name="line-37"></a> <span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>before_c_ty</span> <span class='hs-varid'>after_c_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-38"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_first</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>c_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>core_cmd</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span>
<a name="line-39"></a> <span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>after_c_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>snd_fn</span><span class='hs-layout'>,</span>
<a name="line-40"></a> <span class='hs-varid'>extendVarSetList</span> <span class='hs-varid'>fv_cmd</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-41"></a> <span class='hs-keyword'>where</span>
<a name="line-42"></a>
<a name="line-43"></a><span class='hs-comment'>-- A | xs1 |- c :: [] t</span>
<a name="line-44"></a><span class='hs-comment'>-- A | xs' |- do { ss } :: [] t' xs2 = xs' - defs(p)</span>
<a name="line-45"></a><span class='hs-comment'>-- -----------------------------------</span>
<a name="line-46"></a><span class='hs-comment'>-- A | xs |- do { p <- c; ss } :: [] t'</span>
<a name="line-47"></a><span class='hs-comment'>--</span>
<a name="line-48"></a><span class='hs-comment'>-- ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>></span>
<a name="line-49"></a><span class='hs-comment'>-- arr (\ (p, (xs2)) -> (xs')) >>> ss</span>
<a name="line-50"></a><span class='hs-comment'>--</span>
<a name="line-51"></a><span class='hs-comment'>-- It would be simpler and more consistent to do this using second,</span>
<a name="line-52"></a><span class='hs-comment'>-- but that's likely to be defined in terms of first.</span>
<a name="line-53"></a>
<a name="line-54"></a><span class='hs-definition'>dsCmdStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-layout'>(</span><span class='hs-conid'>BindStmt</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>cmd</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-55"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_cmd</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-conid'>[]</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsLPatType</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-varid'>cmd</span>
<a name="line-56"></a> <span class='hs-keyword'>let</span>
<a name="line-57"></a> <span class='hs-varid'>pat_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>hsLPatType</span> <span class='hs-varid'>pat</span>
<a name="line-58"></a> <span class='hs-varid'>pat_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectPatBinders</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-59"></a> <span class='hs-varid'>env_ids2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varSetElems</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>out_ids</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>pat_vars</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-varid'>env_ty2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids2</span>
<a name="line-61"></a>
<a name="line-62"></a> <span class='hs-comment'>-- multiplexing function</span>
<a name="line-63"></a> <span class='hs-comment'>-- \ (xs) -> ((xs1),(xs2))</span>
<a name="line-64"></a>
<a name="line-65"></a> <span class='hs-varid'>core_mux</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span>
<a name="line-66"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkCorePairExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env_ids1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env_ids2</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-67"></a>
<a name="line-68"></a> <span class='hs-comment'>-- projection function</span>
<a name="line-69"></a> <span class='hs-comment'>-- \ (p, (xs2)) -> (zs)</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-varid'>env_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>env_ty2</span>
<a name="line-72"></a> <span class='hs-varid'>uniqs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUniqueSupply</span>
<a name="line-73"></a> <span class='hs-keyword'>let</span>
<a name="line-74"></a> <span class='hs-varid'>after_c_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>pat_ty</span> <span class='hs-varid'>env_ty2</span>
<a name="line-75"></a> <span class='hs-varid'>out_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span>
<a name="line-76"></a> <span class='hs-varid'>body_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>coreCaseTuple</span> <span class='hs-varid'>uniqs</span> <span class='hs-varid'>env_id</span> <span class='hs-varid'>env_ids2</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-77"></a>
<a name="line-78"></a> <span class='hs-varid'>fail_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkFailExpr</span> <span class='hs-layout'>(</span><span class='hs-conid'>StmtCtxt</span> <span class='hs-conid'>DoExpr</span><span class='hs-layout'>)</span> <span class='hs-varid'>out_ty</span>
<a name="line-79"></a> <span class='hs-varid'>pat_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>selectSimpleMatchVarL</span> <span class='hs-varid'>pat</span>
<a name="line-80"></a> <span class='hs-varid'>match_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchSimply</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>pat_id</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>StmtCtxt</span> <span class='hs-conid'>DoExpr</span><span class='hs-layout'>)</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>body_expr</span> <span class='hs-varid'>fail_expr</span>
<a name="line-81"></a> <span class='hs-varid'>pair_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>after_c_ty</span>
<a name="line-82"></a> <span class='hs-keyword'>let</span>
<a name="line-83"></a> <span class='hs-varid'>proj_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Lam</span> <span class='hs-varid'>pair_id</span> <span class='hs-layout'>(</span><span class='hs-varid'>coreCasePair</span> <span class='hs-varid'>pair_id</span> <span class='hs-varid'>pat_id</span> <span class='hs-varid'>env_id</span> <span class='hs-varid'>match_code</span><span class='hs-layout'>)</span>
<a name="line-84"></a>
<a name="line-85"></a> <span class='hs-comment'>-- put it all together</span>
<a name="line-86"></a> <span class='hs-keyword'>let</span>
<a name="line-87"></a> <span class='hs-varid'>in_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-88"></a> <span class='hs-varid'>in_ty1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids1</span>
<a name="line-89"></a> <span class='hs-varid'>in_ty2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids2</span>
<a name="line-90"></a> <span class='hs-varid'>before_c_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>in_ty2</span>
<a name="line-91"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty</span> <span class='hs-varid'>before_c_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>core_mux</span> <span class='hs-varop'>$</span>
<a name="line-92"></a> <span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>before_c_ty</span> <span class='hs-varid'>after_c_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-93"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_first</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_ty1</span> <span class='hs-varid'>pat_ty</span> <span class='hs-varid'>in_ty2</span> <span class='hs-varid'>core_cmd</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span>
<a name="line-94"></a> <span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>after_c_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>proj_expr</span><span class='hs-layout'>,</span>
<a name="line-95"></a> <span class='hs-varid'>fv_cmd</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>out_ids</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>pat_vars</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-96"></a>
<a name="line-97"></a><span class='hs-comment'>-- A | xs' |- do { ss } :: [] t</span>
<a name="line-98"></a><span class='hs-comment'>-- --------------------------------------</span>
<a name="line-99"></a><span class='hs-comment'>-- A | xs |- do { let binds; ss } :: [] t</span>
<a name="line-100"></a><span class='hs-comment'>--</span>
<a name="line-101"></a><span class='hs-comment'>-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss</span>
<a name="line-102"></a>
<a name="line-103"></a><span class='hs-definition'>dsCmdStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-layout'>(</span><span class='hs-conid'>LetStmt</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-104"></a> <span class='hs-comment'>-- build a new environment using the let bindings</span>
<a name="line-105"></a> <span class='hs-varid'>core_binds</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLocalBinds</span> <span class='hs-varid'>binds</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-106"></a> <span class='hs-comment'>-- match the old environment against the input</span>
<a name="line-107"></a> <span class='hs-varid'>core_map</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>core_binds</span>
<a name="line-108"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span>
<a name="line-109"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-110"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-111"></a> <span class='hs-varid'>core_map</span><span class='hs-layout'>,</span>
<a name="line-112"></a> <span class='hs-varid'>exprFreeVars</span> <span class='hs-varid'>core_binds</span> <span class='hs-varop'>`intersectVarSet`</span> <span class='hs-varid'>local_vars</span><span class='hs-layout'>)</span>
<a name="line-113"></a>
<a name="line-114"></a><span class='hs-comment'>-- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...</span>
<a name="line-115"></a><span class='hs-comment'>-- A | xs' |- do { ss' } :: [] t</span>
<a name="line-116"></a><span class='hs-comment'>-- ------------------------------------</span>
<a name="line-117"></a><span class='hs-comment'>-- A | xs |- do { rec ss; ss' } :: [] t</span>
<a name="line-118"></a><span class='hs-comment'>--</span>
<a name="line-119"></a><span class='hs-comment'>-- xs1 = xs' /\ defs(ss)</span>
<a name="line-120"></a><span class='hs-comment'>-- xs2 = xs' - defs(ss)</span>
<a name="line-121"></a><span class='hs-comment'>-- ys1 = ys - defs(ss)</span>
<a name="line-122"></a><span class='hs-comment'>-- ys2 = ys /\ defs(ss)</span>
<a name="line-123"></a><span class='hs-comment'>--</span>
<a name="line-124"></a><span class='hs-comment'>-- ---> arr (\(xs) -> ((ys1),(xs2))) >>></span>
<a name="line-125"></a><span class='hs-comment'>-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>></span>
<a name="line-126"></a><span class='hs-comment'>-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'</span>
<a name="line-127"></a>
<a name="line-128"></a><span class='hs-definition'>dsCmdStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span>
<a name="line-129"></a> <span class='hs-layout'>(</span><span class='hs-conid'>RecStmt</span> <span class='hs-layout'>{</span> <span class='hs-varid'>recS_stmts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>recS_later_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>later_ids</span><span class='hs-layout'>,</span> <span class='hs-varid'>recS_rec_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>rec_ids</span>
<a name="line-130"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>recS_rec_rets</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>rhss</span><span class='hs-layout'>,</span> <span class='hs-varid'>recS_dicts</span> <span class='hs-keyglyph'>=</span> <span class='hs-sel'>_binds</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-131"></a> <span class='hs-keyword'>let</span> <span class='hs-comment'>-- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********</span>
<a name="line-132"></a> <span class='hs-varid'>env2_id_set</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>out_ids</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>later_ids</span>
<a name="line-133"></a> <span class='hs-varid'>env2_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>env2_id_set</span>
<a name="line-134"></a> <span class='hs-varid'>env2_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env2_ids</span>
<a name="line-135"></a>
<a name="line-136"></a> <span class='hs-comment'>-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)</span>
<a name="line-137"></a>
<a name="line-138"></a> <span class='hs-varid'>uniqs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUniqueSupply</span>
<a name="line-139"></a> <span class='hs-varid'>env2_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>env2_ty</span>
<a name="line-140"></a> <span class='hs-keyword'>let</span>
<a name="line-141"></a> <span class='hs-varid'>later_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>later_ids</span>
<a name="line-142"></a> <span class='hs-varid'>post_pair_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>later_ty</span> <span class='hs-varid'>env2_ty</span>
<a name="line-143"></a> <span class='hs-varid'>post_loop_body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>coreCaseTuple</span> <span class='hs-varid'>uniqs</span> <span class='hs-varid'>env2_id</span> <span class='hs-varid'>env2_ids</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-144"></a>
<a name="line-145"></a> <span class='hs-varid'>post_loop_fn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>later_ids</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>env2_id</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>post_loop_body</span>
<a name="line-146"></a>
<a name="line-147"></a> <span class='hs-comment'>--- loop (...)</span>
<a name="line-148"></a>
<a name="line-149"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_loop</span><span class='hs-layout'>,</span> <span class='hs-varid'>env1_id_set</span><span class='hs-layout'>,</span> <span class='hs-varid'>env1_ids</span><span class='hs-layout'>)</span>
<a name="line-150"></a> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsRecCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>later_ids</span> <span class='hs-varid'>rec_ids</span> <span class='hs-varid'>rhss</span>
<a name="line-151"></a>
<a name="line-152"></a> <span class='hs-comment'>-- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))</span>
<a name="line-153"></a>
<a name="line-154"></a> <span class='hs-keyword'>let</span>
<a name="line-155"></a> <span class='hs-varid'>env1_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env1_ids</span>
<a name="line-156"></a> <span class='hs-varid'>pre_pair_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>env1_ty</span> <span class='hs-varid'>env2_ty</span>
<a name="line-157"></a> <span class='hs-varid'>pre_loop_body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env1_ids</span><span class='hs-layout'>)</span>
<a name="line-158"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>env2_ids</span><span class='hs-layout'>)</span>
<a name="line-159"></a>
<a name="line-160"></a> <span class='hs-varid'>pre_loop_fn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env_ids</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>pre_loop_body</span>
<a name="line-161"></a>
<a name="line-162"></a> <span class='hs-comment'>-- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn</span>
<a name="line-163"></a>
<a name="line-164"></a> <span class='hs-keyword'>let</span>
<a name="line-165"></a> <span class='hs-varid'>env_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-166"></a> <span class='hs-varid'>out_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span>
<a name="line-167"></a> <span class='hs-varid'>core_body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>env_ty</span> <span class='hs-varid'>pre_pair_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-168"></a> <span class='hs-varid'>pre_loop_fn</span>
<a name="line-169"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>pre_pair_ty</span> <span class='hs-varid'>post_pair_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-170"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_first</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>env1_ty</span> <span class='hs-varid'>later_ty</span> <span class='hs-varid'>env2_ty</span>
<a name="line-171"></a> <span class='hs-varid'>core_loop</span><span class='hs-layout'>)</span>
<a name="line-172"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>post_pair_ty</span> <span class='hs-varid'>out_ty</span>
<a name="line-173"></a> <span class='hs-varid'>post_loop_fn</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-174"></a>
<a name="line-175"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>core_body</span><span class='hs-layout'>,</span> <span class='hs-varid'>env1_id_set</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>env2_id_set</span><span class='hs-layout'>)</span>
<a name="line-176"></a>
<a name="line-177"></a><span class='hs-definition'>dsCmdStmt</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"dsCmdStmt"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span>
<a name="line-178"></a>
<a name="line-179"></a><span class='hs-comment'>-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>></span>
<a name="line-180"></a><span class='hs-comment'>-- ss >>></span>
<a name="line-181"></a><span class='hs-comment'>-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>></span>
<a name="line-182"></a>
<a name="line-183"></a><a name="dsRecCmd"></a><span class='hs-definition'>dsRecCmd</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>VarSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LStmt</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>HsExpr</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span>
<a name="line-184"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-conid'>VarSet</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-185"></a><span class='hs-definition'>dsRecCmd</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>later_ids</span> <span class='hs-varid'>rec_ids</span> <span class='hs-varid'>rhss</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-186"></a> <span class='hs-keyword'>let</span>
<a name="line-187"></a> <span class='hs-varid'>rec_id_set</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>rec_ids</span>
<a name="line-188"></a> <span class='hs-varid'>out_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varSetElems</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>later_ids</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>rec_id_set</span><span class='hs-layout'>)</span>
<a name="line-189"></a> <span class='hs-varid'>out_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span>
<a name="line-190"></a> <span class='hs-varid'>local_vars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>rec_id_set</span>
<a name="line-191"></a>
<a name="line-192"></a> <span class='hs-comment'>-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))</span>
<a name="line-193"></a>
<a name="line-194"></a> <span class='hs-varid'>core_rhss</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>dsExpr</span> <span class='hs-varid'>rhss</span>
<a name="line-195"></a> <span class='hs-keyword'>let</span>
<a name="line-196"></a> <span class='hs-varid'>later_tuple</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>later_ids</span>
<a name="line-197"></a> <span class='hs-varid'>later_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>later_ids</span>
<a name="line-198"></a> <span class='hs-varid'>rec_tuple</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreTup</span> <span class='hs-varid'>core_rhss</span>
<a name="line-199"></a> <span class='hs-varid'>rec_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>rec_ids</span>
<a name="line-200"></a> <span class='hs-varid'>out_pair</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairExpr</span> <span class='hs-varid'>later_tuple</span> <span class='hs-varid'>rec_tuple</span>
<a name="line-201"></a> <span class='hs-varid'>out_pair_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>later_ty</span> <span class='hs-varid'>rec_ty</span>
<a name="line-202"></a>
<a name="line-203"></a> <span class='hs-varid'>mk_pair_fn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>out_ids</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>out_pair</span>
<a name="line-204"></a>
<a name="line-205"></a> <span class='hs-comment'>-- ss</span>
<a name="line-206"></a>
<a name="line-207"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars'</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>stmts</span>
<a name="line-208"></a>
<a name="line-209"></a> <span class='hs-comment'>-- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)</span>
<a name="line-210"></a>
<a name="line-211"></a> <span class='hs-varid'>rec_id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>rec_ty</span>
<a name="line-212"></a> <span class='hs-keyword'>let</span>
<a name="line-213"></a> <span class='hs-varid'>env1_id_set</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fv_stmts</span> <span class='hs-varop'>`minusVarSet`</span> <span class='hs-varid'>rec_id_set</span>
<a name="line-214"></a> <span class='hs-varid'>env1_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>env1_id_set</span>
<a name="line-215"></a> <span class='hs-varid'>env1_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env1_ids</span>
<a name="line-216"></a> <span class='hs-varid'>in_pair_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCorePairTy</span> <span class='hs-varid'>env1_ty</span> <span class='hs-varid'>rec_ty</span>
<a name="line-217"></a> <span class='hs-varid'>core_body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreTup</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>selectVar</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-218"></a> <span class='hs-keyword'>where</span>
<a name="line-219"></a> <span class='hs-varid'>selectVar</span> <span class='hs-varid'>v</span>
<a name="line-220"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v</span> <span class='hs-varop'>`elemVarSet`</span> <span class='hs-varid'>rec_id_set</span>
<a name="line-221"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTupleSelector</span> <span class='hs-varid'>rec_ids</span> <span class='hs-varid'>v</span> <span class='hs-varid'>rec_id</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>rec_id</span><span class='hs-layout'>)</span>
<a name="line-222"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>v</span>
<a name="line-223"></a>
<a name="line-224"></a> <span class='hs-varid'>squash_pair_fn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchEnvStack</span> <span class='hs-varid'>env1_ids</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>rec_id</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>core_body</span>
<a name="line-225"></a>
<a name="line-226"></a> <span class='hs-comment'>-- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)</span>
<a name="line-227"></a>
<a name="line-228"></a> <span class='hs-keyword'>let</span>
<a name="line-229"></a> <span class='hs-varid'>env_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span>
<a name="line-230"></a> <span class='hs-varid'>core_loop</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>do_loop</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>env1_ty</span> <span class='hs-varid'>later_ty</span> <span class='hs-varid'>rec_ty</span>
<a name="line-231"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_map_arrow</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>in_pair_ty</span> <span class='hs-varid'>env_ty</span> <span class='hs-varid'>out_pair_ty</span>
<a name="line-232"></a> <span class='hs-varid'>squash_pair_fn</span>
<a name="line-233"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>env_ty</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>out_pair_ty</span>
<a name="line-234"></a> <span class='hs-varid'>core_stmts</span>
<a name="line-235"></a> <span class='hs-layout'>(</span><span class='hs-varid'>do_arr</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>out_ty</span> <span class='hs-varid'>out_pair_ty</span> <span class='hs-varid'>mk_pair_fn</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-236"></a>
<a name="line-237"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>core_loop</span><span class='hs-layout'>,</span> <span class='hs-varid'>env1_id_set</span><span class='hs-layout'>,</span> <span class='hs-varid'>env1_ids</span><span class='hs-layout'>)</span>
<a name="line-238"></a>
</pre>\end{code}
A sequence of statements (as in a rec) is desugared to an arrow between
two environments
\begin{code}
<pre><a name="line-1"></a>
<a name="line-2"></a><a name="dsfixCmdStmts"></a><span class='hs-definition'>dsfixCmdStmts</span>
<a name="line-3"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this statement</span>
<a name="line-5"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- output vars of these statements</span>
<a name="line-6"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LStmt</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- statements to desugar</span>
<a name="line-7"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-8"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-9"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- input vars</span>
<a name="line-10"></a>
<a name="line-11"></a><span class='hs-definition'>dsfixCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>stmts</span>
<a name="line-12"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fixDs</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span> <span class='hs-keyglyph'>~</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-13"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>stmts</span>
<a name="line-14"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>fv_stmts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-15"></a>
<a name="line-16"></a><a name="dsCmdStmts"></a><span class='hs-definition'>dsCmdStmts</span>
<a name="line-17"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsCmdEnv</span> <span class='hs-comment'>-- arrow combinators</span>
<a name="line-18"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IdSet</span> <span class='hs-comment'>-- set of local vars available to this statement</span>
<a name="line-19"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- list of vars in the input to these statements</span>
<a name="line-20"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- output vars of these statements</span>
<a name="line-21"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LStmt</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- statements to desugar</span>
<a name="line-22"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- desugared expression</span>
<a name="line-23"></a> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- set of local vars that occur free</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-definition'>dsCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>stmt</span><span class='hs-keyglyph'>]</span>
<a name="line-26"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dsCmdLStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>stmt</span>
<a name="line-27"></a>
<a name="line-28"></a><span class='hs-definition'>dsCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>out_ids</span> <span class='hs-layout'>(</span><span class='hs-varid'>stmt</span><span class='hs-conop'>:</span><span class='hs-varid'>stmts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-29"></a> <span class='hs-keyword'>let</span>
<a name="line-30"></a> <span class='hs-varid'>bound_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLStmtBinders</span> <span class='hs-varid'>stmt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-31"></a> <span class='hs-varid'>local_vars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>local_vars</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>bound_vars</span>
<a name="line-32"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span> <span class='hs-sel'>_fv_stmts</span><span class='hs-layout'>,</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsfixCmdStmts</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars'</span> <span class='hs-varid'>out_ids</span> <span class='hs-varid'>stmts</span>
<a name="line-33"></a> <span class='hs-layout'>(</span><span class='hs-varid'>core_stmt</span><span class='hs-layout'>,</span> <span class='hs-varid'>fv_stmt</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsCmdLStmt</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>local_vars</span> <span class='hs-varid'>env_ids</span> <span class='hs-varid'>env_ids'</span> <span class='hs-varid'>stmt</span>
<a name="line-34"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_compose</span> <span class='hs-varid'>ids</span>
<a name="line-35"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>env_ids'</span><span class='hs-layout'>)</span>
<a name="line-37"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkBigCoreVarTupTy</span> <span class='hs-varid'>out_ids</span><span class='hs-layout'>)</span>
<a name="line-38"></a> <span class='hs-varid'>core_stmt</span>
<a name="line-39"></a> <span class='hs-varid'>core_stmts</span><span class='hs-layout'>,</span>
<a name="line-40"></a> <span class='hs-varid'>fv_stmt</span><span class='hs-layout'>)</span>
<a name="line-41"></a>
<a name="line-42"></a><span class='hs-definition'>dsCmdStmts</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"dsCmdStmts []"</span>
<a name="line-43"></a>
</pre>\end{code}
Match a list of expressions against a list of patterns, left-to-right.
\begin{code}
<pre><a name="line-1"></a><a name="matchSimplys"></a><span class='hs-definition'>matchSimplys</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreExpr</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Scrutinees</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>HsMatchContext</span> <span class='hs-conid'>Name</span> <span class='hs-comment'>-- Match kind</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Patterns they should match</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- Return this if they all match</span>
<a name="line-5"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- Return this if they don't</span>
<a name="line-6"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-7"></a><span class='hs-definition'>matchSimplys</span> <span class='hs-conid'>[]</span> <span class='hs-sel'>_ctxt</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>result_expr</span> <span class='hs-sel'>_fail_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varid'>result_expr</span>
<a name="line-8"></a><span class='hs-definition'>matchSimplys</span> <span class='hs-layout'>(</span><span class='hs-varid'>exp</span><span class='hs-conop'>:</span><span class='hs-varid'>exps</span><span class='hs-layout'>)</span> <span class='hs-varid'>ctxt</span> <span class='hs-layout'>(</span><span class='hs-varid'>pat</span><span class='hs-conop'>:</span><span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-varid'>result_expr</span> <span class='hs-varid'>fail_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-9"></a> <span class='hs-varid'>match_code</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchSimplys</span> <span class='hs-varid'>exps</span> <span class='hs-varid'>ctxt</span> <span class='hs-varid'>pats</span> <span class='hs-varid'>result_expr</span> <span class='hs-varid'>fail_expr</span>
<a name="line-10"></a> <span class='hs-varid'>matchSimply</span> <span class='hs-varid'>exp</span> <span class='hs-varid'>ctxt</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>match_code</span> <span class='hs-varid'>fail_expr</span>
<a name="line-11"></a><span class='hs-definition'>matchSimplys</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"matchSimplys"</span>
</pre>\end{code}
List of leaf expressions, with set of variables bound in each
\begin{code}
<pre><a name="line-1"></a><a name="leavesMatch"></a><span class='hs-definition'>leavesMatch</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LMatch</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span><span class='hs-layout'>,</span> <span class='hs-conid'>IdSet</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-2"></a><span class='hs-definition'>leavesMatch</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>pats</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHSs</span> <span class='hs-varid'>grhss</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>let</span>
<a name="line-4"></a> <span class='hs-varid'>defined_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectPatsBinders</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-varop'>`unionVarSet`</span>
<a name="line-6"></a> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLocalBinders</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-7"></a> <span class='hs-keyword'>in</span>
<a name="line-8"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>expr</span><span class='hs-layout'>,</span>
<a name="line-9"></a> <span class='hs-varid'>mkVarSet</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLStmtsBinders</span> <span class='hs-varid'>stmts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-10"></a> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>defined_vars</span><span class='hs-layout'>)</span>
<a name="line-11"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHS</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>grhss</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
Replace the leaf commands in a match
\begin{code}
<pre><a name="line-1"></a><a name="replaceLeavesMatch"></a><span class='hs-definition'>replaceLeavesMatch</span>
<a name="line-2"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- new result type</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- replacement leaf expressions of that type</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LMatch</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- the matches of a case command</span>
<a name="line-5"></a> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span><span class='hs-comment'>-- remaining leaf expressions</span>
<a name="line-6"></a> <span class='hs-conid'>LMatch</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- updated match</span>
<a name="line-7"></a><span class='hs-definition'>replaceLeavesMatch</span> <span class='hs-sel'>_res_ty</span> <span class='hs-varid'>leaves</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>mt</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHSs</span> <span class='hs-varid'>grhss</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>let</span>
<a name="line-9"></a> <span class='hs-layout'>(</span><span class='hs-varid'>leaves'</span><span class='hs-layout'>,</span> <span class='hs-varid'>grhss'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mapAccumL</span> <span class='hs-varid'>replaceLeavesGRHS</span> <span class='hs-varid'>leaves</span> <span class='hs-varid'>grhss</span>
<a name="line-10"></a> <span class='hs-keyword'>in</span>
<a name="line-11"></a> <span class='hs-layout'>(</span><span class='hs-varid'>leaves'</span><span class='hs-layout'>,</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>mt</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHSs</span> <span class='hs-varid'>grhss'</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-12"></a>
<a name="line-13"></a><a name="replaceLeavesGRHS"></a><span class='hs-definition'>replaceLeavesGRHS</span>
<a name="line-14"></a> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- replacement leaf expressions of that type</span>
<a name="line-15"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LGRHS</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- rhss of a case command</span>
<a name="line-16"></a> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span><span class='hs-comment'>-- remaining leaf expressions</span>
<a name="line-17"></a> <span class='hs-conid'>LGRHS</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- updated GRHS</span>
<a name="line-18"></a><span class='hs-definition'>replaceLeavesGRHS</span> <span class='hs-layout'>(</span><span class='hs-varid'>leaf</span><span class='hs-conop'>:</span><span class='hs-varid'>leaves</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHS</span> <span class='hs-varid'>stmts</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>leaves</span><span class='hs-layout'>,</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>GRHS</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>leaf</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-20"></a><span class='hs-definition'>replaceLeavesGRHS</span> <span class='hs-conid'>[]</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"replaceLeavesGRHS []"</span>
</pre>\end{code}
Balanced fold of a non-empty list.
\begin{code}
<pre><a name="line-1"></a><a name="foldb"></a><span class='hs-definition'>foldb</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span>
<a name="line-2"></a><span class='hs-definition'>foldb</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>error</span> <span class='hs-str'>"foldb of empty list"</span>
<a name="line-3"></a><span class='hs-definition'>foldb</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>
<a name="line-4"></a><span class='hs-definition'>foldb</span> <span class='hs-varid'>f</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldb</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-varid'>fold_pairs</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-keyword'>where</span>
<a name="line-6"></a> <span class='hs-varid'>fold_pairs</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-7"></a> <span class='hs-varid'>fold_pairs</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>
<a name="line-8"></a> <span class='hs-varid'>fold_pairs</span> <span class='hs-layout'>(</span><span class='hs-varid'>x1</span><span class='hs-conop'>:</span><span class='hs-varid'>x2</span><span class='hs-conop'>:</span><span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>f</span> <span class='hs-varid'>x1</span> <span class='hs-varid'>x2</span><span class='hs-conop'>:</span><span class='hs-varid'>fold_pairs</span> <span class='hs-varid'>xs</span>
</pre>\end{code}
The following functions to collect value variables from patterns are
copied from HsUtils, with one change: we also collect the dictionary
bindings (pat_binds) from ConPatOut. We need them for cases like
h :: Arrow a => Int -> a (Int,Int) Int
h x = proc (y,z) -> case compare x y of
GT -> returnA -< z+x
The type checker turns the case into
case compare x y of
GT { p77 = plusInt } -> returnA -< p77 z x
Here p77 is a local binding for the (+) operation.
See comments in HsUtils for why the other version does not include
these bindings.
\begin{code}
<pre><a name="line-1"></a><a name="collectPatBinders"></a><span class='hs-definition'>collectPatBinders</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutputableBndr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LPat</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-2"></a><span class='hs-definition'>collectPatBinders</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLocatedPatBinders</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="collectLocatedPatBinders"></a><span class='hs-definition'>collectLocatedPatBinders</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutputableBndr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LPat</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Located</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-5"></a><span class='hs-definition'>collectLocatedPatBinders</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-conid'>[]</span>
<a name="line-6"></a>
<a name="line-7"></a><a name="collectPatsBinders"></a><span class='hs-definition'>collectPatsBinders</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutputableBndr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-8"></a><span class='hs-definition'>collectPatsBinders</span> <span class='hs-varid'>pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectLocatedPatsBinders</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="collectLocatedPatsBinders"></a><span class='hs-definition'>collectLocatedPatsBinders</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutputableBndr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Located</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-11"></a><span class='hs-definition'>collectLocatedPatsBinders</span> <span class='hs-varid'>pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>pats</span>
<a name="line-12"></a>
<a name="line-13"></a><a name="collectl"></a><span class='hs-comment'>---------------------</span>
<a name="line-14"></a><span class='hs-definition'>collectl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutputableBndr</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LPat</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Located</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Located</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-15"></a><span class='hs-definition'>collectl</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>l</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-16"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>pat</span>
<a name="line-17"></a> <span class='hs-keyword'>where</span>
<a name="line-18"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>VarPat</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>l</span> <span class='hs-varid'>var</span> <span class='hs-conop'>:</span> <span class='hs-varid'>bndrs</span>
<a name="line-19"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>VarPatOut</span> <span class='hs-varid'>var</span> <span class='hs-varid'>bs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>l</span> <span class='hs-varid'>var</span> <span class='hs-conop'>:</span> <span class='hs-varid'>collectHsBindLocatedBinders</span> <span class='hs-varid'>bs</span>
<a name="line-20"></a> <span class='hs-varop'>++</span> <span class='hs-varid'>bndrs</span>
<a name="line-21"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>WildPat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bndrs</span>
<a name="line-22"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>LazyPat</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-23"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>BangPat</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-24"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>AsPat</span> <span class='hs-varid'>a</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>a</span> <span class='hs-conop'>:</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-25"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>ParPat</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-26"></a>
<a name="line-27"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>ListPat</span> <span class='hs-varid'>pats</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>pats</span>
<a name="line-28"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>PArrPat</span> <span class='hs-varid'>pats</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>pats</span>
<a name="line-29"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>TuplePat</span> <span class='hs-varid'>pats</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>pats</span>
<a name="line-30"></a>
<a name="line-31"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConPatIn</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>bndrs</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsConPatArgs</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConPatOut</span> <span class='hs-layout'>{</span><span class='hs-varid'>pat_args</span><span class='hs-keyglyph'>=</span><span class='hs-varid'>ps</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_binds</span><span class='hs-keyglyph'>=</span><span class='hs-varid'>ds</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<a name="line-33"></a> <span class='hs-varid'>collectHsBindLocatedBinders</span> <span class='hs-varid'>ds</span>
<a name="line-34"></a> <span class='hs-varop'>++</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>bndrs</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsConPatArgs</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<a name="line-35"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>LitPat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bndrs</span>
<a name="line-36"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>NPat</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bndrs</span>
<a name="line-37"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>NPlusKPat</span> <span class='hs-varid'>n</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>n</span> <span class='hs-conop'>:</span> <span class='hs-varid'>bndrs</span>
<a name="line-38"></a>
<a name="line-39"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>SigPatIn</span> <span class='hs-varid'>pat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-40"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>SigPatOut</span> <span class='hs-varid'>pat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-41"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>TypePat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bndrs</span>
<a name="line-42"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoPat</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>pat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-43"></a> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-conid'>ViewPat</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>pat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectl</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>bndrs</span>
<a name="line-44"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>p</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>QuasiQuotePat</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"collectl/go"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span>
</pre>\end{code}
</body>
</html>
