<?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/MatchCon.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
%
Pattern-matching constructors
\begin{code}
<pre><a name="line-1"></a><span class='hs-comment'>{-# OPTIONS -fno-warn-incomplete-patterns #-}</span>
<a name="line-2"></a><span class='hs-comment'>-- The above warning supression flag is a temporary kludge.</span>
<a name="line-3"></a><span class='hs-comment'>-- While working on this module you are encouraged to remove it and fix</span>
<a name="line-4"></a><span class='hs-comment'>-- any warnings in the module. See</span>
<a name="line-5"></a><span class='hs-comment'>-- <a href="http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings">http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings</a></span>
<a name="line-6"></a><span class='hs-comment'>-- for details</span>
<a name="line-7"></a>
<a name="line-8"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>MatchCon</span> <span class='hs-layout'>(</span> <span class='hs-varid'>matchConFamily</span> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-9"></a>
<a name="line-10"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-11"></a>
<a name="line-12"></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'>match</span> <span class='hs-layout'>)</span>
<a name="line-13"></a>
<a name="line-14"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>HsSyn</span>
<a name="line-15"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsBinds</span>
<a name="line-16"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DataCon</span>
<a name="line-17"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcType</span>
<a name="line-18"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSyn</span>
<a name="line-19"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MkCore</span>
<a name="line-20"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsMonad</span>
<a name="line-21"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DsUtils</span>
<a name="line-22"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Util</span> <span class='hs-layout'>(</span> <span class='hs-varid'>all2</span><span class='hs-layout'>,</span> <span class='hs-varid'>takeList</span><span class='hs-layout'>,</span> <span class='hs-varid'>zipEqual</span> <span class='hs-layout'>)</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>ListSetOps</span> <span class='hs-layout'>(</span> <span class='hs-varid'>runs</span> <span class='hs-layout'>)</span>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Id</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>(</span> <span class='hs-conid'>Var</span> <span class='hs-layout'>)</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>NameEnv</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>SrcLoc</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
</pre>\end{code}
We are confronted with the first column of patterns in a set of
equations, all beginning with constructors from one ``family'' (e.g.,
@[]@ and @:@ make up the @List@ ``family''). We want to generate the
alternatives for a @Case@ expression. There are several choices:
\begin{enumerate}
\item
Generate an alternative for every constructor in the family, whether
they are used in this set of equations or not; this is what the Wadler
chapter does.
\begin{description}
\item[Advantages:]
(a)~Simple. (b)~It may also be that large sparsely-used constructor
families are mainly handled by the code for literals.
\item[Disadvantages:]
(a)~Not practical for large sparsely-used constructor families, e.g.,
the ASCII character set. (b)~Have to look up a list of what
constructors make up the whole family.
\end{description}
\item
Generate an alternative for each constructor used, then add a default
alternative in case some constructors in the family weren't used.
\begin{description}
\item[Advantages:]
(a)~Alternatives aren't generated for unused constructors. (b)~The
STG is quite happy with defaults. (c)~No lookup in an environment needed.
\item[Disadvantages:]
(a)~A spurious default alternative may be generated.
\end{description}
\item
``Do it right:'' generate an alternative for each constructor used,
and add a default alternative if all constructors in the family
weren't used.
\begin{description}
\item[Advantages:]
(a)~You will get cases with only one alternative (and no default),
which should be amenable to optimisation. Tuples are a common example.
\item[Disadvantages:]
(b)~Have to look up constructor families in TDE (as above).
\end{description}
\end{enumerate}
We are implementing the ``do-it-right'' option for now. The arguments
to @matchConFamily@ are the same as to @match@; the extra @Int@
returned is the number of constructors in the family.
The function @matchConFamily@ is concerned with this
have-we-used-all-the-constructors? question; the local function
@match_cons_used@ does all the real work.
\begin{code}
<pre><a name="line-1"></a><a name="matchConFamily"></a><span class='hs-definition'>matchConFamily</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-3"></a> <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><span class='hs-keyglyph'>]</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>MatchResult</span>
<a name="line-5"></a><span class='hs-comment'>-- Each group of eqns is for a single constructor</span>
<a name="line-6"></a><span class='hs-definition'>matchConFamily</span> <span class='hs-layout'>(</span><span class='hs-varid'>var</span><span class='hs-conop'>:</span><span class='hs-varid'>vars</span><span class='hs-layout'>)</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>groups</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'>alts</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>matchOneCon</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span> <span class='hs-varid'>groups</span>
<a name="line-8"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoAlgCaseMatchResult</span> <span class='hs-varid'>var</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="ConArgPats"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>ConArgPats</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>HsConDetails</span> <span class='hs-layout'>(</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsRecFields</span> <span class='hs-conid'>Id</span> <span class='hs-layout'>(</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-11"></a>
<a name="line-12"></a><a name="matchOneCon"></a><span class='hs-definition'>matchOneCon</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span>
<a name="line-13"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-14"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>EquationInfo</span><span class='hs-keyglyph'>]</span>
<a name="line-15"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</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'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>MatchResult</span><span class='hs-layout'>)</span>
<a name="line-16"></a><span class='hs-definition'>matchOneCon</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>eqn1</span> <span class='hs-conop'>:</span> <span class='hs-varid'>eqns</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- All eqns for a single constructor</span>
<a name="line-17"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>arg_vars</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>selectConMatchVars</span> <span class='hs-varid'>arg_tys</span> <span class='hs-varid'>args1</span>
<a name="line-18"></a> <span class='hs-comment'>-- Use the first equation as a source of </span>
<a name="line-19"></a> <span class='hs-comment'>-- suggestions for the new variables</span>
<a name="line-20"></a>
<a name="line-21"></a> <span class='hs-comment'>-- Divide into sub-groups; see Note [Record patterns]</span>
<a name="line-22"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>groups</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>ConArgPats</span><span class='hs-layout'>,</span> <span class='hs-conid'>EquationInfo</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span>
<a name="line-23"></a> <span class='hs-varid'>groups</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runs</span> <span class='hs-varid'>compatible_pats</span> <span class='hs-keyglyph'>[</span> <span class='hs-layout'>(</span><span class='hs-varid'>pat_args</span> <span class='hs-layout'>(</span><span class='hs-varid'>firstPat</span> <span class='hs-varid'>eqn</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqn</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>eqn</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>eqn1</span><span class='hs-conop'>:</span><span class='hs-varid'>eqns</span> <span class='hs-keyglyph'>]</span>
<a name="line-25"></a>
<a name="line-26"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>match_results</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>match_group</span> <span class='hs-varid'>arg_vars</span><span class='hs-layout'>)</span> <span class='hs-varid'>groups</span>
<a name="line-27"></a>
<a name="line-28"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>con1</span><span class='hs-layout'>,</span> <span class='hs-varid'>tvs1</span> <span class='hs-varop'>++</span> <span class='hs-varid'>dicts1</span> <span class='hs-varop'>++</span> <span class='hs-varid'>arg_vars</span><span class='hs-layout'>,</span>
<a name="line-29"></a> <span class='hs-varid'>foldr1</span> <span class='hs-varid'>combineMatchResults</span> <span class='hs-varid'>match_results</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-30"></a> <span class='hs-keyword'>where</span>
<a name="line-31"></a> <span class='hs-conid'>ConPatOut</span> <span class='hs-layout'>{</span> <span class='hs-varid'>pat_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>con1</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pat_ty1</span><span class='hs-layout'>,</span>
<a name="line-32"></a> <span class='hs-varid'>pat_tvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tvs1</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_dicts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dicts1</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>args1</span> <span class='hs-layout'>}</span>
<a name="line-33"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>firstPat</span> <span class='hs-varid'>eqn1</span>
<a name="line-34"></a> <span class='hs-varid'>fields1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConFieldLabels</span> <span class='hs-varid'>con1</span>
<a name="line-35"></a>
<a name="line-36"></a> <span class='hs-varid'>arg_tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConInstOrigArgTys</span> <span class='hs-varid'>con1</span> <span class='hs-varid'>inst_tys</span>
<a name="line-37"></a> <span class='hs-varid'>inst_tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tcTyConAppArgs</span> <span class='hs-varid'>pat_ty1</span> <span class='hs-varop'>++</span>
<a name="line-38"></a> <span class='hs-varid'>mkTyVarTys</span> <span class='hs-layout'>(</span><span class='hs-varid'>takeList</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConExTyVars</span> <span class='hs-varid'>con1</span><span class='hs-layout'>)</span> <span class='hs-varid'>tvs1</span><span class='hs-layout'>)</span>
<a name="line-39"></a> <span class='hs-comment'>-- Newtypes opaque, hence tcTyConAppArgs</span>
<a name="line-40"></a> <span class='hs-comment'>-- dataConInstOrigArgTys takes the univ and existential tyvars</span>
<a name="line-41"></a> <span class='hs-comment'>-- and returns the types of the *value* args, which is what we want</span>
<a name="line-42"></a>
<a name="line-43"></a> <span class='hs-varid'>match_group</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>ConArgPats</span><span class='hs-layout'>,</span> <span class='hs-conid'>EquationInfo</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DsM</span> <span class='hs-conid'>MatchResult</span>
<a name="line-44"></a> <span class='hs-comment'>-- All members of the group have compatible ConArgPats</span>
<a name="line-45"></a> <span class='hs-varid'>match_group</span> <span class='hs-varid'>arg_vars</span> <span class='hs-varid'>arg_eqn_prs</span>
<a name="line-46"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-varid'>wraps</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqns'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-varid'>shift</span> <span class='hs-varid'>arg_eqn_prs</span>
<a name="line-47"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>group_arg_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>select_arg_vars</span> <span class='hs-varid'>arg_vars</span> <span class='hs-varid'>arg_eqn_prs</span>
<a name="line-48"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>match_result</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>match</span> <span class='hs-layout'>(</span><span class='hs-varid'>group_arg_vars</span> <span class='hs-varop'>++</span> <span class='hs-varid'>vars</span><span class='hs-layout'>)</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>eqns'</span>
<a name="line-49"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>adjustMatchResult</span> <span class='hs-layout'>(</span><span class='hs-varid'>foldr1</span> <span class='hs-layout'>(</span><span class='hs-varop'>.</span><span class='hs-layout'>)</span> <span class='hs-varid'>wraps</span><span class='hs-layout'>)</span> <span class='hs-varid'>match_result</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-50"></a>
<a name="line-51"></a> <span class='hs-varid'>shift</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqn</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>EqnInfo</span> <span class='hs-layout'>{</span> <span class='hs-varid'>eqn_pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ConPatOut</span><span class='hs-layout'>{</span> <span class='hs-varid'>pat_tvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tvs</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_dicts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ds</span><span class='hs-layout'>,</span>
<a name="line-52"></a> <span class='hs-varid'>pat_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>pat_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>args</span>
<a name="line-53"></a> <span class='hs-layout'>}</span> <span class='hs-conop'>:</span> <span class='hs-varid'>pats</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>prs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dsLHsBinds</span> <span class='hs-varid'>bind</span>
<a name="line-55"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>wrapBinds</span> <span class='hs-layout'>(</span><span class='hs-varid'>tvs</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>tvs1</span><span class='hs-layout'>)</span>
<a name="line-56"></a> <span class='hs-varop'>.</span> <span class='hs-varid'>wrapBinds</span> <span class='hs-layout'>(</span><span class='hs-varid'>ds</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>dicts1</span><span class='hs-layout'>)</span>
<a name="line-57"></a> <span class='hs-varop'>.</span> <span class='hs-varid'>mkCoreLet</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-58"></a> <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'>conArgPats</span> <span class='hs-varid'>arg_tys</span> <span class='hs-varid'>args</span> <span class='hs-varop'>++</span> <span class='hs-varid'>pats</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-59"></a>
<a name="line-60"></a> <span class='hs-comment'>-- Choose the right arg_vars in the right order for this group</span>
<a name="line-61"></a> <span class='hs-comment'>-- Note [Record patterns]</span>
<a name="line-62"></a> <span class='hs-varid'>select_arg_vars</span> <span class='hs-varid'>arg_vars</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>arg_pats</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>RecCon</span> <span class='hs-varid'>flds</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>arg_pats</span>
<a name="line-64"></a> <span class='hs-layout'>,</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>rpats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>rec_flds</span> <span class='hs-varid'>flds</span>
<a name="line-65"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>null</span> <span class='hs-varid'>rpats</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Treated specially; cf conArgPats</span>
<a name="line-66"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT2</span><span class='hs-layout'>(</span> <span class='hs-varid'>length</span> <span class='hs-varid'>fields1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>length</span> <span class='hs-varid'>arg_vars</span><span class='hs-layout'>,</span>
<a name="line-67"></a> <span class='hs-varid'>ppr</span> <span class='hs-varid'>con1</span> <span class='hs-varop'>$$</span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>fields1</span> <span class='hs-varop'>$$</span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>arg_vars</span> <span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-varid'>map</span> <span class='hs-varid'>lookup_fld</span> <span class='hs-varid'>rpats</span>
<a name="line-69"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-70"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>arg_vars</span>
<a name="line-71"></a> <span class='hs-keyword'>where</span>
<a name="line-72"></a> <span class='hs-varid'>fld_var_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkNameEnv</span> <span class='hs-varop'>$</span> <span class='hs-varid'>zipEqual</span> <span class='hs-str'>"get_arg_vars"</span> <span class='hs-varid'>fields1</span> <span class='hs-varid'>arg_vars</span>
<a name="line-73"></a> <span class='hs-varid'>lookup_fld</span> <span class='hs-varid'>rpat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupNameEnv_NF</span> <span class='hs-varid'>fld_var_env</span>
<a name="line-74"></a> <span class='hs-layout'>(</span><span class='hs-varid'>idName</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsRecFieldId</span> <span class='hs-varid'>rpat</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-75"></a>
<a name="line-76"></a><a name="compatible_pats"></a><span class='hs-comment'>-----------------</span>
<a name="line-77"></a><span class='hs-definition'>compatible_pats</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConArgPats</span><span class='hs-layout'>,</span><span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ConArgPats</span><span class='hs-layout'>,</span><span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-78"></a><span class='hs-comment'>-- Two constructors have compatible argument patterns if the number</span>
<a name="line-79"></a><span class='hs-comment'>-- and order of sub-matches is the same in both cases</span>
<a name="line-80"></a><span class='hs-definition'>compatible_pats</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-varid'>flds1</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-varid'>flds2</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'>same_fields</span> <span class='hs-varid'>flds1</span> <span class='hs-varid'>flds2</span>
<a name="line-81"></a><span class='hs-definition'>compatible_pats</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-varid'>flds1</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>null</span> <span class='hs-layout'>(</span><span class='hs-varid'>rec_flds</span> <span class='hs-varid'>flds1</span><span class='hs-layout'>)</span>
<a name="line-82"></a><span class='hs-definition'>compatible_pats</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-varid'>flds2</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'>null</span> <span class='hs-layout'>(</span><span class='hs-varid'>rec_flds</span> <span class='hs-varid'>flds2</span><span class='hs-layout'>)</span>
<a name="line-83"></a><span class='hs-definition'>compatible_pats</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span> <span class='hs-comment'>-- Prefix or infix con</span>
<a name="line-84"></a>
<a name="line-85"></a><a name="same_fields"></a><span class='hs-definition'>same_fields</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HsRecFields</span> <span class='hs-conid'>Id</span> <span class='hs-layout'>(</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>HsRecFields</span> <span class='hs-conid'>Id</span> <span class='hs-layout'>(</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-86"></a><span class='hs-definition'>same_fields</span> <span class='hs-varid'>flds1</span> <span class='hs-varid'>flds2</span>
<a name="line-87"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>all2</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>f1</span> <span class='hs-varid'>f2</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsRecFieldId</span> <span class='hs-varid'>f1</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-varid'>unLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>hsRecFieldId</span> <span class='hs-varid'>f2</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-88"></a> <span class='hs-layout'>(</span><span class='hs-varid'>rec_flds</span> <span class='hs-varid'>flds1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>rec_flds</span> <span class='hs-varid'>flds2</span><span class='hs-layout'>)</span>
<a name="line-89"></a>
<a name="line-90"></a>
<a name="line-91"></a><a name="selectConMatchVars"></a><span class='hs-comment'>-----------------</span>
<a name="line-92"></a><span class='hs-definition'>selectConMatchVars</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ConArgPats</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-93"></a><span class='hs-definition'>selectConMatchVars</span> <span class='hs-varid'>arg_tys</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newSysLocalsDs</span> <span class='hs-varid'>arg_tys</span>
<a name="line-94"></a><span class='hs-definition'>selectConMatchVars</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>PrefixCon</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>selectMatchVars</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<a name="line-95"></a><span class='hs-definition'>selectConMatchVars</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>InfixCon</span> <span class='hs-varid'>p1</span> <span class='hs-varid'>p2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>selectMatchVars</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>p1</span><span class='hs-layout'>,</span> <span class='hs-varid'>unLoc</span> <span class='hs-varid'>p2</span><span class='hs-keyglyph'>]</span>
<a name="line-96"></a>
<a name="line-97"></a><a name="conArgPats"></a><span class='hs-definition'>conArgPats</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Type</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Instantiated argument types </span>
<a name="line-98"></a> <span class='hs-comment'>-- Used only to fill in the types of WildPats, which</span>
<a name="line-99"></a> <span class='hs-comment'>-- are probably never looked at anyway</span>
<a name="line-100"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ConArgPats</span>
<a name="line-101"></a> <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>
<a name="line-102"></a><span class='hs-definition'>conArgPats</span> <span class='hs-sel'>_arg_tys</span> <span class='hs-layout'>(</span><span class='hs-conid'>PrefixCon</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>unLoc</span> <span class='hs-varid'>ps</span>
<a name="line-103"></a><span class='hs-definition'>conArgPats</span> <span class='hs-sel'>_arg_tys</span> <span class='hs-layout'>(</span><span class='hs-conid'>InfixCon</span> <span class='hs-varid'>p1</span> <span class='hs-varid'>p2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>unLoc</span> <span class='hs-varid'>p1</span><span class='hs-layout'>,</span> <span class='hs-varid'>unLoc</span> <span class='hs-varid'>p2</span><span class='hs-keyglyph'>]</span>
<a name="line-104"></a><span class='hs-definition'>conArgPats</span> <span class='hs-varid'>arg_tys</span> <span class='hs-layout'>(</span><span class='hs-conid'>RecCon</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsRecFields</span> <span class='hs-layout'>{</span> <span class='hs-varid'>rec_flds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>rpats</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-105"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>rpats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-conid'>WildPat</span> <span class='hs-varid'>arg_tys</span>
<a name="line-106"></a> <span class='hs-comment'>-- Important special case for C {}, which can be used for a </span>
<a name="line-107"></a> <span class='hs-comment'>-- datacon that isn't declared to have fields at all</span>
<a name="line-108"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>unLoc</span> <span class='hs-varop'>.</span> <span class='hs-varid'>hsRecFieldArg</span><span class='hs-layout'>)</span> <span class='hs-varid'>rpats</span>
</pre>\end{code}
Note [Record patterns]
~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = T { x,y,z :: Bool }
f (T { y=True, x=False }) = ...
We must match the patterns IN THE ORDER GIVEN, thus for the first
one we match y=True before x=False. See Trac #246; or imagine
matching against (T { y=False, x=undefined }): should fail without
touching the undefined.
Now consider:
f (T { y=True, x=False }) = ...
f (T { x=True, y= False}) = ...
In the first we must test y first; in the second we must test x
first. So we must divide even the equations for a single constructor
T into sub-goups, based on whether they match the same field in the
same order. That's what the (runs compatible_pats) grouping.
All non-record patterns are "compatible" in this sense, because the
positional patterns (T a b) and (a `T` b) all match the arguments
in order. Also T {} is special because it's equivalent to (T _ _).
Hence the (null rpats) checks here and there.
Note [Existentials in shift_con_pat]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = forall a. Ord a => T a (a->Int)
f (T x f) True = ...expr1...
f (T y g) False = ...expr2..
When we put in the tyvars etc we get
f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
After desugaring etc we'll get a single case:
f = \t::T b::Bool ->
case t of
T a (d::Ord a) (x::a) (f::a->Int)) ->
case b of
True -> ...expr1...
False -> ...expr2...
*** We have to substitute [a/b, d/e] in expr2! **
Hence
False -> ....((/\b\(e:Ord b).expr2) a d)....
Originally I tried to use
(\b -> let e = d in expr2) a
to do this substitution. While this is "correct" in a way, it fails
Lint, because e::Ord b but d::Ord a.
</body>
</html>
