<?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/DsUtils.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
%
Utilities for desugaring
This module exports some utility functions of no great interest.
\begin{code}
<pre><a name="line-1"></a><span class='hs-comment'>-- | Utility functions for constructing Core syntax, principally for desugaring</span>
<a name="line-2"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>DsUtils</span> <span class='hs-layout'>(</span>
<a name="line-3"></a> <span class='hs-conid'>EquationInfo</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-4"></a> <span class='hs-varid'>firstPat</span><span class='hs-layout'>,</span> <span class='hs-varid'>shiftEqns</span><span class='hs-layout'>,</span>
<a name="line-5"></a>
<a name="line-6"></a> <span class='hs-conid'>MatchResult</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-conid'>CanItFail</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-7"></a> <span class='hs-varid'>cantFailMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>alwaysFailMatchResult</span><span class='hs-layout'>,</span>
<a name="line-8"></a> <span class='hs-varid'>extractMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>combineMatchResults</span><span class='hs-layout'>,</span>
<a name="line-9"></a> <span class='hs-varid'>adjustMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>adjustMatchResultDs</span><span class='hs-layout'>,</span>
<a name="line-10"></a> <span class='hs-varid'>mkCoLetMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkViewMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkGuardedMatchResult</span><span class='hs-layout'>,</span>
<a name="line-11"></a> <span class='hs-varid'>matchCanFail</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkEvalMatchResult</span><span class='hs-layout'>,</span>
<a name="line-12"></a> <span class='hs-varid'>mkCoPrimCaseMatchResult</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkCoAlgCaseMatchResult</span><span class='hs-layout'>,</span>
<a name="line-13"></a> <span class='hs-varid'>wrapBind</span><span class='hs-layout'>,</span> <span class='hs-varid'>wrapBinds</span><span class='hs-layout'>,</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-varid'>mkErrorAppDs</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkCoreAppDs</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkCoreAppsDs</span><span class='hs-layout'>,</span>
<a name="line-16"></a>
<a name="line-17"></a> <span class='hs-varid'>seqVar</span><span class='hs-layout'>,</span>
<a name="line-18"></a>
<a name="line-19"></a> <span class='hs-comment'>-- LHs tuples</span>
<a name="line-20"></a> <span class='hs-varid'>mkLHsVarPatTup</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkLHsPatTup</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkVanillaTuplePat</span><span class='hs-layout'>,</span>
<a name="line-21"></a> <span class='hs-varid'>mkBigLHsVarTup</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkBigLHsTup</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkBigLHsVarPatTup</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkBigLHsPatTup</span><span class='hs-layout'>,</span>
<a name="line-22"></a>
<a name="line-23"></a> <span class='hs-varid'>mkSelectorBinds</span><span class='hs-layout'>,</span>
<a name="line-24"></a>
<a name="line-25"></a> <span class='hs-varid'>dsSyntaxTable</span><span class='hs-layout'>,</span> <span class='hs-varid'>lookupEvidence</span><span class='hs-layout'>,</span>
<a name="line-26"></a>
<a name="line-27"></a> <span class='hs-varid'>selectSimpleMatchVarL</span><span class='hs-layout'>,</span> <span class='hs-varid'>selectMatchVars</span><span class='hs-layout'>,</span> <span class='hs-varid'>selectMatchVar</span><span class='hs-layout'>,</span>
<a name="line-28"></a> <span class='hs-varid'>mkTickBox</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkOptTickBox</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkBinaryTickBox</span>
<a name="line-29"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-30"></a>
<a name="line-31"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-32"></a>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-comment'>{-# SOURCE #-}</span> <span class='hs-conid'>Match</span> <span class='hs-layout'>(</span> <span class='hs-varid'>matchSimply</span> <span class='hs-layout'>)</span>
<a name="line-34"></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>
<a name="line-35"></a>
<a name="line-36"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>HsSyn</span>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcHsSyn</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcType</span><span class='hs-layout'>(</span> <span class='hs-varid'>tcSplitTyConApp</span> <span class='hs-layout'>)</span>
<a name="line-39"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSyn</span>
<a name="line-40"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsMonad</span>
<a name="line-41"></a>
<a name="line-42"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreUtils</span>
<a name="line-43"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MkCore</span>
<a name="line-44"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MkId</span>
<a name="line-45"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Id</span>
<a name="line-46"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span>
<a name="line-47"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Name</span>
<a name="line-48"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Literal</span>
<a name="line-49"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TyCon</span>
<a name="line-50"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DataCon</span>
<a name="line-51"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Type</span>
<a name="line-52"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Coercion</span>
<a name="line-53"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TysPrim</span>
<a name="line-54"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TysWiredIn</span>
<a name="line-55"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>BasicTypes</span>
<a name="line-56"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>UniqSet</span>
<a name="line-57"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>UniqSupply</span>
<a name="line-58"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrelNames</span>
<a name="line-59"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
<a name="line-60"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>SrcLoc</span>
<a name="line-61"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Util</span>
<a name="line-62"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>ListSetOps</span>
<a name="line-63"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>FastString</span>
<a name="line-64"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>StaticFlags</span>
</pre>\end{code}
%************************************************************************
%* *
Rebindable syntax
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="dsSyntaxTable"></a><span class='hs-definition'>dsSyntaxTable</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SyntaxTable</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-keyglyph'>[</span><span class='hs-conid'>CoreBind</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Auxiliary bindings</span>
<a name="line-3"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Name</span><span class='hs-layout'>,</span><span class='hs-conid'>Id</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Maps the standard name to its value</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-definition'>dsSyntaxTable</span> <span class='hs-varid'>rebound_ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-6"></a> <span class='hs-layout'>(</span><span class='hs-varid'>binds_s</span><span class='hs-layout'>,</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-varid'>mk_bind</span> <span class='hs-varid'>rebound_ids</span>
<a name="line-7"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>concat</span> <span class='hs-varid'>binds_s</span><span class='hs-layout'>,</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-keyword'>where</span>
<a name="line-9"></a> <span class='hs-comment'>-- The cheapo special case can happen when we </span>
<a name="line-10"></a> <span class='hs-comment'>-- make an intermediate HsDo when desugaring a RecStmt</span>
<a name="line-11"></a> <span class='hs-varid'>mk_bind</span> <span class='hs-layout'>(</span><span class='hs-varid'>std_name</span><span class='hs-layout'>,</span> <span class='hs-conid'>HsVar</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>std_name</span><span class='hs-layout'>,</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-12"></a> <span class='hs-varid'>mk_bind</span> <span class='hs-layout'>(</span><span class='hs-varid'>std_name</span><span class='hs-layout'>,</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-13"></a> <span class='hs-varid'>rhs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsExpr</span> <span class='hs-varid'>expr</span>
<a name="line-14"></a> <span class='hs-varid'>id</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>exprType</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>id</span> <span class='hs-varid'>rhs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>std_name</span><span class='hs-layout'>,</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-16"></a>
<a name="line-17"></a><a name="lookupEvidence"></a><span class='hs-definition'>lookupEvidence</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Name</span><span class='hs-layout'>,</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Name</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span>
<a name="line-18"></a><span class='hs-definition'>lookupEvidence</span> <span class='hs-varid'>prs</span> <span class='hs-varid'>std_name</span>
<a name="line-19"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>assocDefault</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_panic</span> <span class='hs-varid'>std_name</span><span class='hs-layout'>)</span> <span class='hs-varid'>prs</span> <span class='hs-varid'>std_name</span>
<a name="line-20"></a> <span class='hs-keyword'>where</span>
<a name="line-21"></a> <span class='hs-varid'>mk_panic</span> <span class='hs-varid'>std_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"dsSyntaxTable"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"Not found:"</span><span class='hs-layout'>)</span> <span class='hs-varop'><+></span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>std_name</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{ Selecting match variables}
%* *
%************************************************************************
We're about to match against some patterns. We want to make some
@Ids@ to use as match variables. If a pattern has an @Id@ readily at
hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.
\begin{code}
<pre><a name="line-1"></a><a name="selectSimpleMatchVarL"></a><span class='hs-definition'>selectSimpleMatchVarL</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-conid'>DsM</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a><span class='hs-definition'>selectSimpleMatchVarL</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>selectMatchVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-3"></a>
<a name="line-4"></a><span class='hs-comment'>-- (selectMatchVars ps tys) chooses variables of type tys</span>
<a name="line-5"></a><span class='hs-comment'>-- to use for matching ps against. If the pattern is a variable,</span>
<a name="line-6"></a><span class='hs-comment'>-- we try to use that, to save inventing lots of fresh variables.</span>
<a name="line-7"></a><span class='hs-comment'>--</span>
<a name="line-8"></a><span class='hs-comment'>-- OLD, but interesting note:</span>
<a name="line-9"></a><span class='hs-comment'>-- But even if it is a variable, its type might not match. Consider</span>
<a name="line-10"></a><span class='hs-comment'>-- data T a where</span>
<a name="line-11"></a><span class='hs-comment'>-- T1 :: Int -> T Int</span>
<a name="line-12"></a><span class='hs-comment'>-- T2 :: a -> T a</span>
<a name="line-13"></a><span class='hs-comment'>--</span>
<a name="line-14"></a><span class='hs-comment'>-- f :: T a -> a -> Int</span>
<a name="line-15"></a><span class='hs-comment'>-- f (T1 i) (x::Int) = x</span>
<a name="line-16"></a><span class='hs-comment'>-- f (T2 i) (y::a) = 0</span>
<a name="line-17"></a><span class='hs-comment'>-- Then we must not choose (x::Int) as the matching variable!</span>
<a name="line-18"></a><span class='hs-comment'>-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat</span>
<a name="line-19"></a>
<a name="line-20"></a><a name="selectMatchVars"></a><span class='hs-definition'>selectMatchVars</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Pat</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span>
<a name="line-21"></a><span class='hs-definition'>selectMatchVars</span> <span class='hs-varid'>ps</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>selectMatchVar</span> <span class='hs-varid'>ps</span>
<a name="line-22"></a>
<a name="line-23"></a><a name="selectMatchVar"></a><span class='hs-definition'>selectMatchVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Pat</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>Id</span>
<a name="line-24"></a><span class='hs-definition'>selectMatchVar</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'>selectMatchVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-25"></a><span class='hs-definition'>selectMatchVar</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'>selectMatchVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-26"></a><span class='hs-definition'>selectMatchVar</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'>selectMatchVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-27"></a><span class='hs-definition'>selectMatchVar</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-varid'>return</span> <span class='hs-varid'>var</span>
<a name="line-28"></a><span class='hs-definition'>selectMatchVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>AsPat</span> <span class='hs-varid'>var</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span>
<a name="line-29"></a><span class='hs-definition'>selectMatchVar</span> <span class='hs-varid'>other_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsPatType</span> <span class='hs-varid'>other_pat</span><span class='hs-layout'>)</span>
<a name="line-30"></a> <span class='hs-comment'>-- OK, better make up one...</span>
</pre>\end{code}
%************************************************************************
%* *
%* type synonym EquationInfo and access functions for its pieces *
%* *
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
\begin{code}
<pre><a name="line-1"></a><a name="firstPat"></a><span class='hs-definition'>firstPat</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>EquationInfo</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Pat</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a><span class='hs-definition'>firstPat</span> <span class='hs-varid'>eqn</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>notNull</span> <span class='hs-layout'>(</span><span class='hs-varid'>eqn_pats</span> <span class='hs-varid'>eqn</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span> <span class='hs-varid'>head</span> <span class='hs-layout'>(</span><span class='hs-varid'>eqn_pats</span> <span class='hs-varid'>eqn</span><span class='hs-layout'>)</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="shiftEqns"></a><span class='hs-definition'>shiftEqns</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>EquationInfo</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>EquationInfo</span><span class='hs-keyglyph'>]</span>
<a name="line-5"></a><span class='hs-comment'>-- Drop the first pattern in each equation</span>
<a name="line-6"></a><span class='hs-definition'>shiftEqns</span> <span class='hs-varid'>eqns</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>eqn</span> <span class='hs-layout'>{</span> <span class='hs-varid'>eqn_pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tail</span> <span class='hs-layout'>(</span><span class='hs-varid'>eqn_pats</span> <span class='hs-varid'>eqn</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>eqn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>eqns</span> <span class='hs-keyglyph'>]</span>
</pre>\end{code}
Functions on MatchResults
\begin{code}
<pre><a name="line-1"></a><a name="matchCanFail"></a><span class='hs-definition'>matchCanFail</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-2"></a><span class='hs-definition'>matchCanFail</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-3"></a><span class='hs-definition'>matchCanFail</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CantFail</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-4"></a>
<a name="line-5"></a><a name="alwaysFailMatchResult"></a><span class='hs-definition'>alwaysFailMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MatchResult</span>
<a name="line-6"></a><span class='hs-definition'>alwaysFailMatchResult</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>fail</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span>
<a name="line-7"></a>
<a name="line-8"></a><a name="cantFailMatchResult"></a><span class='hs-definition'>cantFailMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-9"></a><span class='hs-definition'>cantFailMatchResult</span> <span class='hs-varid'>expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CantFail</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span>
<a name="line-10"></a>
<a name="line-11"></a><a name="extractMatchResult"></a><span class='hs-definition'>extractMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <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'>extractMatchResult</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CantFail</span> <span class='hs-varid'>match_fn</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span>
<a name="line-13"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>match_fn</span> <span class='hs-layout'>(</span><span class='hs-varid'>error</span> <span class='hs-str'>"It can't fail!"</span><span class='hs-layout'>)</span>
<a name="line-14"></a>
<a name="line-15"></a><span class='hs-definition'>extractMatchResult</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-varid'>match_fn</span><span class='hs-layout'>)</span> <span class='hs-varid'>fail_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-16"></a> <span class='hs-layout'>(</span><span class='hs-varid'>fail_bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>if_it_fails</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkFailurePair</span> <span class='hs-varid'>fail_expr</span>
<a name="line-17"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>match_fn</span> <span class='hs-varid'>if_it_fails</span>
<a name="line-18"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoreLet</span> <span class='hs-varid'>fail_bind</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a>
<a name="line-21"></a><a name="combineMatchResults"></a><span class='hs-definition'>combineMatchResults</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-22"></a><span class='hs-definition'>combineMatchResults</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-varid'>body_fn1</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail2</span> <span class='hs-varid'>body_fn2</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail2</span> <span class='hs-varid'>body_fn</span>
<a name="line-25"></a> <span class='hs-keyword'>where</span>
<a name="line-26"></a> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>body2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>body_fn2</span> <span class='hs-varid'>fail</span>
<a name="line-27"></a> <span class='hs-layout'>(</span><span class='hs-varid'>fail_bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>duplicatable_expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkFailurePair</span> <span class='hs-varid'>body2</span>
<a name="line-28"></a> <span class='hs-varid'>body1</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>body_fn1</span> <span class='hs-varid'>duplicatable_expr</span>
<a name="line-29"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-varid'>fail_bind</span> <span class='hs-varid'>body1</span><span class='hs-layout'>)</span>
<a name="line-30"></a>
<a name="line-31"></a><span class='hs-definition'>combineMatchResults</span> <span class='hs-varid'>match_result1</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CantFail</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span>
<a name="line-32"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>match_result1</span>
<a name="line-33"></a>
<a name="line-34"></a><a name="adjustMatchResult"></a><span class='hs-definition'>adjustMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DsWrapper</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-35"></a><span class='hs-definition'>adjustMatchResult</span> <span class='hs-varid'>encl_fn</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail</span> <span class='hs-varid'>body_fn</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>fail</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>encl_fn</span> <span class='hs-varop'><$></span> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span>
<a name="line-37"></a>
<a name="line-38"></a><a name="adjustMatchResultDs"></a><span class='hs-definition'>adjustMatchResultDs</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-39"></a><span class='hs-definition'>adjustMatchResultDs</span> <span class='hs-varid'>encl_fn</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail</span> <span class='hs-varid'>body_fn</span><span class='hs-layout'>)</span>
<a name="line-40"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>fail</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>encl_fn</span> <span class='hs-varop'>=<<</span> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span>
<a name="line-41"></a>
<a name="line-42"></a><a name="wrapBinds"></a><span class='hs-definition'>wrapBinds</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Var</span><span class='hs-layout'>,</span><span class='hs-conid'>Var</span><span class='hs-layout'>)</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-43"></a><span class='hs-definition'>wrapBinds</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>e</span>
<a name="line-44"></a><span class='hs-definition'>wrapBinds</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>new</span><span class='hs-layout'>,</span><span class='hs-varid'>old</span><span class='hs-layout'>)</span><span class='hs-conop'>:</span><span class='hs-varid'>prs</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>wrapBind</span> <span class='hs-varid'>new</span> <span class='hs-varid'>old</span> <span class='hs-layout'>(</span><span class='hs-varid'>wrapBinds</span> <span class='hs-varid'>prs</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-45"></a>
<a name="line-46"></a><a name="wrapBind"></a><span class='hs-definition'>wrapBind</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Var</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Var</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-47"></a><span class='hs-definition'>wrapBind</span> <span class='hs-varid'>new</span> <span class='hs-varid'>old</span> <span class='hs-varid'>body</span> <span class='hs-comment'>-- Can deal with term variables *or* type variables</span>
<a name="line-48"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>new</span><span class='hs-varop'>==</span><span class='hs-varid'>old</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>body</span>
<a name="line-49"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>new</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkTyBind</span> <span class='hs-varid'>new</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkTyVarTy</span> <span class='hs-varid'>old</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span>
<a name="line-50"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>new</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>old</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span>
<a name="line-51"></a>
<a name="line-52"></a><a name="seqVar"></a><span class='hs-definition'>seqVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Var</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-53"></a><span class='hs-definition'>seqVar</span> <span class='hs-varid'>var</span> <span class='hs-varid'>body</span> <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'>var</span><span class='hs-layout'>)</span> <span class='hs-varid'>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-54"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-55"></a>
<a name="line-56"></a><a name="mkCoLetMatchResult"></a><span class='hs-definition'>mkCoLetMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreBind</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-57"></a><span class='hs-definition'>mkCoLetMatchResult</span> <span class='hs-varid'>bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>adjustMatchResult</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoreLet</span> <span class='hs-varid'>bind</span><span class='hs-layout'>)</span>
<a name="line-58"></a>
<a name="line-59"></a><a name="mkViewMatchResult"></a><span class='hs-comment'>-- (mkViewMatchResult var' viewExpr var mr) makes the expression</span>
<a name="line-60"></a><span class='hs-comment'>-- let var' = viewExpr var in mr</span>
<a name="line-61"></a><span class='hs-definition'>mkViewMatchResult</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'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-62"></a><span class='hs-definition'>mkViewMatchResult</span> <span class='hs-varid'>var'</span> <span class='hs-varid'>viewExpr</span> <span class='hs-varid'>var</span> <span class='hs-keyglyph'>=</span>
<a name="line-63"></a> <span class='hs-varid'>adjustMatchResult</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoreLet</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>var'</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoreAppDs</span> <span class='hs-varid'>viewExpr</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-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-64"></a>
<a name="line-65"></a><a name="mkEvalMatchResult"></a><span class='hs-definition'>mkEvalMatchResult</span> <span class='hs-keyglyph'>::</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'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-66"></a><span class='hs-definition'>mkEvalMatchResult</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span>
<a name="line-67"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>adjustMatchResult</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>e</span> <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'>var</span><span class='hs-layout'>)</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-68"></a>
<a name="line-69"></a><a name="mkGuardedMatchResult"></a><span class='hs-definition'>mkGuardedMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-70"></a><span class='hs-definition'>mkGuardedMatchResult</span> <span class='hs-varid'>pred_expr</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchResult</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>body_fn</span><span class='hs-layout'>)</span>
<a name="line-71"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>fail</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span>
<a name="line-72"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkIfThenElse</span> <span class='hs-varid'>pred_expr</span> <span class='hs-varid'>body</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-73"></a>
<a name="line-74"></a><a name="mkCoPrimCaseMatchResult"></a><span class='hs-definition'>mkCoPrimCaseMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- Scrutinee</span>
<a name="line-75"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- Type of the case</span>
<a name="line-76"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Literal</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Alternatives</span>
<a name="line-77"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-78"></a><span class='hs-definition'>mkCoPrimCaseMatchResult</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>match_alts</span>
<a name="line-79"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-varid'>mk_case</span>
<a name="line-80"></a> <span class='hs-keyword'>where</span>
<a name="line-81"></a> <span class='hs-varid'>mk_case</span> <span class='hs-varid'>fail</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-82"></a> <span class='hs-varid'>alts</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_alt</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span> <span class='hs-varid'>sorted_alts</span>
<a name="line-83"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Case</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-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-84"></a>
<a name="line-85"></a> <span class='hs-varid'>sorted_alts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sortWith</span> <span class='hs-varid'>fst</span> <span class='hs-varid'>match_alts</span> <span class='hs-comment'>-- Right order for a Case</span>
<a name="line-86"></a> <span class='hs-varid'>mk_alt</span> <span class='hs-varid'>fail</span> <span class='hs-layout'>(</span><span class='hs-varid'>lit</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>body_fn</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span>
<a name="line-87"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>LitAlt</span> <span class='hs-varid'>lit</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-88"></a>
<a name="line-89"></a>
<a name="line-90"></a><a name="mkCoAlgCaseMatchResult"></a><span class='hs-definition'>mkCoAlgCaseMatchResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- Scrutinee</span>
<a name="line-91"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- Type of exp</span>
<a name="line-92"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DataCon</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBndr</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Alternatives</span>
<a name="line-93"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MatchResult</span>
<a name="line-94"></a><span class='hs-definition'>mkCoAlgCaseMatchResult</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>match_alts</span>
<a name="line-95"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isNewTyCon</span> <span class='hs-varid'>tycon</span> <span class='hs-comment'>-- Newtype case; use a let</span>
<a name="line-96"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>null</span> <span class='hs-layout'>(</span><span class='hs-varid'>tail</span> <span class='hs-varid'>match_alts</span><span class='hs-layout'>)</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>null</span> <span class='hs-layout'>(</span><span class='hs-varid'>tail</span> <span class='hs-varid'>arg_ids1</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-97"></a> <span class='hs-varid'>mkCoLetMatchResult</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>arg_id1</span> <span class='hs-varid'>newtype_rhs</span><span class='hs-layout'>)</span> <span class='hs-varid'>match_result1</span>
<a name="line-98"></a>
<a name="line-99"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isPArrFakeAlts</span> <span class='hs-varid'>match_alts</span> <span class='hs-comment'>-- Sugared parallel array; use a literal case </span>
<a name="line-100"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-conid'>CanFail</span> <span class='hs-varid'>mk_parrCase</span>
<a name="line-101"></a>
<a name="line-102"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- Datatype case; use a case</span>
<a name="line-103"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MatchResult</span> <span class='hs-varid'>fail_flag</span> <span class='hs-varid'>mk_case</span>
<a name="line-104"></a> <span class='hs-keyword'>where</span>
<a name="line-105"></a> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConTyCon</span> <span class='hs-varid'>con1</span>
<a name="line-106"></a> <span class='hs-comment'>-- [Interesting: becuase of GADTs, we can't rely on the type of </span>
<a name="line-107"></a> <span class='hs-comment'>-- the scrutinised Id to be sufficiently refined to have a TyCon in it]</span>
<a name="line-108"></a>
<a name="line-109"></a> <span class='hs-comment'>-- Stuff for newtype</span>
<a name="line-110"></a> <span class='hs-layout'>(</span><span class='hs-varid'>con1</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_ids1</span><span class='hs-layout'>,</span> <span class='hs-varid'>match_result1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>notNull</span> <span class='hs-varid'>match_alts</span> <span class='hs-layout'>)</span> <span class='hs-varid'>head</span> <span class='hs-varid'>match_alts</span>
<a name="line-111"></a> <span class='hs-varid'>arg_id1</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>notNull</span> <span class='hs-varid'>arg_ids1</span> <span class='hs-layout'>)</span> <span class='hs-varid'>head</span> <span class='hs-varid'>arg_ids1</span>
<a name="line-112"></a> <span class='hs-varid'>var_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>idType</span> <span class='hs-varid'>var</span>
<a name="line-113"></a> <span class='hs-layout'>(</span><span class='hs-varid'>tc</span><span class='hs-layout'>,</span> <span class='hs-varid'>ty_args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcSplitTyConApp</span> <span class='hs-varid'>var_ty</span> <span class='hs-comment'>-- Don't look through newtypes</span>
<a name="line-114"></a> <span class='hs-comment'>-- (not that splitTyConApp does, these days)</span>
<a name="line-115"></a> <span class='hs-varid'>newtype_rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unwrapNewTypeBody</span> <span class='hs-varid'>tc</span> <span class='hs-varid'>ty_args</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span>
<a name="line-116"></a>
<a name="line-117"></a> <span class='hs-comment'>-- Stuff for data types</span>
<a name="line-118"></a> <span class='hs-varid'>data_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span>
<a name="line-119"></a> <span class='hs-varid'>match_results</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>match_result</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'>match_result</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>match_alts</span><span class='hs-keyglyph'>]</span>
<a name="line-120"></a>
<a name="line-121"></a> <span class='hs-varid'>fail_flag</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>exhaustive_case</span>
<a name="line-122"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr1</span> <span class='hs-varid'>orFail</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>can_it_fail</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>MatchResult</span> <span class='hs-varid'>can_it_fail</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>match_results</span><span class='hs-keyglyph'>]</span>
<a name="line-123"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-124"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>CanFail</span>
<a name="line-125"></a>
<a name="line-126"></a> <span class='hs-varid'>sorted_alts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sortWith</span> <span class='hs-varid'>get_tag</span> <span class='hs-varid'>match_alts</span>
<a name="line-127"></a> <span class='hs-varid'>get_tag</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</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-keyglyph'>=</span> <span class='hs-varid'>dataConTag</span> <span class='hs-varid'>con</span>
<a name="line-128"></a> <span class='hs-varid'>mk_case</span> <span class='hs-varid'>fail</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>alts</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_alt</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span> <span class='hs-varid'>sorted_alts</span>
<a name="line-129"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkWildCase</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-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_default</span> <span class='hs-varid'>fail</span> <span class='hs-varop'>++</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-130"></a>
<a name="line-131"></a> <span class='hs-varid'>mk_alt</span> <span class='hs-varid'>fail</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>body_fn</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-132"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>body_fn</span> <span class='hs-varid'>fail</span>
<a name="line-133"></a> <span class='hs-varid'>us</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUniqueSupply</span>
<a name="line-134"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkReboxingAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>uniqsFromSupply</span> <span class='hs-varid'>us</span><span class='hs-layout'>)</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-135"></a>
<a name="line-136"></a> <span class='hs-varid'>mk_default</span> <span class='hs-varid'>fail</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>exhaustive_case</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-137"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-138"></a>
<a name="line-139"></a> <span class='hs-varid'>un_mentioned_constructors</span>
<a name="line-140"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkUniqSet</span> <span class='hs-varid'>data_cons</span> <span class='hs-varop'>`minusUniqSet`</span> <span class='hs-varid'>mkUniqSet</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</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-keyglyph'><-</span> <span class='hs-varid'>match_alts</span><span class='hs-keyglyph'>]</span>
<a name="line-141"></a> <span class='hs-varid'>exhaustive_case</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isEmptyUniqSet</span> <span class='hs-varid'>un_mentioned_constructors</span>
<a name="line-142"></a>
<a name="line-143"></a> <span class='hs-comment'>-- Stuff for parallel arrays</span>
<a name="line-144"></a> <span class='hs-comment'>-- </span>
<a name="line-145"></a> <span class='hs-comment'>-- * the following is to desugar cases over fake constructors for</span>
<a name="line-146"></a> <span class='hs-comment'>-- parallel arrays, which are introduced by `tidy1' in the `PArrPat'</span>
<a name="line-147"></a> <span class='hs-comment'>-- case</span>
<a name="line-148"></a> <span class='hs-comment'>--</span>
<a name="line-149"></a> <span class='hs-comment'>-- Concerning `isPArrFakeAlts':</span>
<a name="line-150"></a> <span class='hs-comment'>--</span>
<a name="line-151"></a> <span class='hs-comment'>-- * it is *not* sufficient to just check the type of the type</span>
<a name="line-152"></a> <span class='hs-comment'>-- constructor, as we have to be careful not to confuse the real</span>
<a name="line-153"></a> <span class='hs-comment'>-- representation of parallel arrays with the fake constructors;</span>
<a name="line-154"></a> <span class='hs-comment'>-- moreover, a list of alternatives must not mix fake and real</span>
<a name="line-155"></a> <span class='hs-comment'>-- constructors (this is checked earlier on)</span>
<a name="line-156"></a> <span class='hs-comment'>--</span>
<a name="line-157"></a> <span class='hs-comment'>-- FIXME: We actually go through the whole list and make sure that</span>
<a name="line-158"></a> <span class='hs-comment'>-- either all or none of the constructors are fake parallel</span>
<a name="line-159"></a> <span class='hs-comment'>-- array constructors. This is to spot equations that mix fake</span>
<a name="line-160"></a> <span class='hs-comment'>-- constructors with the real representation defined in</span>
<a name="line-161"></a> <span class='hs-comment'>-- `PrelPArr'. It would be nicer to spot this situation</span>
<a name="line-162"></a> <span class='hs-comment'>-- earlier and raise a proper error message, but it can really</span>
<a name="line-163"></a> <span class='hs-comment'>-- only happen in `PrelPArr' anyway.</span>
<a name="line-164"></a> <span class='hs-comment'>--</span>
<a name="line-165"></a> <span class='hs-varid'>isPArrFakeAlts</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>dcon</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-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isPArrFakeCon</span> <span class='hs-varid'>dcon</span>
<a name="line-166"></a> <span class='hs-varid'>isPArrFakeAlts</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>dcon</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-conop'>:</span><span class='hs-varid'>alts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<a name="line-167"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>isPArrFakeCon</span> <span class='hs-varid'>dcon</span><span class='hs-layout'>,</span> <span class='hs-varid'>isPArrFakeAlts</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-168"></a> <span class='hs-layout'>(</span><span class='hs-conid'>True</span> <span class='hs-layout'>,</span> <span class='hs-conid'>True</span> <span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span>
<a name="line-169"></a> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span>
<a name="line-170"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>panic</span> <span class='hs-str'>"DsUtils: you may not mix `[:...:]' with `PArr' patterns"</span>
<a name="line-171"></a> <span class='hs-varid'>isPArrFakeAlts</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"DsUtils: unexpectedly found an empty list of PArr fake alternatives"</span>
<a name="line-172"></a> <span class='hs-comment'>--</span>
<a name="line-173"></a> <span class='hs-varid'>mk_parrCase</span> <span class='hs-varid'>fail</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-174"></a> <span class='hs-varid'>lengthP</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupGlobalId</span> <span class='hs-varid'>lengthPName</span>
<a name="line-175"></a> <span class='hs-varid'>alt</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>unboxAlt</span>
<a name="line-176"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkWildCase</span> <span class='hs-layout'>(</span><span class='hs-varid'>len</span> <span class='hs-varid'>lengthP</span><span class='hs-layout'>)</span> <span class='hs-varid'>intTy</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>alt</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-177"></a> <span class='hs-keyword'>where</span>
<a name="line-178"></a> <span class='hs-varid'>elemTy</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>splitTyConApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-179"></a> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>elemTy</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>elemTy</span>
<a name="line-180"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>panic</span> <span class='hs-varid'>panicMsg</span>
<a name="line-181"></a> <span class='hs-varid'>panicMsg</span> <span class='hs-keyglyph'>=</span> <span class='hs-str'>"DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"</span>
<a name="line-182"></a> <span class='hs-varid'>len</span> <span class='hs-varid'>lengthP</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>lengthP</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>elemTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>var</span><span class='hs-keyglyph'>]</span>
<a name="line-183"></a> <span class='hs-comment'>--</span>
<a name="line-184"></a> <span class='hs-varid'>unboxAlt</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-185"></a> <span class='hs-varid'>l</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>intPrimTy</span>
<a name="line-186"></a> <span class='hs-varid'>indexP</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLookupGlobalId</span> <span class='hs-varid'>indexPName</span>
<a name="line-187"></a> <span class='hs-varid'>alts</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkAlt</span> <span class='hs-varid'>indexP</span><span class='hs-layout'>)</span> <span class='hs-varid'>sorted_alts</span>
<a name="line-188"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>intDataCon</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>l</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkWildCase</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>l</span><span class='hs-layout'>)</span> <span class='hs-varid'>intPrimTy</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>dft</span> <span class='hs-conop'>:</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-189"></a> <span class='hs-keyword'>where</span>
<a name="line-190"></a> <span class='hs-varid'>dft</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>fail</span><span class='hs-layout'>)</span>
<a name="line-191"></a> <span class='hs-comment'>--</span>
<a name="line-192"></a> <span class='hs-comment'>-- each alternative matches one array length (corresponding to one</span>
<a name="line-193"></a> <span class='hs-comment'>-- fake array constructor), so the match is on a literal; each</span>
<a name="line-194"></a> <span class='hs-comment'>-- alternative's body is extended by a local binding for each</span>
<a name="line-195"></a> <span class='hs-comment'>-- constructor argument, which are bound to array elements starting</span>
<a name="line-196"></a> <span class='hs-comment'>-- with the first</span>
<a name="line-197"></a> <span class='hs-comment'>--</span>
<a name="line-198"></a> <span class='hs-varid'>mkAlt</span> <span class='hs-varid'>indexP</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>bodyFun</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-199"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bodyFun</span> <span class='hs-varid'>fail</span>
<a name="line-200"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>LitAlt</span> <span class='hs-varid'>lit</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkCoreLets</span> <span class='hs-varid'>binds</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-201"></a> <span class='hs-keyword'>where</span>
<a name="line-202"></a> <span class='hs-varid'>lit</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MachInt</span> <span class='hs-varop'>$</span> <span class='hs-varid'>toInteger</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span>
<a name="line-203"></a> <span class='hs-varid'>binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>arg</span> <span class='hs-layout'>(</span><span class='hs-varid'>indexExpr</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>zip</span> <span class='hs-keyglyph'>[</span><span class='hs-num'>1</span><span class='hs-keyglyph'>..</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>args</span><span class='hs-keyglyph'>]</span>
<a name="line-204"></a> <span class='hs-comment'>--</span>
<a name="line-205"></a> <span class='hs-varid'>indexExpr</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>indexP</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>elemTy</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-varid'>mkIntExpr</span> <span class='hs-varid'>i</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Desugarer's versions of some Core functions}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="mkErrorAppDs"></a><span class='hs-definition'>mkErrorAppDs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- The error function</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- Type to which it should be applied</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SDoc</span> <span class='hs-comment'>-- The error message string to pass</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-5"></a>
<a name="line-6"></a><span class='hs-definition'>mkErrorAppDs</span> <span class='hs-varid'>err_id</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>msg</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-7"></a> <span class='hs-varid'>src_loc</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getSrcSpanDs</span>
<a name="line-8"></a> <span class='hs-keyword'>let</span>
<a name="line-9"></a> <span class='hs-varid'>full_msg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>showSDoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>hcat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>src_loc</span><span class='hs-layout'>,</span> <span class='hs-varid'>text</span> <span class='hs-str'>"|"</span><span class='hs-layout'>,</span> <span class='hs-varid'>msg</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-10"></a> <span class='hs-varid'>core_msg</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Lit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkMachString</span> <span class='hs-varid'>full_msg</span><span class='hs-layout'>)</span>
<a name="line-11"></a> <span class='hs-comment'>-- mkMachString returns a result of type String#</span>
<a name="line-12"></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'>Var</span> <span class='hs-varid'>err_id</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span> <span class='hs-varid'>ty</span><span class='hs-layout'>,</span> <span class='hs-varid'>core_msg</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>\end{code}
'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
Note [Desugaring seq (1)] cf Trac #1031
~~~~~~~~~~~~~~~~~~~~~~~~~
f x y = x `seq` (y `seq` (# x,y #))
The [CoreSyn let/app invariant] means that, other things being equal, because
the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
But that is bad for two reasons:
(a) we now evaluate y before x, and
(b) we can't bind v to an unboxed pair
Seq is very, very special! So we recognise it right here, and desugar to
case x of _ -> case y of _ -> (# x,y #)
Note [Desugaring seq (2)] cf Trac #2231
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
let chp = case b of { True -> fst x; False -> 0 }
in chp `seq` ...chp...
Here the seq is designed to plug the space leak of retaining (snd x)
for too long.
If we rely on the ordinary inlining of seq, we'll get
let chp = case b of { True -> fst x; False -> 0 }
case chp of _ { I# -> ...chp... }
But since chp is cheap, and the case is an alluring contet, we'll
inline chp into the case scrutinee. Now there is only one use of chp,
so we'll inline a second copy. Alas, we've now ruined the purpose of
the seq, by re-introducing the space leak:
case (case b of {True -> fst x; False -> 0}) of
I# _ -> ...case b of {True -> fst x; False -> 0}...
We can try to avoid doing this by ensuring that the binder-swap in the
case happens, so we get his at an early stage:
case chp of chp2 { I# -> ...chp2... }
But this is fragile. The real culprit is the source program. Perhaps we
should have said explicitly
let !chp2 = chp in ...chp2...
But that's painful. So the code here does a little hack to make seq
more robust: a saturated application of 'seq' is turned *directly* into
the case expression. So we desugar to:
let chp = case b of { True -> fst x; False -> 0 }
case chp of chp { I# -> ...chp... }
Notice the shadowing of the case binder! And now all is well.
The reason it's a hack is because if you define mySeq=seq, the hack
won't work on mySeq.
Note [Desugaring seq (3)] cf Trac #2409
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The isLocalId ensures that we don't turn
True `seq` e
into
case True of True { ... }
which stupidly tries to bind the datacon 'True'.
\begin{code}
<pre><a name="line-1"></a><a name="mkCoreAppDs"></a><span class='hs-definition'>mkCoreAppDs</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-2"></a><span class='hs-definition'>mkCoreAppDs</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>f</span> <span class='hs-varop'>`App`</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>ty1</span> <span class='hs-varop'>`App`</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>ty2</span> <span class='hs-varop'>`App`</span> <span class='hs-varid'>arg1</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg2</span>
<a name="line-3"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>f</span> <span class='hs-varop'>`hasKey`</span> <span class='hs-varid'>seqIdKey</span> <span class='hs-comment'>-- Note [Desugaring seq (1), (2)]</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Case</span> <span class='hs-varid'>arg1</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>ty2</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span><span class='hs-varid'>arg2</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-5"></a> <span class='hs-keyword'>where</span>
<a name="line-6"></a> <span class='hs-varid'>case_bndr</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>arg1</span> <span class='hs-keyword'>of</span>
<a name="line-7"></a> <span class='hs-conid'>Var</span> <span class='hs-varid'>v1</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isLocalId</span> <span class='hs-varid'>v1</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>v1</span> <span class='hs-comment'>-- Note [Desugaring seq (2) and (3)]</span>
<a name="line-8"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mkWildBinder</span> <span class='hs-varid'>ty1</span>
<a name="line-9"></a>
<a name="line-10"></a><span class='hs-definition'>mkCoreAppDs</span> <span class='hs-varid'>fun</span> <span class='hs-varid'>arg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCoreApp</span> <span class='hs-varid'>fun</span> <span class='hs-varid'>arg</span> <span class='hs-comment'>-- The rest is done in MkCore</span>
<a name="line-11"></a>
<a name="line-12"></a><a name="mkCoreAppsDs"></a><span class='hs-definition'>mkCoreAppsDs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</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-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-13"></a><span class='hs-definition'>mkCoreAppsDs</span> <span class='hs-varid'>fun</span> <span class='hs-varid'>args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl</span> <span class='hs-varid'>mkCoreAppDs</span> <span class='hs-varid'>fun</span> <span class='hs-varid'>args</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection[mkSelectorBind]{Make a selector bind}
%* *
%************************************************************************
This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
\begin{verbatim}
b = case v of pat' -> b'
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
ToDo: making these bindings should really depend on whether there's
much work to be done per binding. If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).
Boring! Boring! One error message per binder. The above ToDo is
even more helpful. Something very similar happens for pattern-bound
expressions.
\begin{code}
<pre><a name="line-1"></a><a name="mkSelectorBinds"></a><span class='hs-definition'>mkSelectorBinds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- The pattern</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- Expression to which the pattern is bound</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Id</span><span class='hs-layout'>,</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-definition'>mkSelectorBinds</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'>VarPat</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>val_expr</span>
<a name="line-6"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>,</span> <span class='hs-varid'>val_expr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-7"></a>
<a name="line-8"></a><span class='hs-definition'>mkSelectorBinds</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>val_expr</span>
<a name="line-9"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSingleton</span> <span class='hs-varid'>binders</span> <span class='hs-varop'>||</span> <span class='hs-varid'>is_simple_lpat</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-10"></a> <span class='hs-comment'>-- Given p = e, where p binds x,y</span>
<a name="line-11"></a> <span class='hs-comment'>-- we are going to make</span>
<a name="line-12"></a> <span class='hs-comment'>-- v = p (where v is fresh)</span>
<a name="line-13"></a> <span class='hs-comment'>-- x = case v of p -> x</span>
<a name="line-14"></a> <span class='hs-comment'>-- y = case v of p -> x</span>
<a name="line-15"></a>
<a name="line-16"></a> <span class='hs-comment'>-- Make up 'v'</span>
<a name="line-17"></a> <span class='hs-comment'>-- NB: give it the type of *pattern* p, not the type of the *rhs* e.</span>
<a name="line-18"></a> <span class='hs-comment'>-- This does not matter after desugaring, but there's a subtle </span>
<a name="line-19"></a> <span class='hs-comment'>-- issue with implicit parameters. Consider</span>
<a name="line-20"></a> <span class='hs-comment'>-- (x,y) = ?i</span>
<a name="line-21"></a> <span class='hs-comment'>-- Then, ?i is given type {?i :: Int}, a PredType, which is opaque</span>
<a name="line-22"></a> <span class='hs-comment'>-- to the desugarer. (Why opaque? Because newtypes have to be. Why</span>
<a name="line-23"></a> <span class='hs-comment'>-- does it get that type? So that when we abstract over it we get the</span>
<a name="line-24"></a> <span class='hs-comment'>-- right top-level type (?i::Int) => ...)</span>
<a name="line-25"></a> <span class='hs-comment'>--</span>
<a name="line-26"></a> <span class='hs-comment'>-- So to get the type of 'v', use the pattern not the rhs. Often more</span>
<a name="line-27"></a> <span class='hs-comment'>-- efficient too.</span>
<a name="line-28"></a> <span class='hs-varid'>val_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsLPatType</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-29"></a>
<a name="line-30"></a> <span class='hs-comment'>-- For the error message we make one error-app, to avoid duplication.</span>
<a name="line-31"></a> <span class='hs-comment'>-- But we need it at different types... so we use coerce for that</span>
<a name="line-32"></a> <span class='hs-varid'>err_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkErrorAppDs</span> <span class='hs-varid'>iRREFUT_PAT_ERROR_ID</span> <span class='hs-varid'>unitTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-varid'>err_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>unitTy</span>
<a name="line-34"></a> <span class='hs-varid'>binds</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_bind</span> <span class='hs-varid'>val_var</span> <span class='hs-varid'>err_var</span><span class='hs-layout'>)</span> <span class='hs-varid'>binders</span>
<a name="line-35"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span> <span class='hs-layout'>(</span><span class='hs-varid'>val_var</span><span class='hs-layout'>,</span> <span class='hs-varid'>val_expr</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span>
<a name="line-36"></a> <span class='hs-layout'>(</span><span class='hs-varid'>err_var</span><span class='hs-layout'>,</span> <span class='hs-varid'>err_expr</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span>
<a name="line-37"></a> <span class='hs-varid'>binds</span> <span class='hs-layout'>)</span>
<a name="line-38"></a>
<a name="line-39"></a>
<a name="line-40"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-41"></a> <span class='hs-varid'>error_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkErrorAppDs</span> <span class='hs-varid'>iRREFUT_PAT_ERROR_ID</span> <span class='hs-varid'>tuple_ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span>
<a name="line-42"></a> <span class='hs-varid'>tuple_expr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>matchSimply</span> <span class='hs-varid'>val_expr</span> <span class='hs-conid'>PatBindRhs</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>local_tuple</span> <span class='hs-varid'>error_expr</span>
<a name="line-43"></a> <span class='hs-varid'>tuple_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>tuple_ty</span>
<a name="line-44"></a> <span class='hs-keyword'>let</span>
<a name="line-45"></a> <span class='hs-varid'>mk_tup_bind</span> <span class='hs-varid'>binder</span>
<a name="line-46"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>binder</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkTupleSelector</span> <span class='hs-varid'>binders</span> <span class='hs-varid'>binder</span> <span class='hs-varid'>tuple_var</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>tuple_var</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-47"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span> <span class='hs-layout'>(</span><span class='hs-varid'>tuple_var</span><span class='hs-layout'>,</span> <span class='hs-varid'>tuple_expr</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>map</span> <span class='hs-varid'>mk_tup_bind</span> <span class='hs-varid'>binders</span> <span class='hs-layout'>)</span>
<a name="line-48"></a> <span class='hs-keyword'>where</span>
<a name="line-49"></a> <span class='hs-varid'>binders</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectPatBinders</span> <span class='hs-varid'>pat</span>
<a name="line-50"></a> <span class='hs-varid'>local_tuple</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigCoreVarTup</span> <span class='hs-varid'>binders</span>
<a name="line-51"></a> <span class='hs-varid'>tuple_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>local_tuple</span>
<a name="line-52"></a>
<a name="line-53"></a> <span class='hs-varid'>mk_bind</span> <span class='hs-varid'>scrut_var</span> <span class='hs-varid'>err_var</span> <span class='hs-varid'>bndr_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-54"></a> <span class='hs-comment'>-- (mk_bind sv err_var) generates</span>
<a name="line-55"></a> <span class='hs-comment'>-- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }</span>
<a name="line-56"></a> <span class='hs-comment'>-- Remember, pat binds bv</span>
<a name="line-57"></a> <span class='hs-varid'>rhs_expr</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'>scrut_var</span><span class='hs-layout'>)</span> <span class='hs-conid'>PatBindRhs</span> <span class='hs-varid'>pat</span>
<a name="line-58"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>bndr_var</span><span class='hs-layout'>)</span> <span class='hs-varid'>error_expr</span>
<a name="line-59"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndr_var</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs_expr</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-keyword'>where</span>
<a name="line-61"></a> <span class='hs-varid'>error_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCoerce</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>err_var</span><span class='hs-layout'>)</span>
<a name="line-62"></a> <span class='hs-varid'>co</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkUnsafeCoercion</span> <span class='hs-layout'>(</span><span class='hs-varid'>exprType</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>err_var</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>bndr_var</span><span class='hs-layout'>)</span>
<a name="line-63"></a>
<a name="line-64"></a> <span class='hs-varid'>is_simple_lpat</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>is_simple_pat</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span>
<a name="line-65"></a>
<a name="line-66"></a> <span class='hs-varid'>is_simple_pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>TuplePat</span> <span class='hs-varid'>ps</span> <span class='hs-conid'>Boxed</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>all</span> <span class='hs-varid'>is_triv_lpat</span> <span class='hs-varid'>ps</span>
<a name="line-67"></a> <span class='hs-varid'>is_simple_pat</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-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>all</span> <span class='hs-varid'>is_triv_lpat</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-68"></a> <span class='hs-varid'>is_simple_pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>VarPat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-69"></a> <span class='hs-varid'>is_simple_pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>ParPat</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>is_simple_lpat</span> <span class='hs-varid'>p</span>
<a name="line-70"></a> <span class='hs-varid'>is_simple_pat</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-71"></a>
<a name="line-72"></a> <span class='hs-varid'>is_triv_lpat</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>is_triv_pat</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span>
<a name="line-73"></a>
<a name="line-74"></a> <span class='hs-varid'>is_triv_pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>VarPat</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-75"></a> <span class='hs-varid'>is_triv_pat</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-conid'>True</span>
<a name="line-76"></a> <span class='hs-varid'>is_triv_pat</span> <span class='hs-layout'>(</span><span class='hs-conid'>ParPat</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>is_triv_lpat</span> <span class='hs-varid'>p</span>
<a name="line-77"></a> <span class='hs-varid'>is_triv_pat</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-78"></a>
</pre>\end{code}
Creating big tuples and their types for full Haskell expressions.
They work over *Ids*, and create tuples replete with their types,
which is whey they are not in HsUtils.
\begin{code}
<pre><a name="line-1"></a><a name="mkLHsPatTup"></a><span class='hs-definition'>mkLHsPatTup</span> <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-keyglyph'>-></span> <span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span>
<a name="line-2"></a><span class='hs-definition'>mkLHsPatTup</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkVanillaTuplePat</span> <span class='hs-conid'>[]</span> <span class='hs-conid'>Boxed</span>
<a name="line-3"></a><span class='hs-definition'>mkLHsPatTup</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>lpat</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lpat</span>
<a name="line-4"></a><span class='hs-definition'>mkLHsPatTup</span> <span class='hs-varid'>lpats</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-layout'>(</span><span class='hs-varid'>getLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>head</span> <span class='hs-varid'>lpats</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span>
<a name="line-5"></a> <span class='hs-varid'>mkVanillaTuplePat</span> <span class='hs-varid'>lpats</span> <span class='hs-conid'>Boxed</span>
<a name="line-6"></a>
<a name="line-7"></a><a name="mkLHsVarPatTup"></a><span class='hs-definition'>mkLHsVarPatTup</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'>LPat</span> <span class='hs-conid'>Id</span>
<a name="line-8"></a><span class='hs-definition'>mkLHsVarPatTup</span> <span class='hs-varid'>bs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkLHsPatTup</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>bs</span><span class='hs-layout'>)</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="mkVanillaTuplePat"></a><span class='hs-definition'>mkVanillaTuplePat</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OutPat</span> <span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Boxity</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Pat</span> <span class='hs-conid'>Id</span>
<a name="line-11"></a><span class='hs-comment'>-- A vanilla tuple pattern simply gets its type from its sub-patterns</span>
<a name="line-12"></a><span class='hs-definition'>mkVanillaTuplePat</span> <span class='hs-varid'>pats</span> <span class='hs-varid'>box</span>
<a name="line-13"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>TuplePat</span> <span class='hs-varid'>pats</span> <span class='hs-varid'>box</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkTupleTy</span> <span class='hs-varid'>box</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-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>hsLPatType</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-14"></a>
<a name="line-15"></a><a name="mkBigLHsVarTup"></a><span class='hs-comment'>-- The Big equivalents for the source tuple expressions</span>
<a name="line-16"></a><span class='hs-definition'>mkBigLHsVarTup</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-17"></a><span class='hs-definition'>mkBigLHsVarTup</span> <span class='hs-varid'>ids</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigLHsTup</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span>
<a name="line-18"></a>
<a name="line-19"></a><a name="mkBigLHsTup"></a><span class='hs-definition'>mkBigLHsTup</span> <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-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>Id</span>
<a name="line-20"></a><span class='hs-definition'>mkBigLHsTup</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkChunkified</span> <span class='hs-varid'>mkLHsTupleExpr</span>
<a name="line-21"></a>
<a name="line-22"></a><a name="mkBigLHsVarPatTup"></a><span class='hs-comment'>-- The Big equivalents for the source tuple patterns</span>
<a name="line-23"></a><span class='hs-definition'>mkBigLHsVarPatTup</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'>LPat</span> <span class='hs-conid'>Id</span>
<a name="line-24"></a><span class='hs-definition'>mkBigLHsVarPatTup</span> <span class='hs-varid'>bs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBigLHsPatTup</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>bs</span><span class='hs-layout'>)</span>
<a name="line-25"></a>
<a name="line-26"></a><a name="mkBigLHsPatTup"></a><span class='hs-definition'>mkBigLHsPatTup</span> <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-keyglyph'>-></span> <span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span>
<a name="line-27"></a><span class='hs-definition'>mkBigLHsPatTup</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkChunkified</span> <span class='hs-varid'>mkLHsPatTup</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%* *
%************************************************************************
Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
let fail.33 = error "Help"
in
case x of
p1 -> ...
p2 -> fail.33
p3 -> fail.33
p4 -> ...
\end{verbatim}
Then
\begin{itemize}
\item
If the case can't fail, then there'll be no mention of @fail.33@, and the
simplifier will later discard it.
\item
If it can fail in only one way, then the simplifier will inline it.
\item
Only if it is used more than once will the let-binding remain.
\end{itemize}
There's a problem when the result of the case expression is of
unboxed type. Then the type of @fail.33@ is unboxed too, and
there is every chance that someone will change the let into a case:
\begin{verbatim}
case error "Help" of
fail.33 -> case ....
\end{verbatim}
which is of course utterly wrong. Rather than drop the condition that
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
let fail.33 :: Void -> Int#
fail.33 = \_ -> error "Help"
in
case x of
p1 -> ...
p2 -> fail.33 void
p3 -> fail.33 void
p4 -> ...
\end{verbatim}
Now @fail.33@ is a function, so it can be let-bound.
\begin{code}
<pre><a name="line-1"></a><a name="mkFailurePair"></a><span class='hs-definition'>mkFailurePair</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- Result type of the whole case expression</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'>CoreBind</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Binds the newly-created fail variable</span>
<a name="line-3"></a> <span class='hs-comment'>-- to \ _ -> expression</span>
<a name="line-4"></a> <span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Fail variable applied to realWorld#</span>
<a name="line-5"></a><span class='hs-comment'>-- See Note [Failure thunks and CPR]</span>
<a name="line-6"></a><span class='hs-definition'>mkFailurePair</span> <span class='hs-varid'>expr</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>fail_fun_var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newFailLocalDs</span> <span class='hs-layout'>(</span><span class='hs-varid'>realWorldStatePrimTy</span> <span class='hs-varop'>`mkFunTy`</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>fail_fun_arg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newSysLocalDs</span> <span class='hs-varid'>realWorldStatePrimTy</span>
<a name="line-9"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>fail_fun_var</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>fail_fun_arg</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-10"></a> <span class='hs-conid'>App</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>fail_fun_var</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>realWorldPrimId</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-11"></a> <span class='hs-keyword'>where</span>
<a name="line-12"></a> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>expr</span>
</pre>\end{code}
Note [Failure thunks and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we make a failure point we ensure that it
does not look like a thunk. Example:
let fail = \rw -> error "urk"
in case x of
[] -> fail realWorld#
(y:ys) -> case ys of
[] -> fail realWorld#
(z:zs) -> (y,z)
Reason: we know that a failure point is always a "join point" and is
entered at most once. Adding a dummy 'realWorld' token argument makes
it clear that sharing is not an issue. And that in turn makes it more
CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see Trac #3403.
\begin{code}
<pre><a name="line-1"></a><a name="mkOptTickBox"></a><span class='hs-definition'>mkOptTickBox</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-conid'>Int</span><span class='hs-layout'>,</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-2"></a><span class='hs-definition'>mkOptTickBox</span> <span class='hs-conid'>Nothing</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varid'>e</span>
<a name="line-3"></a><span class='hs-definition'>mkOptTickBox</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>ix</span><span class='hs-layout'>,</span><span class='hs-varid'>ids</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTickBox</span> <span class='hs-varid'>ix</span> <span class='hs-varid'>ids</span> <span class='hs-varid'>e</span>
<a name="line-4"></a>
<a name="line-5"></a><a name="mkTickBox"></a><span class='hs-definition'>mkTickBox</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</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'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-6"></a><span class='hs-definition'>mkTickBox</span> <span class='hs-varid'>ix</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-7"></a> <span class='hs-varid'>uq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUnique</span>
<a name="line-8"></a> <span class='hs-varid'>mod</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getModuleDs</span>
<a name="line-9"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>tick</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>opt_Hpc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTickBoxOpId</span> <span class='hs-varid'>uq</span> <span class='hs-varid'>mod</span> <span class='hs-varid'>ix</span>
<a name="line-10"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkBreakPointOpId</span> <span class='hs-varid'>uq</span> <span class='hs-varid'>mod</span> <span class='hs-varid'>ix</span>
<a name="line-11"></a> <span class='hs-varid'>uq2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUnique</span>
<a name="line-12"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>occName</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarOcc</span> <span class='hs-str'>"tick"</span>
<a name="line-13"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkInternalName</span> <span class='hs-varid'>uq2</span> <span class='hs-varid'>occName</span> <span class='hs-varid'>noSrcSpan</span> <span class='hs-comment'>-- use mkSysLocal?</span>
<a name="line-14"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>var</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Id</span><span class='hs-varop'>.</span><span class='hs-varid'>mkLocalId</span> <span class='hs-varid'>name</span> <span class='hs-varid'>realWorldStatePrimTy</span>
<a name="line-15"></a> <span class='hs-varid'>scrut</span> <span class='hs-keyglyph'><-</span>
<a name="line-16"></a> <span class='hs-keyword'>if</span> <span class='hs-varid'>opt_Hpc</span>
<a name="line-17"></a> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>tick</span><span class='hs-layout'>)</span>
<a name="line-18"></a> <span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span>
<a name="line-19"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>tickVar</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>tick</span>
<a name="line-20"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>tickType</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkFunTys</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>idType</span> <span class='hs-varid'>vars</span><span class='hs-layout'>)</span> <span class='hs-varid'>realWorldStatePrimTy</span>
<a name="line-21"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>scrutApTy</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>App</span> <span class='hs-varid'>tickVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-varid'>tickType</span><span class='hs-layout'>)</span>
<a name="line-22"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkApps</span> <span class='hs-varid'>scrutApTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>vars</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Expr</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Case</span> <span class='hs-varid'>scrut</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span><span class='hs-varid'>e</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-24"></a> <span class='hs-keyword'>where</span>
<a name="line-25"></a> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>e</span>
<a name="line-26"></a>
<a name="line-27"></a><a name="mkBinaryTickBox"></a><span class='hs-definition'>mkBinaryTickBox</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>CoreExpr</span>
<a name="line-28"></a><span class='hs-definition'>mkBinaryTickBox</span> <span class='hs-varid'>ixT</span> <span class='hs-varid'>ixF</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-29"></a> <span class='hs-varid'>uq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newUnique</span>
<a name="line-30"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>bndr1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSysLocal</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"t1"</span><span class='hs-layout'>)</span> <span class='hs-varid'>uq</span> <span class='hs-varid'>boolTy</span>
<a name="line-31"></a> <span class='hs-varid'>falseBox</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkTickBox</span> <span class='hs-varid'>ixF</span> <span class='hs-conid'>[]</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>falseDataConId</span>
<a name="line-32"></a> <span class='hs-varid'>trueBox</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkTickBox</span> <span class='hs-varid'>ixT</span> <span class='hs-conid'>[]</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>trueDataConId</span>
<a name="line-33"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Case</span> <span class='hs-varid'>e</span> <span class='hs-varid'>bndr1</span> <span class='hs-varid'>boolTy</span>
<a name="line-34"></a> <span class='hs-keyglyph'>[</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>falseDataCon</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>falseBox</span><span class='hs-layout'>)</span>
<a name="line-35"></a> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>trueDataCon</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>trueBox</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-keyglyph'>]</span>
</pre>\end{code}
</body>
</html>
