<?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>typecheck/TcGenDeriv.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
%
TcGenDeriv: Generating derived instance declarations
This module is nominally ``subordinate'' to @TcDeriv@, which is the
``official'' interface to deriving-related things.
This is where we do all the grimy bindings' generation.
\begin{code}
<pre><a name="line-1"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>TcGenDeriv</span> <span class='hs-layout'>(</span>
<a name="line-2"></a> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>,</span> <span class='hs-varid'>isDupAux</span><span class='hs-layout'>,</span>
<a name="line-3"></a>
<a name="line-4"></a> <span class='hs-varid'>gen_Bounded_binds</span><span class='hs-layout'>,</span>
<a name="line-5"></a> <span class='hs-varid'>gen_Enum_binds</span><span class='hs-layout'>,</span>
<a name="line-6"></a> <span class='hs-varid'>gen_Eq_binds</span><span class='hs-layout'>,</span>
<a name="line-7"></a> <span class='hs-varid'>gen_Ix_binds</span><span class='hs-layout'>,</span>
<a name="line-8"></a> <span class='hs-varid'>gen_Ord_binds</span><span class='hs-layout'>,</span>
<a name="line-9"></a> <span class='hs-varid'>gen_Read_binds</span><span class='hs-layout'>,</span>
<a name="line-10"></a> <span class='hs-varid'>gen_Show_binds</span><span class='hs-layout'>,</span>
<a name="line-11"></a> <span class='hs-varid'>gen_Data_binds</span><span class='hs-layout'>,</span>
<a name="line-12"></a> <span class='hs-varid'>gen_Typeable_binds</span><span class='hs-layout'>,</span>
<a name="line-13"></a> <span class='hs-varid'>gen_Functor_binds</span><span class='hs-layout'>,</span>
<a name="line-14"></a> <span class='hs-conid'>FFoldType</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>functorLikeTraverse</span><span class='hs-layout'>,</span>
<a name="line-15"></a> <span class='hs-varid'>deepSubtypesContaining</span><span class='hs-layout'>,</span> <span class='hs-varid'>foldDataConArgs</span><span class='hs-layout'>,</span>
<a name="line-16"></a> <span class='hs-varid'>gen_Foldable_binds</span><span class='hs-layout'>,</span>
<a name="line-17"></a> <span class='hs-varid'>gen_Traversable_binds</span><span class='hs-layout'>,</span>
<a name="line-18"></a> <span class='hs-varid'>genAuxBind</span>
<a name="line-19"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-20"></a>
<a name="line-21"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-22"></a>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>HsSyn</span>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>RdrName</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>BasicTypes</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DataCon</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Name</span>
<a name="line-28"></a>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>HscTypes</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrelInfo</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrelNames</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>PrimOp</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>SrcLoc</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TyCon</span>
<a name="line-35"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TcType</span>
<a name="line-36"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TysPrim</span>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TysWiredIn</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Type</span>
<a name="line-39"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span><span class='hs-layout'>(</span> <span class='hs-conid'>TyVar</span> <span class='hs-layout'>)</span>
<a name="line-40"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>TypeRep</span>
<a name="line-41"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>VarSet</span>
<a name="line-42"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>State</span>
<a name="line-43"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Util</span>
<a name="line-44"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MonadUtils</span>
<a name="line-45"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
<a name="line-46"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>FastString</span>
<a name="line-47"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Bag</span>
<a name="line-48"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>List</span> <span class='hs-layout'>(</span> <span class='hs-varid'>partition</span><span class='hs-layout'>,</span> <span class='hs-varid'>intersperse</span> <span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="DerivAuxBinds"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>DerivAuxBinds</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>DerivAuxBind</span><span class='hs-keyglyph'>]</span>
<a name="line-2"></a>
<a name="line-3"></a><a name="DerivAuxBind"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>DerivAuxBind</span> <span class='hs-comment'>-- Please add these auxiliary top-level bindings</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>GenCon2Tag</span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- The con2Tag for given TyCon</span>
<a name="line-5"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>GenTag2Con</span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- ...ditto tag2Con</span>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>GenMaxTag</span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- ...and maxTag</span>
<a name="line-7"></a>
<a name="line-8"></a> <span class='hs-comment'>-- Scrap your boilerplate</span>
<a name="line-9"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>MkDataCon</span> <span class='hs-conid'>DataCon</span> <span class='hs-comment'>-- For constructor C we get $cC :: Constr</span>
<a name="line-10"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>MkTyCon</span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- For tycon T we get $tT :: DataType</span>
<a name="line-11"></a>
<a name="line-12"></a>
<a name="line-13"></a><a name="isDupAux"></a><span class='hs-definition'>isDupAux</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DerivAuxBind</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DerivAuxBind</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-14"></a><span class='hs-definition'>isDupAux</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tc1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tc2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tc1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>tc2</span>
<a name="line-15"></a><span class='hs-definition'>isDupAux</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenTag2Con</span> <span class='hs-varid'>tc1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenTag2Con</span> <span class='hs-varid'>tc2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tc1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>tc2</span>
<a name="line-16"></a><span class='hs-definition'>isDupAux</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenMaxTag</span> <span class='hs-varid'>tc1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenMaxTag</span> <span class='hs-varid'>tc2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tc1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>tc2</span>
<a name="line-17"></a><span class='hs-definition'>isDupAux</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkDataCon</span> <span class='hs-varid'>dc1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkDataCon</span> <span class='hs-varid'>dc2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dc1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>dc2</span>
<a name="line-18"></a><span class='hs-definition'>isDupAux</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkTyCon</span> <span class='hs-varid'>tc1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkTyCon</span> <span class='hs-varid'>tc2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tc1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>tc2</span>
<a name="line-19"></a><span class='hs-definition'>isDupAux</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>\end{code}
%************************************************************************
%* *
Eq instances
%* *
%************************************************************************
Here are the heuristics for the code we generate for @Eq@:
\begin{itemize}
\item
Let's assume we have a data type with some (possibly zero) nullary
data constructors and some ordinary, non-nullary ones (the rest,
also possibly zero of them). Here's an example, with both \tr{N}ullary
and \tr{O}rdinary data cons.
\begin{verbatim}
data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
\end{verbatim}
\item
For the ordinary constructors (if any), we emit clauses to do The
Usual Thing, e.g.,:
\begin{verbatim}
(==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
(==) (O2 a1) (O2 a2) = a1 == a2
(==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
\end{verbatim}
Note: if we're comparing unlifted things, e.g., if \tr{a1} and
\tr{a2} are \tr{Float#}s, then we have to generate
\begin{verbatim}
case (a1 `eqFloat#` a2) of
r -> r
\end{verbatim}
for that particular test.
\item
If there are any nullary constructors, we emit a catch-all clause of
the form:
\begin{verbatim}
(==) a b = case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
case (a# ==# b#) of {
r -> r
}}}
\end{verbatim}
If there aren't any nullary constructors, we emit a simpler
catch-all:
\begin{verbatim}
(==) a b = False
\end{verbatim}
\item
For the @(/=)@ method, we normally just use the default method.
If the type is an enumeration type, we could/may/should? generate
special code that calls @con2tag_Foo@, much like for @(==)@ shown
above.
\item
We thought about doing this: If we're also deriving @Ord@ for this
tycon, we generate:
\begin{verbatim}
instance ... Eq (Foo ...) where
(==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
(/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
\begin{verbatim}
However, that requires that \tr{Ord <whatever>} was put in the context
for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
\end{itemize}
\begin{code}
<pre><a name="line-1"></a><a name="gen_Eq_binds"></a><span class='hs-definition'>gen_Eq_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Eq_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>method_binds</span><span class='hs-layout'>,</span> <span class='hs-varid'>aux_binds</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-keyword'>where</span>
<a name="line-5"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nullary_cons</span><span class='hs-layout'>,</span> <span class='hs-varid'>nonnullary_cons</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isNewTyCon</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-7"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>partition</span> <span class='hs-varid'>isNullarySrcDataCon</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-8"></a>
<a name="line-9"></a> <span class='hs-varid'>no_nullary_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>null</span> <span class='hs-varid'>nullary_cons</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-varid'>rest</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>no_nullary_cons</span>
<a name="line-12"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>tyConSingleDataCon_maybe</span> <span class='hs-varid'>tycon</span> <span class='hs-keyword'>of</span>
<a name="line-13"></a> <span class='hs-conid'>Just</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>[]</span>
<a name="line-14"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-comment'>-- if cons don't match, then False</span>
<a name="line-15"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>false_Expr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-16"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- calc. and compare the tags</span>
<a name="line-17"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-18"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span><span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span><span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-19"></a> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>eqInt_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-20"></a>
<a name="line-21"></a> <span class='hs-varid'>aux_binds</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>no_nullary_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-22"></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-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span>
<a name="line-23"></a>
<a name="line-24"></a> <span class='hs-varid'>method_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span>
<a name="line-25"></a> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>eq_RDR</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>pats_etc</span> <span class='hs-varid'>nonnullary_cons</span><span class='hs-layout'>)</span> <span class='hs-varop'>++</span> <span class='hs-varid'>rest</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-26"></a> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>ne_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-27"></a> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>not_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>eq_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-28"></a>
<a name="line-29"></a> <span class='hs-comment'>------------------------------------------------------------------</span>
<a name="line-30"></a> <span class='hs-varid'>pats_etc</span> <span class='hs-varid'>data_con</span>
<a name="line-31"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>let</span>
<a name="line-32"></a> <span class='hs-varid'>con1_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>as_needed</span>
<a name="line-33"></a> <span class='hs-varid'>con2_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>bs_needed</span>
<a name="line-34"></a>
<a name="line-35"></a> <span class='hs-varid'>data_con_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con</span>
<a name="line-36"></a> <span class='hs-varid'>con_arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>tys_needed</span>
<a name="line-37"></a> <span class='hs-varid'>as_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-38"></a> <span class='hs-varid'>bs_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-39"></a> <span class='hs-varid'>tys_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>data_con</span>
<a name="line-40"></a> <span class='hs-keyword'>in</span>
<a name="line-41"></a> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>con1_pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>con2_pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>nested_eq_expr</span> <span class='hs-varid'>tys_needed</span> <span class='hs-varid'>as_needed</span> <span class='hs-varid'>bs_needed</span><span class='hs-layout'>)</span>
<a name="line-42"></a> <span class='hs-keyword'>where</span>
<a name="line-43"></a> <span class='hs-varid'>nested_eq_expr</span> <span class='hs-conid'>[]</span> <span class='hs-conid'>[]</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>true_Expr</span>
<a name="line-44"></a> <span class='hs-varid'>nested_eq_expr</span> <span class='hs-varid'>tys</span> <span class='hs-keyword'>as</span> <span class='hs-varid'>bs</span>
<a name="line-45"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl1</span> <span class='hs-varid'>and_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>zipWith3Equal</span> <span class='hs-str'>"nested_eq"</span> <span class='hs-varid'>nested_eq</span> <span class='hs-varid'>tys</span> <span class='hs-keyword'>as</span> <span class='hs-varid'>bs</span><span class='hs-layout'>)</span>
<a name="line-46"></a> <span class='hs-keyword'>where</span>
<a name="line-47"></a> <span class='hs-varid'>nested_eq</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>eq_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>ty</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
Ord instances
%* *
%************************************************************************
For a derived @Ord@, we concentrate our attentions on @compare@
\begin{verbatim}
compare :: a -> a -> Ordering
data Ordering = LT | EQ | GT deriving ()
\end{verbatim}
We will use the same example data type as above:
\begin{verbatim}
data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
\end{verbatim}
\begin{itemize}
\item
We do all the other @Ord@ methods with calls to @compare@:
\begin{verbatim}
instance ... (Ord <wurble> <wurble>) where
a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
-- compare to come...
\end{verbatim}
\item
@compare@ always has two parts. First, we use the compared
data-constructors' tags to deal with the case of different
constructors:
\begin{verbatim}
compare a b = case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
case (a# ==# b#) of {
True -> cmp_eq a b
False -> case (a# <# b#) of
True -> _LT
False -> _GT
}}}
where
cmp_eq = ... to come ...
\end{verbatim}
\item
We are only left with the ``help'' function @cmp_eq@, to deal with
comparing data constructors with the same tag.
For the ordinary constructors (if any), we emit the sorta-obvious
compare-style stuff; for our example:
\begin{verbatim}
cmp_eq (O1 a1 b1) (O1 a2 b2)
= case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
cmp_eq (O2 a1) (O2 a2)
= compare a1 a2
cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
= case (compare a1 a2) of {
LT -> LT;
GT -> GT;
EQ -> case compare b1 b2 of {
LT -> LT;
GT -> GT;
EQ -> compare c1 c2
}
}
\end{verbatim}
Again, we must be careful about unlifted comparisons. For example,
if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
generate:
\begin{verbatim}
cmp_eq lt eq gt (O2 a1) (O2 a2)
= compareInt# a1 a2
-- or maybe the unfolded equivalent
\end{verbatim}
\item
For the remaining nullary constructors, we already know that the
tags are equal so:
\begin{verbatim}
cmp_eq _ _ = EQ
\end{verbatim}
\end{itemize}
If there is only one constructor in the Data Type we don't need the WildCard Pattern.
JJQC-30-Nov-1997
\begin{code}
<pre><a name="line-1"></a><a name="gen_Ord_binds"></a><span class='hs-definition'>gen_Ord_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a>
<a name="line-3"></a><span class='hs-definition'>gen_Ord_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-4"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span> <span class='hs-varid'>prim_tc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>primWrapperType_maybe</span> <span class='hs-varid'>tycon</span>
<a name="line-5"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>gen_PrimOrd_binds</span> <span class='hs-varid'>con</span> <span class='hs-varid'>prim_tc</span>
<a name="line-6"></a>
<a name="line-7"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-8"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitBag</span> <span class='hs-varid'>compare</span><span class='hs-layout'>,</span> <span class='hs-varid'>aux_binds</span><span class='hs-layout'>)</span>
<a name="line-9"></a> <span class='hs-comment'>-- `AndMonoBinds` compare </span>
<a name="line-10"></a> <span class='hs-comment'>-- The default declaration in PrelBase handles this</span>
<a name="line-11"></a> <span class='hs-keyword'>where</span>
<a name="line-12"></a> <span class='hs-varid'>aux_binds</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>single_con_type</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-13"></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-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-varid'>compare</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFunBind</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>compare_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>compare_matches</span><span class='hs-layout'>)</span>
<a name="line-16"></a> <span class='hs-varid'>compare_matches</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkMatch</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>compare_rhs</span> <span class='hs-varid'>cmp_eq_binds</span><span class='hs-keyglyph'>]</span>
<a name="line-17"></a> <span class='hs-varid'>cmp_eq_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>HsValBinds</span> <span class='hs-layout'>(</span><span class='hs-conid'>ValBindsIn</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitBag</span> <span class='hs-varid'>cmp_eq</span><span class='hs-layout'>)</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-18"></a>
<a name="line-19"></a> <span class='hs-varid'>compare_rhs</span>
<a name="line-20"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>single_con_type</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>cmp_eq_Expr</span> <span class='hs-varid'>a_Expr</span> <span class='hs-varid'>b_Expr</span>
<a name="line-21"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-22"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-23"></a> <span class='hs-layout'>(</span><span class='hs-varid'>cmp_tags_Expr</span> <span class='hs-varid'>eqInt_RDR</span> <span class='hs-varid'>ah_RDR</span> <span class='hs-varid'>bh_RDR</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>cmp_eq_Expr</span> <span class='hs-varid'>a_Expr</span> <span class='hs-varid'>b_Expr</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- True case</span>
<a name="line-25"></a> <span class='hs-comment'>-- False case; they aren't equal</span>
<a name="line-26"></a> <span class='hs-comment'>-- So we need to do a less-than comparison on the tags</span>
<a name="line-27"></a> <span class='hs-layout'>(</span><span class='hs-varid'>cmp_tags_Expr</span> <span class='hs-varid'>ltInt_RDR</span> <span class='hs-varid'>ah_RDR</span> <span class='hs-varid'>bh_RDR</span> <span class='hs-varid'>ltTag_Expr</span> <span class='hs-varid'>gtTag_Expr</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-28"></a>
<a name="line-29"></a> <span class='hs-varid'>tycon_data_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span>
<a name="line-30"></a> <span class='hs-varid'>single_con_type</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isSingleton</span> <span class='hs-varid'>tycon_data_cons</span>
<a name="line-31"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nullary_cons</span><span class='hs-layout'>,</span> <span class='hs-varid'>nonnullary_cons</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isNewTyCon</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>partition</span> <span class='hs-varid'>isNullarySrcDataCon</span> <span class='hs-varid'>tycon_data_cons</span>
<a name="line-34"></a>
<a name="line-35"></a> <span class='hs-varid'>cmp_eq</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>cmp_eq_RDR</span> <span class='hs-varid'>cmp_eq_match</span>
<a name="line-36"></a> <span class='hs-varid'>cmp_eq_match</span>
<a name="line-37"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isEnumerationTyCon</span> <span class='hs-varid'>tycon</span>
<a name="line-38"></a> <span class='hs-comment'>-- We know the tags are equal, so if it's an enumeration TyCon,</span>
<a name="line-39"></a> <span class='hs-comment'>-- then there is nothing left to do</span>
<a name="line-40"></a> <span class='hs-comment'>-- Catch this specially to avoid warnings</span>
<a name="line-41"></a> <span class='hs-comment'>-- about overlapping patterns from the desugarer,</span>
<a name="line-42"></a> <span class='hs-comment'>-- and to avoid unnecessary pattern-matching</span>
<a name="line-43"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-layout'>,</span><span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqTag_Expr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-44"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-45"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>pats_etc</span> <span class='hs-varid'>nonnullary_cons</span> <span class='hs-varop'>++</span>
<a name="line-46"></a> <span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>single_con_type</span> <span class='hs-keyword'>then</span> <span class='hs-comment'>-- Omit wildcards when there's just one </span>
<a name="line-47"></a> <span class='hs-conid'>[]</span> <span class='hs-comment'>-- constructor, to silence desugarer</span>
<a name="line-48"></a> <span class='hs-keyword'>else</span>
<a name="line-49"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>default_rhs</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-50"></a>
<a name="line-51"></a> <span class='hs-varid'>default_rhs</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>nullary_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>impossible_Expr</span> <span class='hs-comment'>-- Keep desugarer from complaining about</span>
<a name="line-52"></a> <span class='hs-comment'>-- inexhaustive patterns</span>
<a name="line-53"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eqTag_Expr</span> <span class='hs-comment'>-- Some nullary constructors;</span>
<a name="line-54"></a> <span class='hs-comment'>-- Tags are equal, no args => return EQ</span>
<a name="line-55"></a> <span class='hs-varid'>pats_etc</span> <span class='hs-varid'>data_con</span>
<a name="line-56"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>con1_pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>con2_pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-57"></a> <span class='hs-varid'>nested_compare_expr</span> <span class='hs-varid'>tys_needed</span> <span class='hs-varid'>as_needed</span> <span class='hs-varid'>bs_needed</span><span class='hs-layout'>)</span>
<a name="line-58"></a> <span class='hs-keyword'>where</span>
<a name="line-59"></a> <span class='hs-varid'>con1_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>as_needed</span>
<a name="line-60"></a> <span class='hs-varid'>con2_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>bs_needed</span>
<a name="line-61"></a>
<a name="line-62"></a> <span class='hs-varid'>data_con_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con</span>
<a name="line-63"></a> <span class='hs-varid'>con_arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>tys_needed</span>
<a name="line-64"></a> <span class='hs-varid'>as_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-65"></a> <span class='hs-varid'>bs_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-66"></a> <span class='hs-varid'>tys_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>data_con</span>
<a name="line-67"></a>
<a name="line-68"></a> <span class='hs-varid'>nested_compare_expr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ty</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>b</span><span class='hs-keyglyph'>]</span>
<a name="line-69"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>careful_compare_Case</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>eqTag_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-varid'>nested_compare_expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>ty</span><span class='hs-conop'>:</span><span class='hs-varid'>tys</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-conop'>:</span><span class='hs-keyword'>as</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>b</span><span class='hs-conop'>:</span><span class='hs-varid'>bs</span><span class='hs-layout'>)</span>
<a name="line-72"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>eq_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nested_compare_expr</span> <span class='hs-varid'>tys</span> <span class='hs-keyword'>as</span> <span class='hs-varid'>bs</span>
<a name="line-73"></a> <span class='hs-keyword'>in</span> <span class='hs-varid'>careful_compare_Case</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>eq_expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span>
<a name="line-74"></a>
<a name="line-75"></a> <span class='hs-varid'>nested_compare_expr</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"nested_compare_expr"</span> <span class='hs-comment'>-- Args always equal length</span>
</pre>\end{code}
Note [Comparision of primitive types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The general plan does not work well for data types like
data T = MkT Int# deriving( Ord )
The general plan defines the 'compare' method, gets (<) etc from it. But
that means we get silly code like:
instance Ord T where
(>) (I# x) (I# y) = case <# x y of
True -> False
False -> case ==# x y of
True -> False
False -> True
We would prefer to use the (>#) primop. See also Trac #2130
\begin{code}
<pre><a name="line-1"></a><a name="gen_PrimOrd_binds"></a><span class='hs-definition'>gen_PrimOrd_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-comment'>-- See Note [Comparison of primitive types]</span>
<a name="line-3"></a><span class='hs-definition'>gen_PrimOrd_binds</span> <span class='hs-varid'>data_con</span> <span class='hs-varid'>prim_tc</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mk_op</span> <span class='hs-varid'>lt_RDR</span> <span class='hs-varid'>lt_op</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_op</span> <span class='hs-varid'>le_RDR</span> <span class='hs-varid'>le_op</span><span class='hs-layout'>,</span>
<a name="line-5"></a> <span class='hs-varid'>mk_op</span> <span class='hs-varid'>ge_RDR</span> <span class='hs-varid'>ge_op</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_op</span> <span class='hs-varid'>gt_RDR</span> <span class='hs-varid'>gt_op</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-keyword'>where</span>
<a name="line-7"></a> <span class='hs-varid'>mk_op</span> <span class='hs-varid'>op_RDR</span> <span class='hs-varid'>op</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-layout'>(</span><span class='hs-varid'>getSrcSpan</span> <span class='hs-varid'>data_con</span><span class='hs-layout'>)</span> <span class='hs-varid'>op_RDR</span>
<a name="line-8"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>apat</span><span class='hs-layout'>,</span> <span class='hs-varid'>bpat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>primOpRdrName</span> <span class='hs-varid'>op</span><span class='hs-layout'>)</span> <span class='hs-varid'>b_Expr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-9"></a> <span class='hs-varid'>con_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con</span>
<a name="line-10"></a> <span class='hs-varid'>apat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>con_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_RDR</span><span class='hs-keyglyph'>]</span>
<a name="line-11"></a> <span class='hs-varid'>bpat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>con_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>b_RDR</span><span class='hs-keyglyph'>]</span>
<a name="line-12"></a>
<a name="line-13"></a> <span class='hs-layout'>(</span><span class='hs-varid'>lt_op</span><span class='hs-layout'>,</span> <span class='hs-varid'>le_op</span><span class='hs-layout'>,</span> <span class='hs-varid'>ge_op</span><span class='hs-layout'>,</span> <span class='hs-varid'>gt_op</span><span class='hs-layout'>)</span>
<a name="line-14"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>charPrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>CharLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>CharLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>CharGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>CharGtOp</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>intPrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>IntLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>IntLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>IntGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>IntGtOp</span><span class='hs-layout'>)</span>
<a name="line-16"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>wordPrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>WordLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>WordLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>WordGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>WordGtOp</span><span class='hs-layout'>)</span>
<a name="line-17"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>addrPrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>AddrLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>AddrLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>AddrGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>AddrGtOp</span><span class='hs-layout'>)</span>
<a name="line-18"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>floatPrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>FloatLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>FloatLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>FloatGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>FloatGtOp</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>prim_tc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>doublePrimTyCon</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>DoubleLtOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>DoubleLeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>DoubleGeOp</span><span class='hs-layout'>,</span> <span class='hs-conid'>DoubleGtOp</span><span class='hs-layout'>)</span>
<a name="line-20"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"Unexpected primitive tycon"</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>prim_tc</span><span class='hs-layout'>)</span>
<a name="line-21"></a>
<a name="line-22"></a>
<a name="line-23"></a><a name="primWrapperType_maybe"></a><span class='hs-definition'>primWrapperType_maybe</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataCon</span><span class='hs-layout'>,</span> <span class='hs-conid'>TyCon</span><span class='hs-layout'>)</span>
<a name="line-24"></a><span class='hs-comment'>-- True of data types that are wrappers around prmitive types</span>
<a name="line-25"></a><span class='hs-comment'>-- data T = MkT Word#</span>
<a name="line-26"></a><span class='hs-comment'>-- For these we want to generate all the (<), (<=) etc operations individually</span>
<a name="line-27"></a><span class='hs-definition'>primWrapperType_maybe</span> <span class='hs-varid'>tc</span>
<a name="line-28"></a> <span class='hs-keyglyph'>|</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tc</span>
<a name="line-29"></a> <span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ty</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>con</span>
<a name="line-30"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>prim_tc</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tcSplitTyConApp_maybe</span> <span class='hs-varid'>ty</span>
<a name="line-31"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>isPrimTyCon</span> <span class='hs-varid'>prim_tc</span>
<a name="line-32"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span> <span class='hs-varid'>prim_tc</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-34"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
</pre>\end{code}
%************************************************************************
%* *
Enum instances
%* *
%************************************************************************
@Enum@ can only be derived for enumeration types. For a type
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
\begin{verbatim}
instance ... Enum (Foo ...) where
succ x = toEnum (1 + fromEnum x)
pred x = toEnum (fromEnum x - 1)
toEnum i = tag2con_Foo i
enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
-- or, really...
enumFrom a
= case con2tag_Foo a of
a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
enumFromThen a b
= map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
-- or, really...
enumFromThen a b
= case con2tag_Foo a of { a# ->
case con2tag_Foo b of { b# ->
map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
}}
\end{verbatim}
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
<pre><a name="line-1"></a><a name="gen_Enum_binds"></a><span class='hs-definition'>gen_Enum_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Enum_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>method_binds</span><span class='hs-layout'>,</span> <span class='hs-varid'>aux_binds</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-keyword'>where</span>
<a name="line-5"></a> <span class='hs-varid'>method_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span>
<a name="line-6"></a> <span class='hs-varid'>succ_enum</span><span class='hs-layout'>,</span>
<a name="line-7"></a> <span class='hs-varid'>pred_enum</span><span class='hs-layout'>,</span>
<a name="line-8"></a> <span class='hs-varid'>to_enum</span><span class='hs-layout'>,</span>
<a name="line-9"></a> <span class='hs-varid'>enum_from</span><span class='hs-layout'>,</span>
<a name="line-10"></a> <span class='hs-varid'>enum_from_then</span><span class='hs-layout'>,</span>
<a name="line-11"></a> <span class='hs-varid'>from_enum</span>
<a name="line-12"></a> <span class='hs-keyglyph'>]</span>
<a name="line-13"></a> <span class='hs-varid'>aux_binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>,</span> <span class='hs-conid'>GenTag2Con</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>,</span> <span class='hs-conid'>GenMaxTag</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-varid'>occ_nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getOccString</span> <span class='hs-varid'>tycon</span>
<a name="line-16"></a>
<a name="line-17"></a> <span class='hs-varid'>succ_enum</span>
<a name="line-18"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>succ_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-19"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-20"></a> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>eq_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-21"></a> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-22"></a> <span class='hs-layout'>(</span><span class='hs-varid'>illegal_Expr</span> <span class='hs-str'>"succ"</span> <span class='hs-varid'>occ_nm</span> <span class='hs-str'>"tried to take `succ' of last tag in enumeration"</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>plus_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-25"></a> <span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>1</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-26"></a>
<a name="line-27"></a> <span class='hs-varid'>pred_enum</span>
<a name="line-28"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>pred_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-29"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-30"></a> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>eq_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-layout'>,</span>
<a name="line-31"></a> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-layout'>(</span><span class='hs-varid'>illegal_Expr</span> <span class='hs-str'>"pred"</span> <span class='hs-varid'>occ_nm</span> <span class='hs-str'>"tried to take `pred' of first tag in enumeration"</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>plus_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-35"></a> <span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsInt</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-36"></a>
<a name="line-37"></a> <span class='hs-varid'>to_enum</span>
<a name="line-38"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>toEnum_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-39"></a> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>and_RDR</span>
<a name="line-40"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>ge_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-41"></a> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>le_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-42"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-43"></a> <span class='hs-layout'>(</span><span class='hs-varid'>illegal_toEnum_tag</span> <span class='hs-varid'>occ_nm</span> <span class='hs-layout'>(</span><span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-44"></a>
<a name="line-45"></a> <span class='hs-varid'>enum_from</span>
<a name="line-46"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>enumFrom_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-47"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-48"></a> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>map_RDR</span>
<a name="line-49"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-50"></a> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>enum_from_to_Expr</span>
<a name="line-51"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-52"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-53"></a>
<a name="line-54"></a> <span class='hs-varid'>enum_from_then</span>
<a name="line-55"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>enumFromThen_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-56"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-57"></a> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>map_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span>
<a name="line-58"></a> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>enum_from_then_to_Expr</span>
<a name="line-59"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bh_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-61"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>gt_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-62"></a> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bh_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span>
<a name="line-64"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-66"></a>
<a name="line-67"></a> <span class='hs-varid'>from_enum</span>
<a name="line-68"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>fromEnum_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-69"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-70"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
Bounded instances
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="gen_Bounded_binds"></a><span class='hs-definition'>gen_Bounded_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Bounded_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isEnumerationTyCon</span> <span class='hs-varid'>tycon</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>min_bound_enum</span><span class='hs-layout'>,</span> <span class='hs-varid'>max_bound_enum</span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-6"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span><span class='hs-varid'>isSingleton</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-7"></a> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>min_bound_1con</span><span class='hs-layout'>,</span> <span class='hs-varid'>max_bound_1con</span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</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-varid'>data_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-comment'>----- enum-flavored: ---------------------------</span>
<a name="line-12"></a> <span class='hs-varid'>min_bound_enum</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>minBound_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>data_con_1_RDR</span><span class='hs-layout'>)</span>
<a name="line-13"></a> <span class='hs-varid'>max_bound_enum</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>maxBound_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>data_con_N_RDR</span><span class='hs-layout'>)</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-varid'>data_con_1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>head</span> <span class='hs-varid'>data_cons</span>
<a name="line-16"></a> <span class='hs-varid'>data_con_N</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>last</span> <span class='hs-varid'>data_cons</span>
<a name="line-17"></a> <span class='hs-varid'>data_con_1_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con_1</span>
<a name="line-18"></a> <span class='hs-varid'>data_con_N_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con_N</span>
<a name="line-19"></a>
<a name="line-20"></a> <span class='hs-comment'>----- single-constructor-flavored: -------------</span>
<a name="line-21"></a> <span class='hs-varid'>arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>data_con_1</span>
<a name="line-22"></a>
<a name="line-23"></a> <span class='hs-varid'>min_bound_1con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>minBound_RDR</span> <span class='hs-varop'>$</span>
<a name="line-24"></a> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>data_con_1_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nOfThem</span> <span class='hs-varid'>arity</span> <span class='hs-varid'>minBound_RDR</span><span class='hs-layout'>)</span>
<a name="line-25"></a> <span class='hs-varid'>max_bound_1con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>maxBound_RDR</span> <span class='hs-varop'>$</span>
<a name="line-26"></a> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>data_con_1_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nOfThem</span> <span class='hs-varid'>arity</span> <span class='hs-varid'>maxBound_RDR</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
Ix instances
%* *
%************************************************************************
Deriving @Ix@ is only possible for enumeration types and
single-constructor types. We deal with them in turn.
For an enumeration type, e.g.,
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
things go not too differently from @Enum@:
\begin{verbatim}
instance ... Ix (Foo ...) where
range (a, b)
= map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
-- or, really...
range (a, b)
= case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
map tag2con_Foo (enumFromTo (I# a#) (I# b#))
}}
-- Generate code for unsafeIndex, becuase using index leads
-- to lots of redundant range tests
unsafeIndex c@(a, b) d
= case (con2tag_Foo d -# con2tag_Foo a) of
r# -> I# r#
inRange (a, b) c
= let
p_tag = con2tag_Foo c
in
p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
-- or, really...
inRange (a, b) c
= case (con2tag_Foo a) of { a_tag ->
case (con2tag_Foo b) of { b_tag ->
case (con2tag_Foo c) of { c_tag ->
if (c_tag >=# a_tag) then
c_tag <=# b_tag
else
False
}}}
\end{verbatim}
(modulo suitable case-ification to handle the unlifted tags)
For a single-constructor type (NB: this includes all tuples), e.g.,
\begin{verbatim}
data Foo ... = MkFoo a b Int Double c c
\end{verbatim}
we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
<pre><a name="line-1"></a><a name="gen_Ix_binds"></a><span class='hs-definition'>gen_Ix_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a>
<a name="line-3"></a><span class='hs-definition'>gen_Ix_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-4"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isEnumerationTyCon</span> <span class='hs-varid'>tycon</span>
<a name="line-5"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>enum_ixes</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>,</span> <span class='hs-conid'>GenTag2Con</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>,</span> <span class='hs-conid'>GenMaxTag</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>single_con_ixes</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</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'>--------------------------------------------------------------</span>
<a name="line-10"></a> <span class='hs-varid'>enum_ixes</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>enum_range</span><span class='hs-layout'>,</span> <span class='hs-varid'>enum_index</span><span class='hs-layout'>,</span> <span class='hs-varid'>enum_inRange</span> <span class='hs-keyglyph'>]</span>
<a name="line-11"></a>
<a name="line-12"></a> <span class='hs-varid'>enum_range</span>
<a name="line-13"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>range_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-14"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-15"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-16"></a> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>map_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span>
<a name="line-17"></a> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>enum_from_to_Expr</span>
<a name="line-18"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>ah_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bh_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-20"></a>
<a name="line-21"></a> <span class='hs-varid'>enum_index</span>
<a name="line-22"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>unsafeIndex_RDR</span>
<a name="line-23"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-conid'>AsPat</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-varid'>c_RDR</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-25"></a> <span class='hs-varid'>d_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-26"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-27"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>d_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>dh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-28"></a> <span class='hs-keyword'>let</span>
<a name="line-29"></a> <span class='hs-varid'>rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>c_RDR</span><span class='hs-keyglyph'>]</span>
<a name="line-30"></a> <span class='hs-keyword'>in</span>
<a name="line-31"></a> <span class='hs-varid'>nlHsCase</span>
<a name="line-32"></a> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>dh_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>minusInt_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>c_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs</span><span class='hs-keyglyph'>]</span>
<a name="line-34"></a> <span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-35"></a> <span class='hs-layout'>)</span>
<a name="line-36"></a>
<a name="line-37"></a> <span class='hs-varid'>enum_inRange</span>
<a name="line-38"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>inRange_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-layout'>,</span> <span class='hs-varid'>c_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-39"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-40"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-41"></a> <span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>c_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ch_RDR</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span>
<a name="line-42"></a> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ch_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>geInt_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span>
<a name="line-43"></a> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ch_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>leInt_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-44"></a> <span class='hs-layout'>)</span> <span class='hs-comment'>{-else-}</span> <span class='hs-layout'>(</span>
<a name="line-45"></a> <span class='hs-varid'>false_Expr</span>
<a name="line-46"></a> <span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-comment'>--------------------------------------------------------------</span>
<a name="line-49"></a> <span class='hs-varid'>single_con_ixes</span>
<a name="line-50"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>single_con_range</span><span class='hs-layout'>,</span> <span class='hs-varid'>single_con_index</span><span class='hs-layout'>,</span> <span class='hs-varid'>single_con_inRange</span><span class='hs-keyglyph'>]</span>
<a name="line-51"></a>
<a name="line-52"></a> <span class='hs-varid'>data_con</span>
<a name="line-53"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>tyConSingleDataCon_maybe</span> <span class='hs-varid'>tycon</span> <span class='hs-keyword'>of</span> <span class='hs-comment'>-- just checking...</span>
<a name="line-54"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>panic</span> <span class='hs-str'>"get_Ix_binds"</span>
<a name="line-55"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>dc</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>dc</span>
<a name="line-56"></a>
<a name="line-57"></a> <span class='hs-varid'>con_arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>data_con</span>
<a name="line-58"></a> <span class='hs-varid'>data_con_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con</span>
<a name="line-59"></a>
<a name="line-60"></a> <span class='hs-varid'>as_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-61"></a> <span class='hs-varid'>bs_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-62"></a> <span class='hs-varid'>cs_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>cs_RDRs</span>
<a name="line-63"></a>
<a name="line-64"></a> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>xs</span>
<a name="line-65"></a> <span class='hs-varid'>con_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>cs_needed</span>
<a name="line-66"></a>
<a name="line-67"></a> <span class='hs-comment'>--------------------------------------------------------------</span>
<a name="line-68"></a> <span class='hs-varid'>single_con_range</span>
<a name="line-69"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>range_RDR</span>
<a name="line-70"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con_pat</span> <span class='hs-varid'>as_needed</span><span class='hs-layout'>,</span> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>bs_needed</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-71"></a> <span class='hs-varid'>nlHsDo</span> <span class='hs-conid'>ListComp</span> <span class='hs-varid'>stmts</span> <span class='hs-varid'>con_expr</span>
<a name="line-72"></a> <span class='hs-keyword'>where</span>
<a name="line-73"></a> <span class='hs-varid'>stmts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWith3Equal</span> <span class='hs-str'>"single_con_range"</span> <span class='hs-varid'>mk_qual</span> <span class='hs-varid'>as_needed</span> <span class='hs-varid'>bs_needed</span> <span class='hs-varid'>cs_needed</span>
<a name="line-74"></a>
<a name="line-75"></a> <span class='hs-varid'>mk_qual</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-varid'>c</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>noLoc</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkBindStmt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>c</span><span class='hs-layout'>)</span>
<a name="line-76"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>range_RDR</span><span class='hs-layout'>)</span>
<a name="line-77"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkLHsVarTuple</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-78"></a>
<a name="line-79"></a> <span class='hs-comment'>----------------</span>
<a name="line-80"></a> <span class='hs-varid'>single_con_index</span>
<a name="line-81"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>unsafeIndex_RDR</span>
<a name="line-82"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con_pat</span> <span class='hs-varid'>as_needed</span><span class='hs-layout'>,</span> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>bs_needed</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-layout'>,</span>
<a name="line-83"></a> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>cs_needed</span><span class='hs-keyglyph'>]</span>
<a name="line-84"></a> <span class='hs-comment'>-- We need to reverse the order we consider the components in</span>
<a name="line-85"></a> <span class='hs-comment'>-- so that</span>
<a name="line-86"></a> <span class='hs-comment'>-- range (l,u) !! index (l,u) i == i -- when i is in range</span>
<a name="line-87"></a> <span class='hs-comment'>-- (from <a href="http://haskell.org/onlinereport/ix.html)">http://haskell.org/onlinereport/ix.html)</a> holds.</span>
<a name="line-88"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mk_index</span> <span class='hs-layout'>(</span><span class='hs-varid'>reverse</span> <span class='hs-varop'>$</span> <span class='hs-varid'>zip3</span> <span class='hs-varid'>as_needed</span> <span class='hs-varid'>bs_needed</span> <span class='hs-varid'>cs_needed</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-89"></a> <span class='hs-keyword'>where</span>
<a name="line-90"></a> <span class='hs-comment'>-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)</span>
<a name="line-91"></a> <span class='hs-varid'>mk_index</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span>
<a name="line-92"></a> <span class='hs-varid'>mk_index</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>l</span><span class='hs-layout'>,</span><span class='hs-varid'>u</span><span class='hs-layout'>,</span><span class='hs-varid'>i</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_one</span> <span class='hs-varid'>l</span> <span class='hs-varid'>u</span> <span class='hs-varid'>i</span>
<a name="line-93"></a> <span class='hs-varid'>mk_index</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>l</span><span class='hs-layout'>,</span><span class='hs-varid'>u</span><span class='hs-layout'>,</span><span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>rest</span><span class='hs-layout'>)</span>
<a name="line-94"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span>
<a name="line-95"></a> <span class='hs-varid'>mk_one</span> <span class='hs-varid'>l</span> <span class='hs-varid'>u</span> <span class='hs-varid'>i</span>
<a name="line-96"></a> <span class='hs-layout'>)</span> <span class='hs-varid'>plus_RDR</span> <span class='hs-layout'>(</span>
<a name="line-97"></a> <span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span>
<a name="line-98"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>unsafeRangeSize_RDR</span><span class='hs-layout'>)</span>
<a name="line-99"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkLHsVarTuple</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>l</span><span class='hs-layout'>,</span><span class='hs-varid'>u</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-100"></a> <span class='hs-layout'>)</span> <span class='hs-varid'>times_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_index</span> <span class='hs-varid'>rest</span><span class='hs-layout'>)</span>
<a name="line-101"></a> <span class='hs-layout'>)</span>
<a name="line-102"></a> <span class='hs-varid'>mk_one</span> <span class='hs-varid'>l</span> <span class='hs-varid'>u</span> <span class='hs-varid'>i</span>
<a name="line-103"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>unsafeIndex_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkLHsVarTuple</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>l</span><span class='hs-layout'>,</span><span class='hs-varid'>u</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>i</span><span class='hs-keyglyph'>]</span>
<a name="line-104"></a>
<a name="line-105"></a> <span class='hs-comment'>------------------</span>
<a name="line-106"></a> <span class='hs-varid'>single_con_inRange</span>
<a name="line-107"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>inRange_RDR</span>
<a name="line-108"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlTuplePat</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con_pat</span> <span class='hs-varid'>as_needed</span><span class='hs-layout'>,</span> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>bs_needed</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Boxed</span><span class='hs-layout'>,</span>
<a name="line-109"></a> <span class='hs-varid'>con_pat</span> <span class='hs-varid'>cs_needed</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-110"></a> <span class='hs-varid'>foldl1</span> <span class='hs-varid'>and_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>zipWith3Equal</span> <span class='hs-str'>"single_con_inRange"</span> <span class='hs-varid'>in_range</span> <span class='hs-varid'>as_needed</span> <span class='hs-varid'>bs_needed</span> <span class='hs-varid'>cs_needed</span><span class='hs-layout'>)</span>
<a name="line-111"></a> <span class='hs-keyword'>where</span>
<a name="line-112"></a> <span class='hs-varid'>in_range</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-varid'>c</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>inRange_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkLHsVarTuple</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>c</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
%************************************************************************
%* *
Read instances
%* *
%************************************************************************
Example
infix 4 %%
data T = Int %% Int
| T1 { f1 :: Int }
| T2 T
instance Read T where
readPrec =
parens
( prec 4 (
do x <- ReadP.step Read.readPrec
Symbol "%%" <- Lex.lex
y <- ReadP.step Read.readPrec
return (x %% y))
+++
prec (appPrec+1) (
-- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
-- Record construction binds even more tightly than application
do Ident "T1" <- Lex.lex
Punc '{' <- Lex.lex
Ident "f1" <- Lex.lex
Punc '=' <- Lex.lex
x <- ReadP.reset Read.readPrec
Punc '}' <- Lex.lex
return (T1 { f1 = x }))
+++
prec appPrec (
do Ident "T2" <- Lex.lexP
x <- ReadP.step Read.readPrec
return (T2 x))
)
readListPrec = readListPrecDefault
readList = readListDefault
\begin{code}
<pre><a name="line-1"></a><a name="gen_Read_binds"></a><span class='hs-definition'>gen_Read_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FixityEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a>
<a name="line-3"></a><span class='hs-definition'>gen_Read_binds</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_prec</span><span class='hs-layout'>,</span> <span class='hs-varid'>default_readlist</span><span class='hs-layout'>,</span> <span class='hs-varid'>default_readlistprec</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-keyword'>where</span>
<a name="line-6"></a> <span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-7"></a> <span class='hs-varid'>default_readlist</span>
<a name="line-8"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>readList_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>readListDefault_RDR</span><span class='hs-layout'>)</span>
<a name="line-9"></a>
<a name="line-10"></a> <span class='hs-varid'>default_readlistprec</span>
<a name="line-11"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>readListPrec_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>readListPrecDefault_RDR</span><span class='hs-layout'>)</span>
<a name="line-12"></a> <span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-13"></a>
<a name="line-14"></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-15"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nullary_cons</span><span class='hs-layout'>,</span> <span class='hs-varid'>non_nullary_cons</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>partition</span> <span class='hs-varid'>isNullarySrcDataCon</span> <span class='hs-varid'>data_cons</span>
<a name="line-16"></a>
<a name="line-17"></a> <span class='hs-varid'>read_prec</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>readPrec_RDR</span>
<a name="line-18"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>parens_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>read_cons</span><span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a> <span class='hs-varid'>read_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr1</span> <span class='hs-varid'>mk_alt</span> <span class='hs-layout'>(</span><span class='hs-varid'>read_nullary_cons</span> <span class='hs-varop'>++</span> <span class='hs-varid'>read_non_nullary_cons</span><span class='hs-layout'>)</span>
<a name="line-21"></a> <span class='hs-varid'>read_non_nullary_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>read_non_nullary_con</span> <span class='hs-varid'>non_nullary_cons</span>
<a name="line-22"></a>
<a name="line-23"></a> <span class='hs-varid'>read_nullary_cons</span>
<a name="line-24"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>nullary_cons</span> <span class='hs-keyword'>of</span>
<a name="line-25"></a> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>[]</span>
<a name="line-26"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsDo</span> <span class='hs-conid'>DoExpr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>ident_pat</span> <span class='hs-layout'>(</span><span class='hs-varid'>data_con_str</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-27"></a> <span class='hs-layout'>(</span><span class='hs-varid'>result_expr</span> <span class='hs-varid'>con</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-28"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>choose_RDR</span><span class='hs-layout'>)</span>
<a name="line-29"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlList</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>mk_pair</span> <span class='hs-varid'>nullary_cons</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-30"></a>
<a name="line-31"></a> <span class='hs-varid'>mk_pair</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkLHsTupleExpr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-varid'>data_con_str</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-32"></a> <span class='hs-varid'>result_expr</span> <span class='hs-varid'>con</span> <span class='hs-conid'>[]</span><span class='hs-keyglyph'>]</span>
<a name="line-33"></a>
<a name="line-34"></a> <span class='hs-varid'>read_non_nullary_con</span> <span class='hs-varid'>data_con</span>
<a name="line-35"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_parser</span> <span class='hs-varid'>infix_prec</span> <span class='hs-varid'>infix_stmts</span> <span class='hs-varid'>body</span>
<a name="line-36"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>is_record</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_parser</span> <span class='hs-varid'>record_prec</span> <span class='hs-varid'>record_stmts</span> <span class='hs-varid'>body</span>
<a name="line-37"></a><span class='hs-comment'>-- Using these two lines instead allows the derived</span>
<a name="line-38"></a><span class='hs-comment'>-- read for infix and record bindings to read the prefix form</span>
<a name="line-39"></a><span class='hs-comment'>-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)</span>
<a name="line-40"></a><span class='hs-comment'>-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)</span>
<a name="line-41"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>prefix_parser</span>
<a name="line-42"></a> <span class='hs-keyword'>where</span>
<a name="line-43"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>result_expr</span> <span class='hs-varid'>data_con</span> <span class='hs-varid'>as_needed</span>
<a name="line-44"></a> <span class='hs-varid'>con_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>data_con_str</span> <span class='hs-varid'>data_con</span>
<a name="line-45"></a>
<a name="line-46"></a> <span class='hs-varid'>prefix_parser</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_parser</span> <span class='hs-varid'>prefix_prec</span> <span class='hs-varid'>prefix_stmts</span> <span class='hs-varid'>body</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-varid'>read_prefix_con</span>
<a name="line-49"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSym</span> <span class='hs-varid'>con_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>"("</span><span class='hs-layout'>,</span> <span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>symbol_pat</span> <span class='hs-varid'>con_str</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>read_punc</span> <span class='hs-str'>")"</span><span class='hs-keyglyph'>]</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-keyglyph'>[</span><span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>ident_pat</span> <span class='hs-varid'>con_str</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-51"></a>
<a name="line-52"></a> <span class='hs-varid'>read_infix_con</span>
<a name="line-53"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSym</span> <span class='hs-varid'>con_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>symbol_pat</span> <span class='hs-varid'>con_str</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-54"></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-varid'>read_punc</span> <span class='hs-str'>"`"</span><span class='hs-layout'>,</span> <span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>ident_pat</span> <span class='hs-varid'>con_str</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>read_punc</span> <span class='hs-str'>"`"</span><span class='hs-keyglyph'>]</span>
<a name="line-55"></a>
<a name="line-56"></a> <span class='hs-varid'>prefix_stmts</span> <span class='hs-comment'>-- T a b c</span>
<a name="line-57"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>read_prefix_con</span> <span class='hs-varop'>++</span> <span class='hs-varid'>read_args</span>
<a name="line-58"></a>
<a name="line-59"></a> <span class='hs-varid'>infix_stmts</span> <span class='hs-comment'>-- a %% b, or a `T` b </span>
<a name="line-60"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_a1</span><span class='hs-keyglyph'>]</span>
<a name="line-61"></a> <span class='hs-varop'>++</span> <span class='hs-varid'>read_infix_con</span>
<a name="line-62"></a> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_a2</span><span class='hs-keyglyph'>]</span>
<a name="line-63"></a>
<a name="line-64"></a> <span class='hs-varid'>record_stmts</span> <span class='hs-comment'>-- T { f1 = a, f2 = b }</span>
<a name="line-65"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>read_prefix_con</span>
<a name="line-66"></a> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>"{"</span><span class='hs-keyglyph'>]</span>
<a name="line-67"></a> <span class='hs-varop'>++</span> <span class='hs-varid'>concat</span> <span class='hs-layout'>(</span><span class='hs-varid'>intersperse</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>","</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>field_stmts</span><span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>"}"</span><span class='hs-keyglyph'>]</span>
<a name="line-69"></a>
<a name="line-70"></a> <span class='hs-varid'>field_stmts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWithEqual</span> <span class='hs-str'>"lbl_stmts"</span> <span class='hs-varid'>read_field</span> <span class='hs-varid'>labels</span> <span class='hs-varid'>as_needed</span>
<a name="line-71"></a>
<a name="line-72"></a> <span class='hs-varid'>con_arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>data_con</span>
<a name="line-73"></a> <span class='hs-varid'>labels</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConFieldLabels</span> <span class='hs-varid'>data_con</span>
<a name="line-74"></a> <span class='hs-varid'>dc_nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getName</span> <span class='hs-varid'>data_con</span>
<a name="line-75"></a> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConIsInfix</span> <span class='hs-varid'>data_con</span>
<a name="line-76"></a> <span class='hs-varid'>is_record</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>labels</span> <span class='hs-varop'>></span> <span class='hs-num'>0</span>
<a name="line-77"></a> <span class='hs-varid'>as_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-78"></a> <span class='hs-varid'>read_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWithEqual</span> <span class='hs-str'>"gen_Read_binds"</span> <span class='hs-varid'>read_arg</span> <span class='hs-varid'>as_needed</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>data_con</span><span class='hs-layout'>)</span>
<a name="line-79"></a> <span class='hs-layout'>(</span><span class='hs-varid'>read_a1</span><span class='hs-conop'>:</span><span class='hs-varid'>read_a2</span><span class='hs-conop'>:</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>read_args</span>
<a name="line-80"></a>
<a name="line-81"></a> <span class='hs-varid'>prefix_prec</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>appPrecedence</span>
<a name="line-82"></a> <span class='hs-varid'>infix_prec</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getPrecedence</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>dc_nm</span>
<a name="line-83"></a> <span class='hs-varid'>record_prec</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>appPrecedence</span> <span class='hs-varop'>+</span> <span class='hs-num'>1</span> <span class='hs-comment'>-- Record construction binds even more tightly</span>
<a name="line-84"></a> <span class='hs-comment'>-- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})</span>
<a name="line-85"></a>
<a name="line-86"></a> <span class='hs-comment'>------------------------------------------------------------------------</span>
<a name="line-87"></a> <span class='hs-comment'>-- Helpers</span>
<a name="line-88"></a> <span class='hs-comment'>------------------------------------------------------------------------</span>
<a name="line-89"></a> <span class='hs-varid'>mk_alt</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>genOpApp</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>alt_RDR</span> <span class='hs-varid'>e2</span> <span class='hs-comment'>-- e1 +++ e2</span>
<a name="line-90"></a> <span class='hs-varid'>mk_parser</span> <span class='hs-varid'>p</span> <span class='hs-varid'>ss</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>prec_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-varid'>p</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsDo</span> <span class='hs-conid'>DoExpr</span> <span class='hs-varid'>ss</span> <span class='hs-varid'>b</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- prec p (do { ss ; b })</span>
<a name="line-91"></a> <span class='hs-varid'>bindLex</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBindStmt</span> <span class='hs-varid'>pat</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>lexP_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- pat <- lexP</span>
<a name="line-92"></a> <span class='hs-varid'>con_app</span> <span class='hs-varid'>con</span> <span class='hs-keyword'>as</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVarApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>getRdrName</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-keyword'>as</span> <span class='hs-comment'>-- con as</span>
<a name="line-93"></a> <span class='hs-varid'>result_expr</span> <span class='hs-varid'>con</span> <span class='hs-keyword'>as</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>returnM_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>con_app</span> <span class='hs-varid'>con</span> <span class='hs-keyword'>as</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- return (con as)</span>
<a name="line-94"></a>
<a name="line-95"></a> <span class='hs-varid'>punc_pat</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConPat</span> <span class='hs-varid'>punc_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlLitPat</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Punc 'c'</span>
<a name="line-96"></a> <span class='hs-varid'>ident_pat</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConPat</span> <span class='hs-varid'>ident_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlLitPat</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Ident "foo"</span>
<a name="line-97"></a> <span class='hs-varid'>symbol_pat</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConPat</span> <span class='hs-varid'>symbol_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlLitPat</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Symbol ">>"</span>
<a name="line-98"></a>
<a name="line-99"></a> <span class='hs-varid'>data_con_str</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>occNameString</span> <span class='hs-layout'>(</span><span class='hs-varid'>getOccName</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span>
<a name="line-100"></a>
<a name="line-101"></a> <span class='hs-varid'>read_punc</span> <span class='hs-varid'>c</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>punc_pat</span> <span class='hs-varid'>c</span><span class='hs-layout'>)</span>
<a name="line-102"></a> <span class='hs-varid'>read_arg</span> <span class='hs-varid'>a</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isUnLiftedType</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-103"></a> <span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBindStmt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>step_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>readPrec_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-104"></a>
<a name="line-105"></a> <span class='hs-varid'>read_field</span> <span class='hs-varid'>lbl</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>read_lbl</span> <span class='hs-varid'>lbl</span> <span class='hs-varop'>++</span>
<a name="line-106"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>"="</span><span class='hs-layout'>,</span>
<a name="line-107"></a> <span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkBindStmt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-varid'>reset_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>readPrec_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-108"></a>
<a name="line-109"></a> <span class='hs-comment'>-- When reading field labels we might encounter</span>
<a name="line-110"></a> <span class='hs-comment'>-- a = 3</span>
<a name="line-111"></a> <span class='hs-comment'>-- _a = 3</span>
<a name="line-112"></a> <span class='hs-comment'>-- or (#) = 4</span>
<a name="line-113"></a> <span class='hs-comment'>-- Note the parens!</span>
<a name="line-114"></a> <span class='hs-varid'>read_lbl</span> <span class='hs-varid'>lbl</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSym</span> <span class='hs-varid'>lbl_str</span>
<a name="line-115"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>read_punc</span> <span class='hs-str'>"("</span><span class='hs-layout'>,</span>
<a name="line-116"></a> <span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>symbol_pat</span> <span class='hs-varid'>lbl_str</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-117"></a> <span class='hs-varid'>read_punc</span> <span class='hs-str'>")"</span><span class='hs-keyglyph'>]</span>
<a name="line-118"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-119"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bindLex</span> <span class='hs-layout'>(</span><span class='hs-varid'>ident_pat</span> <span class='hs-varid'>lbl_str</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-120"></a> <span class='hs-keyword'>where</span>
<a name="line-121"></a> <span class='hs-varid'>lbl_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>occNameString</span> <span class='hs-layout'>(</span><span class='hs-varid'>getOccName</span> <span class='hs-varid'>lbl</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
Show instances
%* *
%************************************************************************
Example
infixr 5 :^:
data Tree a = Leaf a | Tree a :^: Tree a
instance (Show a) => Show (Tree a) where
showsPrec d (Leaf m) = showParen (d > app_prec) showStr
where
showStr = showString "Leaf " . showsPrec (app_prec+1) m
showsPrec d (u :^: v) = showParen (d > up_prec) showStr
where
showStr = showsPrec (up_prec+1) u .
showString " :^: " .
showsPrec (up_prec+1) v
-- Note: right-associativity of :^: ignored
up_prec = 5 -- Precedence of :^:
app_prec = 10 -- Application has precedence one more than
-- the most tightly-binding operator
\begin{code}
<pre><a name="line-1"></a><a name="gen_Show_binds"></a><span class='hs-definition'>gen_Show_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FixityEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a>
<a name="line-3"></a><span class='hs-definition'>gen_Show_binds</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>shows_prec</span><span class='hs-layout'>,</span> <span class='hs-varid'>show_list</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-keyword'>where</span>
<a name="line-6"></a> <span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-7"></a> <span class='hs-varid'>show_list</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>showList_RDR</span>
<a name="line-8"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showList___RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showsPrec_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-9"></a> <span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-10"></a> <span class='hs-varid'>shows_prec</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>showsPrec_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>pats_etc</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</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'>pats_etc</span> <span class='hs-varid'>data_con</span>
<a name="line-13"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>nullary_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- skip the showParen junk...</span>
<a name="line-14"></a> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span><span class='hs-varid'>null</span> <span class='hs-varid'>bs_needed</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-layout'>,</span> <span class='hs-varid'>con_pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_showString_app</span> <span class='hs-varid'>con_str</span><span class='hs-layout'>)</span>
<a name="line-16"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span>
<a name="line-17"></a> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>con_pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-18"></a> <span class='hs-varid'>showParen_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a_Expr</span> <span class='hs-varid'>ge_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsInt</span> <span class='hs-varid'>con_prec_plus_one</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nested_compose_Expr</span> <span class='hs-varid'>show_thingies</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-20"></a> <span class='hs-keyword'>where</span>
<a name="line-21"></a> <span class='hs-varid'>data_con_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>data_con</span>
<a name="line-22"></a> <span class='hs-varid'>con_arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>data_con</span>
<a name="line-23"></a> <span class='hs-varid'>bs_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-varid'>con_arity</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-24"></a> <span class='hs-varid'>arg_tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>data_con</span> <span class='hs-comment'>-- Correspond 1-1 with bs_needed</span>
<a name="line-25"></a> <span class='hs-varid'>con_pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>data_con_RDR</span> <span class='hs-varid'>bs_needed</span>
<a name="line-26"></a> <span class='hs-varid'>nullary_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>con_arity</span> <span class='hs-varop'>==</span> <span class='hs-num'>0</span>
<a name="line-27"></a> <span class='hs-varid'>labels</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConFieldLabels</span> <span class='hs-varid'>data_con</span>
<a name="line-28"></a> <span class='hs-varid'>lab_fields</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>labels</span>
<a name="line-29"></a> <span class='hs-varid'>record_syntax</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lab_fields</span> <span class='hs-varop'>></span> <span class='hs-num'>0</span>
<a name="line-30"></a>
<a name="line-31"></a> <span class='hs-varid'>dc_nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getName</span> <span class='hs-varid'>data_con</span>
<a name="line-32"></a> <span class='hs-varid'>dc_occ_nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getOccName</span> <span class='hs-varid'>data_con</span>
<a name="line-33"></a> <span class='hs-varid'>con_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>occNameString</span> <span class='hs-varid'>dc_occ_nm</span>
<a name="line-34"></a> <span class='hs-varid'>op_con_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>wrapOpParens</span> <span class='hs-varid'>con_str</span>
<a name="line-35"></a> <span class='hs-varid'>backquote_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>wrapOpBackquotes</span> <span class='hs-varid'>con_str</span>
<a name="line-36"></a>
<a name="line-37"></a> <span class='hs-varid'>show_thingies</span>
<a name="line-38"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>show_arg1</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_showString_app</span> <span class='hs-layout'>(</span><span class='hs-str'>" "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>backquote_str</span> <span class='hs-varop'>++</span> <span class='hs-str'>" "</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>show_arg2</span><span class='hs-keyglyph'>]</span>
<a name="line-39"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>record_syntax</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_showString_app</span> <span class='hs-layout'>(</span><span class='hs-varid'>op_con_str</span> <span class='hs-varop'>++</span> <span class='hs-str'>" {"</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span>
<a name="line-40"></a> <span class='hs-varid'>show_record_args</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mk_showString_app</span> <span class='hs-str'>"}"</span><span class='hs-keyglyph'>]</span>
<a name="line-41"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_showString_app</span> <span class='hs-layout'>(</span><span class='hs-varid'>op_con_str</span> <span class='hs-varop'>++</span> <span class='hs-str'>" "</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>show_prefix_args</span>
<a name="line-42"></a>
<a name="line-43"></a> <span class='hs-varid'>show_label</span> <span class='hs-varid'>l</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_showString_app</span> <span class='hs-layout'>(</span><span class='hs-varid'>nm</span> <span class='hs-varop'>++</span> <span class='hs-str'>" = "</span><span class='hs-layout'>)</span>
<a name="line-44"></a> <span class='hs-comment'>-- Note the spaces around the "=" sign. If we don't have them</span>
<a name="line-45"></a> <span class='hs-comment'>-- then we get Foo { x=-1 } and the "=-" parses as a single</span>
<a name="line-46"></a> <span class='hs-comment'>-- lexeme. Only the space after the '=' is necessary, but</span>
<a name="line-47"></a> <span class='hs-comment'>-- it seems tidier to have them both sides.</span>
<a name="line-48"></a> <span class='hs-keyword'>where</span>
<a name="line-49"></a> <span class='hs-varid'>occ_nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getOccName</span> <span class='hs-varid'>l</span>
<a name="line-50"></a> <span class='hs-varid'>nm</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>wrapOpParens</span> <span class='hs-layout'>(</span><span class='hs-varid'>occNameString</span> <span class='hs-varid'>occ_nm</span><span class='hs-layout'>)</span>
<a name="line-51"></a>
<a name="line-52"></a> <span class='hs-varid'>show_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWith</span> <span class='hs-varid'>show_arg</span> <span class='hs-varid'>bs_needed</span> <span class='hs-varid'>arg_tys</span>
<a name="line-53"></a> <span class='hs-layout'>(</span><span class='hs-varid'>show_arg1</span><span class='hs-conop'>:</span><span class='hs-varid'>show_arg2</span><span class='hs-conop'>:</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>show_args</span>
<a name="line-54"></a> <span class='hs-varid'>show_prefix_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>intersperse</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showSpace_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>show_args</span>
<a name="line-55"></a>
<a name="line-56"></a> <span class='hs-comment'>-- Assumption for record syntax: no of fields == no of labelled fields </span>
<a name="line-57"></a> <span class='hs-comment'>-- (and in same order)</span>
<a name="line-58"></a> <span class='hs-varid'>show_record_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>concat</span> <span class='hs-varop'>$</span>
<a name="line-59"></a> <span class='hs-varid'>intersperse</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mk_showString_app</span> <span class='hs-str'>", "</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>$</span>
<a name="line-60"></a> <span class='hs-keyglyph'>[</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>show_label</span> <span class='hs-varid'>lbl</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg</span><span class='hs-keyglyph'>]</span>
<a name="line-61"></a> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>lbl</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'>zipEqual</span> <span class='hs-str'>"gen_Show_binds"</span>
<a name="line-62"></a> <span class='hs-varid'>labels</span> <span class='hs-varid'>show_args</span> <span class='hs-keyglyph'>]</span>
<a name="line-63"></a>
<a name="line-64"></a> <span class='hs-comment'>-- Generates (showsPrec p x) for argument x, but it also boxes</span>
<a name="line-65"></a> <span class='hs-comment'>-- the argument first if necessary. Note that this prints unboxed</span>
<a name="line-66"></a> <span class='hs-comment'>-- things without any '#' decorations; could change that if need be</span>
<a name="line-67"></a> <span class='hs-varid'>show_arg</span> <span class='hs-varid'>b</span> <span class='hs-varid'>arg_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>showsPrec_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsInt</span> <span class='hs-varid'>arg_prec</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-68"></a> <span class='hs-varid'>box_if_necy</span> <span class='hs-str'>"Show"</span> <span class='hs-varid'>tycon</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg_ty</span><span class='hs-keyglyph'>]</span>
<a name="line-69"></a>
<a name="line-70"></a> <span class='hs-comment'>-- Fixity stuff</span>
<a name="line-71"></a> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConIsInfix</span> <span class='hs-varid'>data_con</span>
<a name="line-72"></a> <span class='hs-varid'>con_prec_plus_one</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>1</span> <span class='hs-varop'>+</span> <span class='hs-varid'>getPrec</span> <span class='hs-varid'>is_infix</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>dc_nm</span>
<a name="line-73"></a> <span class='hs-varid'>arg_prec</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>record_syntax</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0</span> <span class='hs-comment'>-- Record fields don't need parens</span>
<a name="line-74"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>con_prec_plus_one</span>
<a name="line-75"></a>
<a name="line-76"></a><a name="wrapOpParens"></a><span class='hs-definition'>wrapOpParens</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span>
<a name="line-77"></a><span class='hs-definition'>wrapOpParens</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSym</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-chr'>'('</span> <span class='hs-conop'>:</span> <span class='hs-varid'>s</span> <span class='hs-varop'>++</span> <span class='hs-str'>")"</span>
<a name="line-78"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>s</span>
<a name="line-79"></a>
<a name="line-80"></a><a name="wrapOpBackquotes"></a><span class='hs-definition'>wrapOpBackquotes</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span>
<a name="line-81"></a><span class='hs-definition'>wrapOpBackquotes</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSym</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>s</span>
<a name="line-82"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-chr'>'`'</span> <span class='hs-conop'>:</span> <span class='hs-varid'>s</span> <span class='hs-varop'>++</span> <span class='hs-str'>"`"</span>
<a name="line-83"></a>
<a name="line-84"></a><a name="isSym"></a><span class='hs-definition'>isSym</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-85"></a><span class='hs-definition'>isSym</span> <span class='hs-str'>""</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-86"></a><span class='hs-definition'>isSym</span> <span class='hs-layout'>(</span><span class='hs-varid'>c</span> <span class='hs-conop'>:</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>startsVarSym</span> <span class='hs-varid'>c</span> <span class='hs-varop'>||</span> <span class='hs-varid'>startsConSym</span> <span class='hs-varid'>c</span>
<a name="line-87"></a>
<a name="line-88"></a><a name="mk_showString_app"></a><span class='hs-definition'>mk_showString_app</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-89"></a><span class='hs-definition'>mk_showString_app</span> <span class='hs-varid'>str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showString_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-varid'>str</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="getPrec"></a><span class='hs-definition'>getPrec</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Bool</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>FixityEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Name</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Integer</span>
<a name="line-2"></a><span class='hs-definition'>getPrec</span> <span class='hs-varid'>is_infix</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>nm</span>
<a name="line-3"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>appPrecedence</span>
<a name="line-4"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getPrecedence</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>nm</span>
<a name="line-5"></a>
<a name="line-6"></a><a name="appPrecedence"></a><span class='hs-definition'>appPrecedence</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integer</span>
<a name="line-7"></a><span class='hs-definition'>appPrecedence</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>maxPrecedence</span> <span class='hs-varop'>+</span> <span class='hs-num'>1</span>
<a name="line-8"></a> <span class='hs-comment'>-- One more than the precedence of the most </span>
<a name="line-9"></a> <span class='hs-comment'>-- tightly-binding operator</span>
<a name="line-10"></a>
<a name="line-11"></a><a name="getPrecedence"></a><span class='hs-definition'>getPrecedence</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FixityEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Name</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Integer</span>
<a name="line-12"></a><span class='hs-definition'>getPrecedence</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>nm</span>
<a name="line-13"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupFixity</span> <span class='hs-varid'>get_fixity</span> <span class='hs-varid'>nm</span> <span class='hs-keyword'>of</span>
<a name="line-14"></a> <span class='hs-conid'>Fixity</span> <span class='hs-varid'>x</span> <span class='hs-sel'>_assoc</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>x</span>
<a name="line-15"></a> <span class='hs-comment'>-- NB: the Report says that associativity is not taken </span>
<a name="line-16"></a> <span class='hs-comment'>-- into account for either Read or Show; hence we </span>
<a name="line-17"></a> <span class='hs-comment'>-- ignore associativity here</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Typeable}
%* *
%************************************************************************
From the data type
data T a b = ....
we generate
instance Typeable2 T where
typeOf2 _ = mkTyConApp (mkTyConRep "T") []
We are passed the Typeable2 class as well as T
\begin{code}
<pre><a name="line-1"></a><a name="gen_Typeable_binds"></a><span class='hs-definition'>gen_Typeable_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span>
<a name="line-2"></a><span class='hs-definition'>gen_Typeable_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unitBag</span> <span class='hs-varop'>$</span>
<a name="line-4"></a> <span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span>
<a name="line-5"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mk_typeOf_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Name of appropriate type0f function</span>
<a name="line-6"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span>
<a name="line-7"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>mkTypeRep_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>tycon_rep</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlList</span> <span class='hs-conid'>[]</span><span class='hs-keyglyph'>]</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-varid'>tycon_rep</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>mkTyConRep_RDR</span> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-varid'>showSDocOneLine</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-10"></a>
<a name="line-11"></a><a name="mk_typeOf_RDR"></a><span class='hs-definition'>mk_typeOf_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span>
<a name="line-12"></a><span class='hs-comment'>-- Use the arity of the TyCon to make the right typeOfn function</span>
<a name="line-13"></a><span class='hs-definition'>mk_typeOf_RDR</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>tYPEABLE</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-layout'>(</span><span class='hs-str'>"typeOf"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>suffix</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-14"></a> <span class='hs-keyword'>where</span>
<a name="line-15"></a> <span class='hs-varid'>arity</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConArity</span> <span class='hs-varid'>tycon</span>
<a name="line-16"></a> <span class='hs-varid'>suffix</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>arity</span> <span class='hs-varop'>==</span> <span class='hs-num'>0</span> <span class='hs-keyglyph'>=</span> <span class='hs-str'>""</span>
<a name="line-17"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>show</span> <span class='hs-varid'>arity</span>
</pre>\end{code}
%************************************************************************
%* *
Data instances
%* *
%************************************************************************
From the data type
data T a b = T1 a b | T2
we generate
$cT1 = mkDataCon $dT "T1" Prefix
$cT2 = mkDataCon $dT "T2" Prefix
$dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
-- the [] is for field labels.
instance (Data a, Data b) => Data (T a b) where
gfoldl k z (T1 a b) = z T `k` a `k` b
gfoldl k z T2 = z T2
-- ToDo: add gmapT,Q,M, gfoldr
gunfold k z c = case conIndex c of
I# 1# -> k (k (z T1))
I# 2# -> z T2
toConstr (T1 _ _) = $cT1
toConstr T2 = $cT2
dataTypeOf _ = $dT
dataCast1 = gcast1 -- If T :: * -> *
dataCast2 = gcast2 -- if T :: * -> * -> *
\begin{code}
<pre><a name="line-1"></a><a name="gen_Data_binds"></a><span class='hs-definition'>gen_Data_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- The method bindings</span>
<a name="line-4"></a> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Auxiliary bindings</span>
<a name="line-5"></a><span class='hs-definition'>gen_Data_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-6"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>listToBag</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>gfoldl_bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>gunfold_bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>toCon_bind</span><span class='hs-layout'>,</span> <span class='hs-varid'>dataTypeOf_bind</span><span class='hs-keyglyph'>]</span>
<a name="line-7"></a> <span class='hs-varop'>`unionBags`</span> <span class='hs-varid'>gcast_binds</span><span class='hs-layout'>,</span>
<a name="line-8"></a> <span class='hs-comment'>-- Auxiliary definitions: the data type and constructors</span>
<a name="line-9"></a> <span class='hs-conid'>MkTyCon</span> <span class='hs-varid'>tycon</span> <span class='hs-conop'>:</span> <span class='hs-varid'>map</span> <span class='hs-conid'>MkDataCon</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-10"></a> <span class='hs-keyword'>where</span>
<a name="line-11"></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-12"></a> <span class='hs-varid'>n_cons</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>data_cons</span>
<a name="line-13"></a> <span class='hs-varid'>one_constr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>n_cons</span> <span class='hs-varop'>==</span> <span class='hs-num'>1</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-comment'>------------ gfoldl</span>
<a name="line-16"></a> <span class='hs-varid'>gfoldl_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>gfoldl_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>gfoldl_eqn</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-17"></a> <span class='hs-varid'>gfoldl_eqn</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>k_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>z_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>con_name</span> <span class='hs-varid'>as_needed</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-18"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>mk_k_app</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>z_RDR</span> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>con_name</span><span class='hs-layout'>)</span> <span class='hs-varid'>as_needed</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-keyword'>where</span>
<a name="line-20"></a> <span class='hs-varid'>con_name</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span>
<a name="line-21"></a> <span class='hs-varid'>con_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>con</span>
<a name="line-22"></a> <span class='hs-varid'>as_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>take</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-23"></a> <span class='hs-varid'>mk_k_app</span> <span class='hs-varid'>e</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsOpApp</span> <span class='hs-varid'>e</span> <span class='hs-varid'>k_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-24"></a>
<a name="line-25"></a> <span class='hs-comment'>------------ gunfold</span>
<a name="line-26"></a> <span class='hs-varid'>gunfold_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span>
<a name="line-27"></a> <span class='hs-varid'>gunfold_RDR</span>
<a name="line-28"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>k_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>z_Pat</span><span class='hs-layout'>,</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>one_constr</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>nlWildPat</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>c_Pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-29"></a> <span class='hs-varid'>gunfold_rhs</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-30"></a>
<a name="line-31"></a> <span class='hs-varid'>gunfold_rhs</span>
<a name="line-32"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>one_constr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_unfold_rhs</span> <span class='hs-layout'>(</span><span class='hs-varid'>head</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- No need for case</span>
<a name="line-33"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsCase</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>conIndex_RDR</span> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>c_Expr</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>gunfold_alt</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-35"></a>
<a name="line-36"></a> <span class='hs-varid'>gunfold_alt</span> <span class='hs-varid'>dc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_unfold_pat</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_unfold_rhs</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span>
<a name="line-37"></a> <span class='hs-varid'>mk_unfold_rhs</span> <span class='hs-varid'>dc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>nlHsApp</span>
<a name="line-38"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>z_RDR</span> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>getRdrName</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-39"></a> <span class='hs-layout'>(</span><span class='hs-varid'>replicate</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConSourceArity</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>k_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-40"></a>
<a name="line-41"></a> <span class='hs-varid'>mk_unfold_pat</span> <span class='hs-varid'>dc</span> <span class='hs-comment'>-- Last one is a wild-pat, to avoid </span>
<a name="line-42"></a> <span class='hs-comment'>-- redundant test, and annoying warning</span>
<a name="line-43"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>tag</span><span class='hs-comment'>-</span><span class='hs-varid'>fIRST_TAG</span> <span class='hs-varop'>==</span> <span class='hs-varid'>n_cons</span><span class='hs-comment'>-</span><span class='hs-num'>1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlWildPat</span> <span class='hs-comment'>-- Last constructor</span>
<a name="line-44"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConPat</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlLitPat</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsIntPrim</span> <span class='hs-layout'>(</span><span class='hs-varid'>toInteger</span> <span class='hs-varid'>tag</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-45"></a> <span class='hs-keyword'>where</span>
<a name="line-46"></a> <span class='hs-varid'>tag</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataConTag</span> <span class='hs-varid'>dc</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-comment'>------------ toConstr</span>
<a name="line-49"></a> <span class='hs-varid'>toCon_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>toConstr_RDR</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>to_con_eqn</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-50"></a> <span class='hs-varid'>to_con_eqn</span> <span class='hs-varid'>dc</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildConPat</span> <span class='hs-varid'>dc</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_constr_name</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-51"></a>
<a name="line-52"></a> <span class='hs-comment'>------------ dataTypeOf</span>
<a name="line-53"></a> <span class='hs-varid'>dataTypeOf_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_easy_FunBind</span>
<a name="line-54"></a> <span class='hs-varid'>loc</span>
<a name="line-55"></a> <span class='hs-varid'>dataTypeOf_RDR</span>
<a name="line-56"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildPat</span><span class='hs-keyglyph'>]</span>
<a name="line-57"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_data_type_name</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-58"></a>
<a name="line-59"></a> <span class='hs-comment'>------------ gcast1/2</span>
<a name="line-60"></a> <span class='hs-varid'>tycon_kind</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConKind</span> <span class='hs-varid'>tycon</span>
<a name="line-61"></a> <span class='hs-varid'>gcast_binds</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>tycon_kind</span> <span class='hs-varop'>`eqKind`</span> <span class='hs-varid'>kind1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_gcast</span> <span class='hs-varid'>dataCast1_RDR</span> <span class='hs-varid'>gcast1_RDR</span>
<a name="line-62"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>tycon_kind</span> <span class='hs-varop'>`eqKind`</span> <span class='hs-varid'>kind2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_gcast</span> <span class='hs-varid'>dataCast2_RDR</span> <span class='hs-varid'>gcast2_RDR</span>
<a name="line-63"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyBag</span>
<a name="line-64"></a> <span class='hs-varid'>mk_gcast</span> <span class='hs-varid'>dataCast_RDR</span> <span class='hs-varid'>gcast_RDR</span>
<a name="line-65"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unitBag</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_easy_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>dataCast_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>f_RDR</span><span class='hs-keyglyph'>]</span>
<a name="line-66"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>gcast_RDR</span> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>f_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-67"></a>
<a name="line-68"></a>
<a name="line-69"></a><a name="kind1"></a><span class='hs-definition'>kind1</span><span class='hs-layout'>,</span> <span class='hs-varid'>kind2</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Kind</span>
<a name="line-70"></a><span class='hs-definition'>kind1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftedTypeKind</span> <span class='hs-varop'>`mkArrowKind`</span> <span class='hs-varid'>liftedTypeKind</span>
<a name="line-71"></a><a name="kind2"></a><span class='hs-definition'>kind2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftedTypeKind</span> <span class='hs-varop'>`mkArrowKind`</span> <span class='hs-varid'>kind1</span>
<a name="line-72"></a>
<a name="line-73"></a><a name="gfoldl_RDR"></a><span class='hs-definition'>gfoldl_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>gunfold_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>toConstr_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>dataTypeOf_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkConstr_RDR</span><span class='hs-layout'>,</span>
<a name="line-74"></a> <span class='hs-varid'>mkDataType_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>conIndex_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>prefix_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>infix_RDR</span><span class='hs-layout'>,</span>
<a name="line-75"></a> <span class='hs-varid'>dataCast1_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>dataCast2_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>gcast1_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>gcast2_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span>
<a name="line-76"></a><span class='hs-definition'>gfoldl_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"gfoldl"</span><span class='hs-layout'>)</span>
<a name="line-77"></a><a name="gunfold_RDR"></a><span class='hs-definition'>gunfold_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"gunfold"</span><span class='hs-layout'>)</span>
<a name="line-78"></a><a name="toConstr_RDR"></a><span class='hs-definition'>toConstr_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"toConstr"</span><span class='hs-layout'>)</span>
<a name="line-79"></a><a name="dataTypeOf_RDR"></a><span class='hs-definition'>dataTypeOf_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"dataTypeOf"</span><span class='hs-layout'>)</span>
<a name="line-80"></a><a name="dataCast1_RDR"></a><span class='hs-definition'>dataCast1_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"dataCast1"</span><span class='hs-layout'>)</span>
<a name="line-81"></a><a name="dataCast2_RDR"></a><span class='hs-definition'>dataCast2_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"dataCast2"</span><span class='hs-layout'>)</span>
<a name="line-82"></a><a name="gcast1_RDR"></a><span class='hs-definition'>gcast1_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>tYPEABLE</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"gcast1"</span><span class='hs-layout'>)</span>
<a name="line-83"></a><a name="gcast2_RDR"></a><span class='hs-definition'>gcast2_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>tYPEABLE</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"gcast2"</span><span class='hs-layout'>)</span>
<a name="line-84"></a><a name="mkConstr_RDR"></a><span class='hs-definition'>mkConstr_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"mkConstr"</span><span class='hs-layout'>)</span>
<a name="line-85"></a><a name="mkDataType_RDR"></a><span class='hs-definition'>mkDataType_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"mkDataType"</span><span class='hs-layout'>)</span>
<a name="line-86"></a><a name="conIndex_RDR"></a><span class='hs-definition'>conIndex_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"constrIndex"</span><span class='hs-layout'>)</span>
<a name="line-87"></a><a name="prefix_RDR"></a><span class='hs-definition'>prefix_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"Prefix"</span><span class='hs-layout'>)</span>
<a name="line-88"></a><a name="infix_RDR"></a><span class='hs-definition'>infix_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>dataQual_RDR</span> <span class='hs-varid'>gENERICS</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"Infix"</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
Functor instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
For the data type:
data T a = T1 Int a | T2 (T a)
We generate the instance:
instance Functor T where
fmap f (T1 b1 a) = T1 b1 (f a)
fmap f (T2 ta) = T2 (fmap f ta)
Notice that we don't simply apply 'fmap' to the constructor arguments.
Rather
- Do nothing to an argument whose type doesn't mention 'a'
- Apply 'f' to an argument of type 'a'
- Apply 'fmap f' to other arguments
That's why we have to recurse deeply into the constructor argument types,
rather than just one level, as we typically do.
What about types with more than one type parameter? In general, we only
derive Functor for the last position:
data S a b = S1 [b] | S2 (a, T a b)
instance Functor (S a) where
fmap f (S1 bs) = S1 (fmap f bs)
fmap f (S2 (p,q)) = S2 (a, fmap f q)
However, we have special cases for
- tuples
- functions
More formally, we write the derivation of fmap code over type variable
'a for type 'b as ($fmap 'a 'b). In this general notation the derived
instance for T is:
instance Functor T where
fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
$(fmap 'a 'b) x = x -- when b does not contain a
$(fmap 'a 'a) x = f x
$(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
$(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
$(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
For functions, the type parameter 'a can occur in a contravariant position,
which means we need to derive a function like:
cofmap :: (a -> b) -> (f b -> f a)
This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
$(cofmap 'a 'b) x = x -- when b does not contain a
$(cofmap 'a 'a) x = error "type variable in contravariant position"
$(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
$(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
$(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
$(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
\begin{code}
<pre><a name="line-1"></a><a name="gen_Functor_binds"></a><span class='hs-definition'>gen_Functor_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Functor_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitBag</span> <span class='hs-varid'>fmap_bind</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-keyword'>where</span>
<a name="line-5"></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-6"></a>
<a name="line-7"></a> <span class='hs-varid'>fmap_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkFunBind</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>fmap_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>fmap_eqn</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-varid'>fmap_eqn</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalState</span> <span class='hs-layout'>(</span><span class='hs-varid'>match_for_con</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>f_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>con</span> <span class='hs-varid'>parts</span><span class='hs-layout'>)</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>parts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldDataConArgs</span> <span class='hs-varid'>ft_fmap</span> <span class='hs-varid'>con</span>
<a name="line-11"></a>
<a name="line-12"></a> <span class='hs-varid'>ft_fmap</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FFoldType</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-13"></a> <span class='hs-comment'>-- Tricky higher order type; I can't say I fully understand this code :-(</span>
<a name="line-14"></a> <span class='hs-varid'>ft_fmap</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span> <span class='hs-comment'>-- fmap f x = x</span>
<a name="line-15"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-varid'>f_Expr</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- fmap f x = f x</span>
<a name="line-16"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>g</span> <span class='hs-varid'>h</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mkSimpleLam</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>h</span> <span class='hs-varop'>=<<</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-varid'>x</span> <span class='hs-varop'>`fmap`</span> <span class='hs-varid'>g</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-17"></a> <span class='hs-comment'>-- fmap f x = \b -> h (x (g b))</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleTupleCase</span> <span class='hs-varid'>match_for_con</span> <span class='hs-comment'>-- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)</span>
<a name="line-19"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>gg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkSimpleLam</span> <span class='hs-varid'>g</span> <span class='hs-comment'>-- fmap f x = fmap g x</span>
<a name="line-20"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>fmap_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>gg</span><span class='hs-layout'>,</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>
<a name="line-21"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span>
<a name="line-22"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"in other argument"</span>
<a name="line-23"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"contravariant"</span> <span class='hs-layout'>}</span>
<a name="line-24"></a>
<a name="line-25"></a> <span class='hs-varid'>match_for_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleConMatch</span> <span class='hs-varop'>$</span>
<a name="line-26"></a> <span class='hs-keyglyph'>\</span><span class='hs-varid'>con_name</span> <span class='hs-varid'>xsM</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>sequence</span> <span class='hs-varid'>xsM</span>
<a name="line-27"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>con_name</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Con (g1 v1) (g2 v2) ..</span>
</pre>\end{code}
Utility functions related to Functor deriving.
Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
This function works like a fold: it makes a value of type 'a' in a bottom up way.
\begin{code}
<pre><a name="line-1"></a><a name="FFoldType"></a><span class='hs-comment'>-- Generic traversal for Functor deriving</span>
<a name="line-2"></a><a name="FFoldType"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>FFoldType</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Describes how to fold over a Type in a functor like way</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Does not contain variable</span>
<a name="line-4"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- The variable itself </span>
<a name="line-5"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- The variable itself, contravariantly </span>
<a name="line-6"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Function type</span>
<a name="line-7"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Boxity</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Tuple type </span>
<a name="line-8"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Type app, variable only in last argument </span>
<a name="line-9"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Type app, variable other than in last argument </span>
<a name="line-10"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TcTyVar</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- Forall type </span>
<a name="line-11"></a> <span class='hs-layout'>}</span>
<a name="line-12"></a>
<a name="line-13"></a><a name="functorLikeTraverse"></a><span class='hs-definition'>functorLikeTraverse</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyVar</span> <span class='hs-comment'>-- ^ Variable to look for</span>
<a name="line-14"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>FFoldType</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- ^ How to fold</span>
<a name="line-15"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- ^ Type to process</span>
<a name="line-16"></a> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span>
<a name="line-17"></a><span class='hs-definition'>functorLikeTraverse</span> <span class='hs-varid'>var</span> <span class='hs-layout'>(</span><span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseTrivial</span><span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseVar</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseCoVar</span><span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseFun</span>
<a name="line-19"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseTuple</span><span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseTyApp</span>
<a name="line-20"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseWrongArg</span><span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>caseForAll</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span>
<a name="line-21"></a> <span class='hs-varid'>ty</span>
<a name="line-22"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fst</span> <span class='hs-layout'>(</span><span class='hs-varid'>go</span> <span class='hs-conid'>False</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-keyword'>where</span> <span class='hs-comment'>-- go returns (result of type a, does type contain var)</span>
<a name="line-24"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>ty'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>coreView</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>ty'</span>
<a name="line-25"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>TyVarTy</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v</span> <span class='hs-varop'>==</span> <span class='hs-varid'>var</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>co</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>caseCoVar</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>caseVar</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-26"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>FunTy</span> <span class='hs-layout'>(</span><span class='hs-conid'>PredTy</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>b</span>
<a name="line-27"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>FunTy</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>xc</span> <span class='hs-varop'>||</span> <span class='hs-varid'>yc</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseFun</span> <span class='hs-varid'>xr</span> <span class='hs-varid'>yr</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-28"></a> <span class='hs-keyword'>where</span> <span class='hs-layout'>(</span><span class='hs-varid'>xr</span><span class='hs-layout'>,</span><span class='hs-varid'>xc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-varid'>not</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-varid'>x</span>
<a name="line-29"></a> <span class='hs-layout'>(</span><span class='hs-varid'>yr</span><span class='hs-layout'>,</span><span class='hs-varid'>yc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>y</span>
<a name="line-30"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>AppTy</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>xc</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseWrongArg</span><span class='hs-layout'>,</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-31"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>yc</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseTyApp</span> <span class='hs-varid'>x</span> <span class='hs-varid'>yr</span><span class='hs-layout'>,</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-keyword'>where</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>xc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>x</span>
<a name="line-33"></a> <span class='hs-layout'>(</span><span class='hs-varid'>yr</span><span class='hs-layout'>,</span><span class='hs-varid'>yc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>y</span>
<a name="line-34"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>ty</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>TyConApp</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-35"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTupleTyCon</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseTuple</span> <span class='hs-layout'>(</span><span class='hs-varid'>tupleTyConBoxity</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-varid'>xrs</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-36"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>args</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseTrivial</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- T</span>
<a name="line-37"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>or</span> <span class='hs-layout'>(</span><span class='hs-varid'>init</span> <span class='hs-varid'>xcs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseWrongArg</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- T (..var..) ty</span>
<a name="line-38"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>last</span> <span class='hs-varid'>xcs</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- T (..no var..) ty</span>
<a name="line-39"></a> <span class='hs-layout'>(</span><span class='hs-varid'>caseTyApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>fst</span> <span class='hs-layout'>(</span><span class='hs-varid'>splitAppTy</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>last</span> <span class='hs-varid'>xrs</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-40"></a> <span class='hs-keyword'>where</span> <span class='hs-layout'>(</span><span class='hs-varid'>xrs</span><span class='hs-layout'>,</span><span class='hs-varid'>xcs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>go</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-41"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-layout'>(</span><span class='hs-conid'>ForAllTy</span> <span class='hs-varid'>v</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v</span> <span class='hs-varop'>/=</span> <span class='hs-varid'>var</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>xc</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseForAll</span> <span class='hs-varid'>v</span> <span class='hs-varid'>xr</span><span class='hs-layout'>,</span><span class='hs-conid'>True</span><span class='hs-layout'>)</span>
<a name="line-42"></a> <span class='hs-keyword'>where</span> <span class='hs-layout'>(</span><span class='hs-varid'>xr</span><span class='hs-layout'>,</span><span class='hs-varid'>xc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>co</span> <span class='hs-varid'>x</span>
<a name="line-43"></a> <span class='hs-varid'>go</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>caseTrivial</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>)</span>
<a name="line-44"></a>
<a name="line-45"></a><a name="deepSubtypesContaining"></a><span class='hs-comment'>-- Return all syntactic subterms of ty that contain var somewhere</span>
<a name="line-46"></a><span class='hs-comment'>-- These are the things that should appear in instance constraints</span>
<a name="line-47"></a><span class='hs-definition'>deepSubtypesContaining</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyVar</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'>TcType</span><span class='hs-keyglyph'>]</span>
<a name="line-48"></a><span class='hs-definition'>deepSubtypesContaining</span> <span class='hs-varid'>tv</span>
<a name="line-49"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>functorLikeTraverse</span> <span class='hs-varid'>tv</span>
<a name="line-50"></a> <span class='hs-layout'>(</span><span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-51"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-52"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varop'>++</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>concat</span> <span class='hs-varid'>xs</span>
<a name="line-53"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conop'>:</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"in other argument"</span>
<a name="line-55"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"contravariant"</span>
<a name="line-56"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>v</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>filterOut</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span> <span class='hs-varop'>`elemVarSet`</span><span class='hs-layout'>)</span> <span class='hs-varop'>.</span> <span class='hs-varid'>tyVarsOfType</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span>
<a name="line-57"></a>
<a name="line-58"></a>
<a name="line-59"></a><a name="foldDataConArgs"></a><span class='hs-definition'>foldDataConArgs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FFoldType</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<a name="line-60"></a><span class='hs-comment'>-- Fold over the arguments of the datacon</span>
<a name="line-61"></a><span class='hs-definition'>foldDataConArgs</span> <span class='hs-varid'>ft</span> <span class='hs-varid'>con</span>
<a name="line-62"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>functorLikeTraverse</span> <span class='hs-varid'>tv</span> <span class='hs-varid'>ft</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConOrigArgTys</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-keyword'>where</span>
<a name="line-64"></a> <span class='hs-varid'>tv</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>last</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConUnivTyVars</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-comment'>-- Argument to derive for, 'a in the above description</span>
<a name="line-66"></a> <span class='hs-comment'>-- The validity checks have ensured that con is</span>
<a name="line-67"></a> <span class='hs-comment'>-- a vanilla data constructor</span>
<a name="line-68"></a>
<a name="line-69"></a><a name="mkSimpleLam"></a><span class='hs-comment'>-- Make a HsLam using a fresh variable from a State monad</span>
<a name="line-70"></a><span class='hs-definition'>mkSimpleLam</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>id</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>id</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span>
<a name="line-71"></a><span class='hs-comment'>-- (mkSimpleLam fn) returns (\x. fn(x))</span>
<a name="line-72"></a><span class='hs-definition'>mkSimpleLam</span> <span class='hs-varid'>lam</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-73"></a> <span class='hs-layout'>(</span><span class='hs-varid'>n</span><span class='hs-conop'>:</span><span class='hs-varid'>names</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>
<a name="line-74"></a> <span class='hs-varid'>put</span> <span class='hs-varid'>names</span>
<a name="line-75"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lam</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span>
<a name="line-76"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsLam</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>n</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-77"></a>
<a name="line-78"></a><a name="mkSimpleLam2"></a><span class='hs-definition'>mkSimpleLam2</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>id</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>id</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span>
<a name="line-79"></a><span class='hs-definition'>mkSimpleLam2</span> <span class='hs-varid'>lam</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-80"></a> <span class='hs-layout'>(</span><span class='hs-varid'>n1</span><span class='hs-conop'>:</span><span class='hs-varid'>n2</span><span class='hs-conop'>:</span><span class='hs-varid'>names</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>
<a name="line-81"></a> <span class='hs-varid'>put</span> <span class='hs-varid'>names</span>
<a name="line-82"></a> <span class='hs-varid'>body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lam</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>n1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>n2</span><span class='hs-layout'>)</span>
<a name="line-83"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsLam</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>n1</span><span class='hs-layout'>,</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>n2</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-84"></a>
<a name="line-85"></a><a name="mkSimpleConMatch"></a><span class='hs-comment'>-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"</span>
<a name="line-86"></a><span class='hs-definition'>mkSimpleConMatch</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-layout'>(</span><span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>LMatch</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span>
<a name="line-87"></a><span class='hs-definition'>mkSimpleConMatch</span> <span class='hs-varid'>fold</span> <span class='hs-varid'>extra_pats</span> <span class='hs-varid'>con</span> <span class='hs-varid'>insides</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-88"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>con_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>con</span>
<a name="line-89"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>vars_needed</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>takeList</span> <span class='hs-varid'>insides</span> <span class='hs-varid'>as_RDRs</span>
<a name="line-90"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>con_name</span> <span class='hs-varid'>vars_needed</span>
<a name="line-91"></a> <span class='hs-varid'>rhs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>fold</span> <span class='hs-varid'>con_name</span> <span class='hs-layout'>(</span><span class='hs-varid'>zipWith</span> <span class='hs-layout'>(</span><span class='hs-varop'>$</span><span class='hs-layout'>)</span> <span class='hs-varid'>insides</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>vars_needed</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-92"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkMatch</span> <span class='hs-layout'>(</span><span class='hs-varid'>extra_pats</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>pat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs</span> <span class='hs-varid'>emptyLocalBinds</span>
<a name="line-93"></a>
<a name="line-94"></a><a name="mkSimpleTupleCase"></a><span class='hs-comment'>-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"</span>
<a name="line-95"></a><span class='hs-definition'>mkSimpleTupleCase</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>LMatch</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-96"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Boxity</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span>
<a name="line-97"></a><span class='hs-definition'>mkSimpleTupleCase</span> <span class='hs-varid'>match_for_con</span> <span class='hs-varid'>boxity</span> <span class='hs-varid'>insides</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-98"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tupleCon</span> <span class='hs-varid'>boxity</span> <span class='hs-layout'>(</span><span class='hs-varid'>length</span> <span class='hs-varid'>insides</span><span class='hs-layout'>)</span>
<a name="line-99"></a> <span class='hs-varid'>match</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>match_for_con</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>con</span> <span class='hs-varid'>insides</span>
<a name="line-100"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>nlHsCase</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>match</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
%************************************************************************
%* *
Foldable instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
Deriving Foldable instances works the same way as Functor instances,
only Foldable instances are not possible for function types at all.
Here the derived instance for the type T above is:
instance Foldable T where
foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
The cases are:
$(foldr 'a 'b) x z = z -- when b does not contain a
$(foldr 'a 'a) x z = f x z
$(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
$(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
\begin{code}
<pre><a name="line-1"></a><a name="gen_Foldable_binds"></a><span class='hs-definition'>gen_Foldable_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Foldable_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitBag</span> <span class='hs-varid'>foldr_bind</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-keyword'>where</span>
<a name="line-5"></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-6"></a>
<a name="line-7"></a> <span class='hs-varid'>foldr_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkFunBind</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>foldable_foldr_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>foldr_eqn</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-varid'>foldr_eqn</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalState</span> <span class='hs-layout'>(</span><span class='hs-varid'>match_for_con</span> <span class='hs-varid'>z_Expr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>f_Pat</span><span class='hs-layout'>,</span><span class='hs-varid'>z_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>con</span> <span class='hs-varid'>parts</span><span class='hs-layout'>)</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>parts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldDataConArgs</span> <span class='hs-varid'>ft_foldr</span> <span class='hs-varid'>con</span>
<a name="line-11"></a>
<a name="line-12"></a> <span class='hs-varid'>ft_foldr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FFoldType</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-13"></a> <span class='hs-varid'>ft_foldr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>z</span> <span class='hs-comment'>-- foldr f z x = z</span>
<a name="line-14"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>f_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>z</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- foldr f z x = f x z</span>
<a name="line-15"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>b</span> <span class='hs-varid'>gs</span> <span class='hs-varid'>x</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mkSimpleTupleCase</span> <span class='hs-layout'>(</span><span class='hs-varid'>match_for_con</span> <span class='hs-varid'>z</span><span class='hs-layout'>)</span> <span class='hs-varid'>b</span> <span class='hs-varid'>gs</span> <span class='hs-varid'>x</span>
<a name="line-16"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>gg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkSimpleLam2</span> <span class='hs-varid'>g</span> <span class='hs-comment'>-- foldr f z x = foldr (\xx zz -> g xx zz) z x</span>
<a name="line-17"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>foldable_foldr_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>gg</span><span class='hs-layout'>,</span><span class='hs-varid'>z</span><span class='hs-layout'>,</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-varid'>z</span>
<a name="line-19"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"covariant"</span>
<a name="line-20"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"function"</span>
<a name="line-21"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"in other argument"</span> <span class='hs-layout'>}</span>
<a name="line-22"></a>
<a name="line-23"></a> <span class='hs-varid'>match_for_con</span> <span class='hs-varid'>z</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleConMatch</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-sel'>_con_name</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>foldrM</span> <span class='hs-layout'>(</span><span class='hs-varop'>$</span><span class='hs-layout'>)</span> <span class='hs-varid'>z</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- g1 v1 (g2 v2 (.. z))</span>
</pre>\end{code}
%************************************************************************
%* *
Traversable instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
Again, Traversable is much like Functor and Foldable.
The cases are:
$(traverse 'a 'b) x = pure x -- when b does not contain a
$(traverse 'a 'a) x = f x
$(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
$(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
Note that the generated code is not as efficient as it could be. For instance:
data T a = T Int a deriving Traversable
gives the function: traverse f (T x y) = T <$> pure x <*> f y
instead of: traverse f (T x y) = T x <$> f y
\begin{code}
<pre><a name="line-1"></a><a name="gen_Traversable_binds"></a><span class='hs-definition'>gen_Traversable_binds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsBinds</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>DerivAuxBinds</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>gen_Traversable_binds</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>tycon</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitBag</span> <span class='hs-varid'>traverse_bind</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-4"></a> <span class='hs-keyword'>where</span>
<a name="line-5"></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-6"></a>
<a name="line-7"></a> <span class='hs-varid'>traverse_bind</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mkFunBind</span> <span class='hs-layout'>(</span><span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>traverse_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>traverse_eqn</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-varid'>traverse_eqn</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalState</span> <span class='hs-layout'>(</span><span class='hs-varid'>match_for_con</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>f_Pat</span><span class='hs-keyglyph'>]</span> <span class='hs-varid'>con</span> <span class='hs-varid'>parts</span><span class='hs-layout'>)</span> <span class='hs-varid'>bs_RDRs</span>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>parts</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldDataConArgs</span> <span class='hs-varid'>ft_trav</span> <span class='hs-varid'>con</span>
<a name="line-11"></a>
<a name="line-12"></a>
<a name="line-13"></a> <span class='hs-varid'>ft_trav</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FFoldType</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>State</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>(</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-14"></a> <span class='hs-varid'>ft_trav</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>FT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>ft_triv</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>pure_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- traverse f x = pure x</span>
<a name="line-15"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>f_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- travese f x = f x</span>
<a name="line-16"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_tup</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleTupleCase</span> <span class='hs-varid'>match_for_con</span> <span class='hs-comment'>-- travese f x z = case x of (a1,a2,..) -> </span>
<a name="line-17"></a> <span class='hs-comment'>-- (,,) <$> g1 a1 <*> g2 a2 <*> ..</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_ty_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>gg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mkSimpleLam</span> <span class='hs-varid'>g</span> <span class='hs-comment'>-- travese f x = travese (\xx -> g xx) x</span>
<a name="line-19"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>traverse_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>gg</span><span class='hs-layout'>,</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>
<a name="line-20"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_forall</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>g</span> <span class='hs-varid'>x</span>
<a name="line-21"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"covariant"</span>
<a name="line-22"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"function"</span>
<a name="line-23"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ft_bad_app</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"in other argument"</span> <span class='hs-layout'>}</span>
<a name="line-24"></a>
<a name="line-25"></a> <span class='hs-varid'>match_for_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSimpleConMatch</span> <span class='hs-varop'>$</span>
<a name="line-26"></a> <span class='hs-keyglyph'>\</span><span class='hs-varid'>con_name</span> <span class='hs-varid'>xsM</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>sequence</span> <span class='hs-varid'>xsM</span>
<a name="line-27"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkApCon</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>con_name</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span>
<a name="line-28"></a>
<a name="line-29"></a> <span class='hs-comment'>-- ((Con <$> x1) <*> x2) <*> ..</span>
<a name="line-30"></a> <span class='hs-varid'>mkApCon</span> <span class='hs-varid'>con</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>pure_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con</span><span class='hs-keyglyph'>]</span>
<a name="line-31"></a> <span class='hs-varid'>mkApCon</span> <span class='hs-varid'>con</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-conop'>:</span><span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldl</span> <span class='hs-varid'>appAp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>fmap_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span>
<a name="line-32"></a> <span class='hs-keyword'>where</span> <span class='hs-varid'>appAp</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>ap_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-keyglyph'>]</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
%* *
%************************************************************************
\begin{verbatim}
data Foo ... = ...
con2tag_Foo :: Foo ... -> Int#
tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
maxtag_Foo :: Int -- ditto (NB: not unlifted)
\end{verbatim}
The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
<pre><a name="line-1"></a><a name="genAuxBind"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SrcSpan</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>DerivAuxBind</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsBind</span> <span class='hs-conid'>RdrName</span>
<a name="line-2"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenCon2Tag</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-3"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>lots_of_constructors</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>rdr_name</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>get_tag_rhs</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-5"></a>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>rdr_name</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>mk_stuff</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-8"></a>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>rdr_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>con2tag_RDR</span> <span class='hs-varid'>tycon</span>
<a name="line-11"></a>
<a name="line-12"></a> <span class='hs-varid'>tvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkRdrUnqual</span> <span class='hs-varop'>.</span> <span class='hs-varid'>getOccName</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConTyVars</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-13"></a> <span class='hs-comment'>-- We can't use gerRdrName because that makes an Exact RdrName</span>
<a name="line-14"></a> <span class='hs-comment'>-- and we can't put them in the LocalRdrEnv</span>
<a name="line-15"></a>
<a name="line-16"></a> <span class='hs-comment'>-- Give a signature to the bound variable, so </span>
<a name="line-17"></a> <span class='hs-comment'>-- that the case expression generated by getTag is</span>
<a name="line-18"></a> <span class='hs-comment'>-- monomorphic. In the push-enter model we get better code.</span>
<a name="line-19"></a> <span class='hs-varid'>get_tag_rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>L</span> <span class='hs-varid'>loc</span> <span class='hs-varop'>$</span> <span class='hs-conid'>ExprWithTySig</span>
<a name="line-20"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLam</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>a_RDR</span><span class='hs-layout'>)</span>
<a name="line-21"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>getTag_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>a_Expr</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-22"></a> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkExplicitHsForAllTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span><span class='hs-varop'>.</span><span class='hs-conid'>UserTyVar</span><span class='hs-layout'>)</span> <span class='hs-varid'>tvs</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>noLoc</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span> <span class='hs-varid'>con2tag_ty</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-23"></a>
<a name="line-24"></a> <span class='hs-varid'>con2tag_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsTyConApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>getRdrName</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>nlHsTyVar</span> <span class='hs-varid'>tvs</span><span class='hs-layout'>)</span>
<a name="line-25"></a> <span class='hs-varop'>`nlHsFunTy`</span>
<a name="line-26"></a> <span class='hs-varid'>nlHsTyVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>getRdrName</span> <span class='hs-varid'>intPrimTyCon</span><span class='hs-layout'>)</span>
<a name="line-27"></a>
<a name="line-28"></a> <span class='hs-varid'>lots_of_constructors</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tyConFamilySize</span> <span class='hs-varid'>tycon</span> <span class='hs-varop'>></span> <span class='hs-num'>8</span>
<a name="line-29"></a> <span class='hs-comment'>-- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS</span>
<a name="line-30"></a> <span class='hs-comment'>-- but we don't do vectored returns any more.</span>
<a name="line-31"></a>
<a name="line-32"></a> <span class='hs-varid'>mk_stuff</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>LPat</span> <span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-varid'>mk_stuff</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlWildConPat</span> <span class='hs-varid'>con</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-34"></a> <span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsIntPrim</span> <span class='hs-layout'>(</span><span class='hs-varid'>toInteger</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>dataConTag</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-comment'>-</span> <span class='hs-varid'>fIRST_TAG</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-35"></a>
<a name="line-36"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenTag2Con</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-37"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_FunBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>rdr_name</span>
<a name="line-38"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>nlConVarPat</span> <span class='hs-varid'>intDataCon_RDR</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a_RDR</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-39"></a> <span class='hs-varid'>noLoc</span> <span class='hs-layout'>(</span><span class='hs-conid'>ExprWithTySig</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>tagToEnum_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>a_Expr</span><span class='hs-layout'>)</span>
<a name="line-40"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsTyVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>getRdrName</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-41"></a> <span class='hs-keyword'>where</span>
<a name="line-42"></a> <span class='hs-varid'>rdr_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tag2con_RDR</span> <span class='hs-varid'>tycon</span>
<a name="line-43"></a>
<a name="line-44"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>GenMaxTag</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-45"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-varid'>rdr_name</span>
<a name="line-46"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>intDataCon_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-conid'>HsIntPrim</span> <span class='hs-varid'>max_tag</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-47"></a> <span class='hs-keyword'>where</span>
<a name="line-48"></a> <span class='hs-varid'>rdr_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maxtag_RDR</span> <span class='hs-varid'>tycon</span>
<a name="line-49"></a> <span class='hs-varid'>max_tag</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-50"></a> <span class='hs-varid'>data_cons</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>toInteger</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>length</span> <span class='hs-varid'>data_cons</span><span class='hs-layout'>)</span> <span class='hs-comment'>-</span> <span class='hs-varid'>fIRST_TAG</span><span class='hs-layout'>)</span>
<a name="line-51"></a>
<a name="line-52"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkTyCon</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- $dT</span>
<a name="line-53"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_data_type_name</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-layout'>(</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>mkDataType_RDR</span>
<a name="line-55"></a> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-varid'>showSDocOneLine</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-56"></a> <span class='hs-varop'>`nlHsApp`</span> <span class='hs-varid'>nlList</span> <span class='hs-varid'>constrs</span> <span class='hs-layout'>)</span>
<a name="line-57"></a> <span class='hs-keyword'>where</span>
<a name="line-58"></a> <span class='hs-varid'>constrs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_constr_name</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tyConDataCons</span> <span class='hs-varid'>tycon</span><span class='hs-keyglyph'>]</span>
<a name="line-59"></a>
<a name="line-60"></a><span class='hs-definition'>genAuxBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-conid'>MkDataCon</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- $cT1 etc</span>
<a name="line-61"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarBind</span> <span class='hs-varid'>loc</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_constr_name</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span>
<a name="line-62"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApps</span> <span class='hs-varid'>mkConstr_RDR</span> <span class='hs-varid'>constr_args</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-keyword'>where</span>
<a name="line-64"></a> <span class='hs-varid'>constr_args</span>
<a name="line-65"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-comment'>-- nlHsIntLit (toInteger (dataConTag dc)), -- Tag</span>
<a name="line-66"></a> <span class='hs-varid'>nlHsVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>mk_data_type_name</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConTyCon</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- DataType</span>
<a name="line-67"></a> <span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-varid'>occNameString</span> <span class='hs-varid'>dc_occ</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- String name</span>
<a name="line-68"></a> <span class='hs-varid'>nlList</span> <span class='hs-varid'>labels</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Field labels</span>
<a name="line-69"></a> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>fixity</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Fixity</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-varid'>labels</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-varop'>.</span> <span class='hs-varid'>mkHsString</span> <span class='hs-varop'>.</span> <span class='hs-varid'>getOccString</span><span class='hs-layout'>)</span>
<a name="line-72"></a> <span class='hs-layout'>(</span><span class='hs-varid'>dataConFieldLabels</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span>
<a name="line-73"></a> <span class='hs-varid'>dc_occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getOccName</span> <span class='hs-varid'>dc</span>
<a name="line-74"></a> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isDataSymOcc</span> <span class='hs-varid'>dc_occ</span>
<a name="line-75"></a> <span class='hs-varid'>fixity</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>is_infix</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>infix_RDR</span>
<a name="line-76"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>prefix_RDR</span>
<a name="line-77"></a>
<a name="line-78"></a><a name="mk_data_type_name"></a><span class='hs-definition'>mk_data_type_name</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- "$tT"</span>
<a name="line-79"></a><span class='hs-definition'>mk_data_type_name</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkAuxBinderName</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConName</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-varid'>mkDataTOcc</span>
<a name="line-80"></a>
<a name="line-81"></a><a name="mk_constr_name"></a><span class='hs-definition'>mk_constr_name</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DataCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- "$cC"</span>
<a name="line-82"></a><span class='hs-definition'>mk_constr_name</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkAuxBinderName</span> <span class='hs-layout'>(</span><span class='hs-varid'>dataConName</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-varid'>mkDataCOcc</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Utility bits for generating bindings}
%* *
%************************************************************************
ToDo: Better SrcLocs.
\begin{code}
<pre><a name="line-1"></a><a name="compare_gen_Case"></a><span class='hs-definition'>compare_gen_Case</span> <span class='hs-keyglyph'>::</span>
<a name="line-2"></a> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- What to do for equality</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-5"></a><a name="careful_compare_Case"></a><span class='hs-definition'>careful_compare_Case</span> <span class='hs-keyglyph'>::</span> <span class='hs-comment'>-- checks for primitive types...</span>
<a name="line-6"></a> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- The tycon we are deriving for</span>
<a name="line-7"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-8"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- What to do for equality</span>
<a name="line-9"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-10"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-11"></a>
<a name="line-12"></a><a name="cmp_eq_Expr"></a><span class='hs-definition'>cmp_eq_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-13"></a><span class='hs-definition'>cmp_eq_Expr</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>cmp_eq_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varid'>b</span>
<a name="line-14"></a> <span class='hs-comment'>-- Was: compare_gen_Case cmp_eq_RDR</span>
<a name="line-15"></a>
<a name="line-16"></a><span class='hs-definition'>compare_gen_Case</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'>HsVar</span> <span class='hs-varid'>eq_tag</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>eq_tag</span> <span class='hs-varop'>==</span> <span class='hs-varid'>eqTag_RDR</span>
<a name="line-17"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>compare_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varid'>b</span> <span class='hs-comment'>-- Simple case </span>
<a name="line-18"></a><span class='hs-definition'>compare_gen_Case</span> <span class='hs-varid'>eq</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-comment'>-- General case</span>
<a name="line-19"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsCase</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>compare_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-comment'>{-of-}</span>
<a name="line-20"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlNullaryConPat</span> <span class='hs-varid'>ltTag_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>ltTag_Expr</span><span class='hs-layout'>,</span>
<a name="line-21"></a> <span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlNullaryConPat</span> <span class='hs-varid'>eqTag_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>eq</span><span class='hs-layout'>,</span>
<a name="line-22"></a> <span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlNullaryConPat</span> <span class='hs-varid'>gtTag_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>gtTag_Expr</span><span class='hs-keyglyph'>]</span>
<a name="line-23"></a>
<a name="line-24"></a><span class='hs-definition'>careful_compare_Case</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>eq</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span>
<a name="line-25"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isUnLiftedType</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-26"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>compare_gen_Case</span> <span class='hs-varid'>eq</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span>
<a name="line-27"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- We have to do something special for primitive things...</span>
<a name="line-28"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a</span> <span class='hs-varid'>relevant_lt_op</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Test (<) first, not (==), becuase the latter</span>
<a name="line-29"></a> <span class='hs-varid'>ltTag_Expr</span> <span class='hs-comment'>-- is true less often, so putting it first would</span>
<a name="line-30"></a> <span class='hs-comment'>-- mean more tests (dynamically)</span>
<a name="line-31"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a</span> <span class='hs-varid'>relevant_eq_op</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-varid'>eq</span> <span class='hs-varid'>gtTag_Expr</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-keyword'>where</span>
<a name="line-33"></a> <span class='hs-varid'>relevant_eq_op</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-layout'>(</span><span class='hs-varid'>assoc_ty_id</span> <span class='hs-str'>"Ord"</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>eq_op_tbl</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-varid'>relevant_lt_op</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-layout'>(</span><span class='hs-varid'>assoc_ty_id</span> <span class='hs-str'>"Ord"</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>lt_op_tbl</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-35"></a>
<a name="line-36"></a>
<a name="line-37"></a><a name="box_if_necy"></a><span class='hs-definition'>box_if_necy</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- The class involved</span>
<a name="line-38"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- The tycon involved</span>
<a name="line-39"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- The argument</span>
<a name="line-40"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- The argument type</span>
<a name="line-41"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- Boxed version of the arg</span>
<a name="line-42"></a><span class='hs-definition'>box_if_necy</span> <span class='hs-varid'>cls_str</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arg_ty</span>
<a name="line-43"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isUnLiftedType</span> <span class='hs-varid'>arg_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>box_con</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg</span>
<a name="line-44"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>arg</span>
<a name="line-45"></a> <span class='hs-keyword'>where</span>
<a name="line-46"></a> <span class='hs-varid'>box_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>assoc_ty_id</span> <span class='hs-varid'>cls_str</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>box_con_tbl</span> <span class='hs-varid'>arg_ty</span>
<a name="line-47"></a>
<a name="line-48"></a><a name="assoc_ty_id"></a><span class='hs-definition'>assoc_ty_id</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- The class involved</span>
<a name="line-49"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>TyCon</span> <span class='hs-comment'>-- The tycon involved</span>
<a name="line-50"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Type</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-comment'>-- The table</span>
<a name="line-51"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- The type</span>
<a name="line-52"></a> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- The result of the lookup</span>
<a name="line-53"></a><span class='hs-definition'>assoc_ty_id</span> <span class='hs-varid'>cls_str</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>tbl</span> <span class='hs-varid'>ty</span>
<a name="line-54"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>res</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pprPanic</span> <span class='hs-str'>"Error in deriving:"</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"Can't derive"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>cls_str</span> <span class='hs-varop'><+></span>
<a name="line-55"></a> <span class='hs-varid'>text</span> <span class='hs-str'>"for primitive type"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-56"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>head</span> <span class='hs-varid'>res</span>
<a name="line-57"></a> <span class='hs-keyword'>where</span>
<a name="line-58"></a> <span class='hs-varid'>res</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>id</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>ty'</span><span class='hs-layout'>,</span><span class='hs-varid'>id</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tbl</span><span class='hs-layout'>,</span> <span class='hs-varid'>ty</span> <span class='hs-varop'>`tcEqType`</span> <span class='hs-varid'>ty'</span><span class='hs-keyglyph'>]</span>
<a name="line-59"></a>
<a name="line-60"></a><a name="eq_op_tbl"></a><span class='hs-definition'>eq_op_tbl</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Type</span><span class='hs-layout'>,</span> <span class='hs-conid'>PrimOp</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-61"></a><span class='hs-definition'>eq_op_tbl</span> <span class='hs-keyglyph'>=</span>
<a name="line-62"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>charPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>CharEqOp</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>intPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>IntEqOp</span><span class='hs-layout'>)</span>
<a name="line-64"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>wordPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>WordEqOp</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>addrPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>AddrEqOp</span><span class='hs-layout'>)</span>
<a name="line-66"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>floatPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>FloatEqOp</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>doublePrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>DoubleEqOp</span><span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-keyglyph'>]</span>
<a name="line-69"></a>
<a name="line-70"></a><a name="lt_op_tbl"></a><span class='hs-definition'>lt_op_tbl</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Type</span><span class='hs-layout'>,</span> <span class='hs-conid'>PrimOp</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-71"></a><span class='hs-definition'>lt_op_tbl</span> <span class='hs-keyglyph'>=</span>
<a name="line-72"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>charPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>CharLtOp</span><span class='hs-layout'>)</span>
<a name="line-73"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>intPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>IntLtOp</span><span class='hs-layout'>)</span>
<a name="line-74"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>wordPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>WordLtOp</span><span class='hs-layout'>)</span>
<a name="line-75"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>addrPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>AddrLtOp</span><span class='hs-layout'>)</span>
<a name="line-76"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>floatPrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>FloatLtOp</span><span class='hs-layout'>)</span>
<a name="line-77"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>doublePrimTy</span><span class='hs-layout'>,</span> <span class='hs-conid'>DoubleLtOp</span><span class='hs-layout'>)</span>
<a name="line-78"></a> <span class='hs-keyglyph'>]</span>
<a name="line-79"></a>
<a name="line-80"></a><a name="box_con_tbl"></a><span class='hs-definition'>box_con_tbl</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Type</span><span class='hs-layout'>,</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-81"></a><span class='hs-definition'>box_con_tbl</span> <span class='hs-keyglyph'>=</span>
<a name="line-82"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>charPrimTy</span><span class='hs-layout'>,</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>charDataCon</span><span class='hs-layout'>)</span>
<a name="line-83"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>intPrimTy</span><span class='hs-layout'>,</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>intDataCon</span><span class='hs-layout'>)</span>
<a name="line-84"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>wordPrimTy</span><span class='hs-layout'>,</span> <span class='hs-varid'>wordDataCon_RDR</span><span class='hs-layout'>)</span>
<a name="line-85"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>floatPrimTy</span><span class='hs-layout'>,</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>floatDataCon</span><span class='hs-layout'>)</span>
<a name="line-86"></a> <span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varid'>doublePrimTy</span><span class='hs-layout'>,</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>doubleDataCon</span><span class='hs-layout'>)</span>
<a name="line-87"></a> <span class='hs-keyglyph'>]</span>
<a name="line-88"></a>
<a name="line-89"></a><span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-90"></a>
<a name="line-91"></a><a name="and_Expr"></a><span class='hs-definition'>and_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-92"></a><span class='hs-definition'>and_Expr</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a</span> <span class='hs-varid'>and_RDR</span> <span class='hs-varid'>b</span>
<a name="line-93"></a>
<a name="line-94"></a><span class='hs-comment'>-----------------------------------------------------------------------</span>
<a name="line-95"></a>
<a name="line-96"></a><a name="eq_Expr"></a><span class='hs-definition'>eq_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-97"></a><span class='hs-definition'>eq_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>genOpApp</span> <span class='hs-varid'>a</span> <span class='hs-varid'>eq_op</span> <span class='hs-varid'>b</span>
<a name="line-98"></a> <span class='hs-keyword'>where</span>
<a name="line-99"></a> <span class='hs-varid'>eq_op</span>
<a name="line-100"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isUnLiftedType</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eq_RDR</span>
<a name="line-101"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-layout'>(</span><span class='hs-varid'>assoc_ty_id</span> <span class='hs-str'>"Eq"</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>eq_op_tbl</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-102"></a> <span class='hs-comment'>-- we have to do something special for primitive things...</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="untag_Expr"></a><span class='hs-definition'>untag_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>,</span> <span class='hs-conid'>RdrName</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-2"></a><span class='hs-definition'>untag_Expr</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>expr</span>
<a name="line-3"></a><span class='hs-definition'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>untag_this</span><span class='hs-layout'>,</span> <span class='hs-varid'>put_tag_here</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>more</span><span class='hs-layout'>)</span> <span class='hs-varid'>expr</span>
<a name="line-4"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsCase</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVarApps</span> <span class='hs-layout'>(</span><span class='hs-varid'>con2tag_RDR</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>untag_this</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-comment'>{-of-}</span>
<a name="line-5"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>mkSimpleHsAlt</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>put_tag_here</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>untag_Expr</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>more</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-6"></a>
<a name="line-7"></a><a name="cmp_tags_Expr"></a><span class='hs-definition'>cmp_tags_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- Comparison op</span>
<a name="line-8"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- Things to compare</span>
<a name="line-9"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- What to return if true</span>
<a name="line-10"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-comment'>-- What to return if false</span>
<a name="line-11"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-definition'>cmp_tags_Expr</span> <span class='hs-varid'>op</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span> <span class='hs-varid'>true_case</span> <span class='hs-varid'>false_case</span>
<a name="line-14"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsIf</span> <span class='hs-layout'>(</span><span class='hs-varid'>genOpApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varid'>op</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>true_case</span> <span class='hs-varid'>false_case</span>
<a name="line-15"></a>
<a name="line-16"></a><a name="enum_from_to_Expr"></a><span class='hs-definition'>enum_from_to_Expr</span>
<a name="line-17"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-18"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-19"></a><a name="enum_from_then_to_Expr"></a><span class='hs-definition'>enum_from_then_to_Expr</span>
<a name="line-20"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-21"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-22"></a>
<a name="line-23"></a><span class='hs-definition'>enum_from_to_Expr</span> <span class='hs-varid'>f</span> <span class='hs-varid'>t2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>enumFromTo_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varid'>t2</span>
<a name="line-24"></a><span class='hs-definition'>enum_from_then_to_Expr</span> <span class='hs-varid'>f</span> <span class='hs-varid'>t</span> <span class='hs-varid'>t2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>enumFromThenTo_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span> <span class='hs-varid'>t2</span>
<a name="line-25"></a>
<a name="line-26"></a><a name="showParen_Expr"></a><span class='hs-definition'>showParen_Expr</span>
<a name="line-27"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-28"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-29"></a>
<a name="line-30"></a><span class='hs-definition'>showParen_Expr</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showParen_RDR</span><span class='hs-layout'>)</span> <span class='hs-varid'>e1</span><span class='hs-layout'>)</span> <span class='hs-varid'>e2</span>
<a name="line-31"></a>
<a name="line-32"></a><a name="nested_compose_Expr"></a><span class='hs-definition'>nested_compose_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-33"></a>
<a name="line-34"></a><span class='hs-definition'>nested_compose_Expr</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"nested_compose_expr"</span> <span class='hs-comment'>-- Arg is always non-empty</span>
<a name="line-35"></a><span class='hs-definition'>nested_compose_Expr</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>e</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>parenify</span> <span class='hs-varid'>e</span>
<a name="line-36"></a><span class='hs-definition'>nested_compose_Expr</span> <span class='hs-layout'>(</span><span class='hs-varid'>e</span><span class='hs-conop'>:</span><span class='hs-varid'>es</span><span class='hs-layout'>)</span>
<a name="line-37"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>compose_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>parenify</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nested_compose_Expr</span> <span class='hs-varid'>es</span><span class='hs-layout'>)</span>
<a name="line-38"></a>
<a name="line-39"></a><a name="impossible_Expr"></a><span class='hs-comment'>-- impossible_Expr is used in case RHSs that should never happen.</span>
<a name="line-40"></a><span class='hs-comment'>-- We generate these to keep the desugarer from complaining that they *might* happen!</span>
<a name="line-41"></a><span class='hs-definition'>impossible_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-42"></a><span class='hs-definition'>impossible_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>error_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-str'>"Urk! in TcGenDeriv"</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-43"></a>
<a name="line-44"></a><a name="illegal_Expr"></a><span class='hs-comment'>-- illegal_Expr is used when signalling error conditions in the RHS of a derived</span>
<a name="line-45"></a><span class='hs-comment'>-- method. It is currently only used by Enum.{succ,pred}</span>
<a name="line-46"></a><span class='hs-definition'>illegal_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-47"></a><span class='hs-definition'>illegal_Expr</span> <span class='hs-varid'>meth</span> <span class='hs-varid'>tp</span> <span class='hs-varid'>msg</span> <span class='hs-keyglyph'>=</span>
<a name="line-48"></a> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>error_RDR</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-varid'>meth</span> <span class='hs-varop'>++</span> <span class='hs-chr'>'{'</span><span class='hs-conop'>:</span><span class='hs-varid'>tp</span> <span class='hs-varop'>++</span> <span class='hs-str'>"}: "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>msg</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-49"></a>
<a name="line-50"></a><a name="illegal_toEnum_tag"></a><span class='hs-comment'>-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you</span>
<a name="line-51"></a><span class='hs-comment'>-- to include the value of a_RDR in the error string.</span>
<a name="line-52"></a><span class='hs-definition'>illegal_toEnum_tag</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-53"></a><span class='hs-definition'>illegal_toEnum_tag</span> <span class='hs-varid'>tp</span> <span class='hs-varid'>maxtag</span> <span class='hs-keyglyph'>=</span>
<a name="line-54"></a> <span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>error_RDR</span><span class='hs-layout'>)</span>
<a name="line-55"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>append_RDR</span><span class='hs-layout'>)</span>
<a name="line-56"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-layout'>(</span><span class='hs-str'>"toEnum{"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>tp</span> <span class='hs-varop'>++</span> <span class='hs-str'>"}: tag ("</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-57"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span>
<a name="line-58"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showsPrec_RDR</span><span class='hs-layout'>)</span>
<a name="line-59"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a_RDR</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-61"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span>
<a name="line-62"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>append_RDR</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-str'>") is outside of enumeration's range (0,"</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-64"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsApp</span>
<a name="line-65"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>showsPrec_RDR</span><span class='hs-layout'>)</span>
<a name="line-66"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsIntLit</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>maxtag</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsLit</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkHsString</span> <span class='hs-str'>")"</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-69"></a>
<a name="line-70"></a><a name="parenify"></a><span class='hs-definition'>parenify</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-71"></a><span class='hs-definition'>parenify</span> <span class='hs-varid'>e</span><span class='hs-keyglyph'>@</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'>HsVar</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>e</span>
<a name="line-72"></a><span class='hs-definition'>parenify</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkHsPar</span> <span class='hs-varid'>e</span>
<a name="line-73"></a>
<a name="line-74"></a><a name="genOpApp"></a><span class='hs-comment'>-- genOpApp wraps brackets round the operator application, so that the</span>
<a name="line-75"></a><span class='hs-comment'>-- renamer won't subsequently try to re-associate it. </span>
<a name="line-76"></a><span class='hs-definition'>genOpApp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-77"></a><span class='hs-definition'>genOpApp</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>op</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsPar</span> <span class='hs-layout'>(</span><span class='hs-varid'>nlHsOpApp</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>op</span> <span class='hs-varid'>e2</span><span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="a_RDR"></a><span class='hs-definition'>a_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>c_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>d_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>f_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>k_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>z_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ah_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>bh_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ch_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>dh_RDR</span><span class='hs-layout'>,</span>
<a name="line-2"></a> <span class='hs-varid'>cmp_eq_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span>
<a name="line-3"></a><span class='hs-definition'>a_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"a"</span><span class='hs-layout'>)</span>
<a name="line-4"></a><a name="b_RDR"></a><span class='hs-definition'>b_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"b"</span><span class='hs-layout'>)</span>
<a name="line-5"></a><a name="c_RDR"></a><span class='hs-definition'>c_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"c"</span><span class='hs-layout'>)</span>
<a name="line-6"></a><a name="d_RDR"></a><span class='hs-definition'>d_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"d"</span><span class='hs-layout'>)</span>
<a name="line-7"></a><a name="f_RDR"></a><span class='hs-definition'>f_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"f"</span><span class='hs-layout'>)</span>
<a name="line-8"></a><a name="k_RDR"></a><span class='hs-definition'>k_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"k"</span><span class='hs-layout'>)</span>
<a name="line-9"></a><a name="z_RDR"></a><span class='hs-definition'>z_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"z"</span><span class='hs-layout'>)</span>
<a name="line-10"></a><a name="ah_RDR"></a><span class='hs-definition'>ah_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"a#"</span><span class='hs-layout'>)</span>
<a name="line-11"></a><a name="bh_RDR"></a><span class='hs-definition'>bh_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"b#"</span><span class='hs-layout'>)</span>
<a name="line-12"></a><a name="ch_RDR"></a><span class='hs-definition'>ch_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"c#"</span><span class='hs-layout'>)</span>
<a name="line-13"></a><a name="dh_RDR"></a><span class='hs-definition'>dh_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"d#"</span><span class='hs-layout'>)</span>
<a name="line-14"></a><a name="cmp_eq_RDR"></a><span class='hs-definition'>cmp_eq_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"cmp_eq"</span><span class='hs-layout'>)</span>
<a name="line-15"></a>
<a name="line-16"></a><a name="as_RDRs"></a><span class='hs-definition'>as_RDRs</span><span class='hs-layout'>,</span> <span class='hs-varid'>bs_RDRs</span><span class='hs-layout'>,</span> <span class='hs-varid'>cs_RDRs</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RdrName</span><span class='hs-keyglyph'>]</span>
<a name="line-17"></a><span class='hs-definition'>as_RDRs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-layout'>(</span><span class='hs-str'>"a"</span><span class='hs-varop'>++</span><span class='hs-varid'>show</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-num'>1</span><span class='hs-keyglyph'>::</span><span class='hs-conid'>Int</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>..</span> <span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>]</span>
<a name="line-18"></a><a name="bs_RDRs"></a><span class='hs-definition'>bs_RDRs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-layout'>(</span><span class='hs-str'>"b"</span><span class='hs-varop'>++</span><span class='hs-varid'>show</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-num'>1</span><span class='hs-keyglyph'>::</span><span class='hs-conid'>Int</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>..</span> <span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>]</span>
<a name="line-19"></a><a name="cs_RDRs"></a><span class='hs-definition'>cs_RDRs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>mkVarUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-layout'>(</span><span class='hs-str'>"c"</span><span class='hs-varop'>++</span><span class='hs-varid'>show</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-num'>1</span><span class='hs-keyglyph'>::</span><span class='hs-conid'>Int</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>..</span> <span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>]</span>
<a name="line-20"></a>
<a name="line-21"></a><a name="a_Expr"></a><span class='hs-definition'>a_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>c_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>f_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>z_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>ltTag_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqTag_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>gtTag_Expr</span><span class='hs-layout'>,</span>
<a name="line-22"></a> <span class='hs-varid'>false_Expr</span><span class='hs-layout'>,</span> <span class='hs-varid'>true_Expr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LHsExpr</span> <span class='hs-conid'>RdrName</span>
<a name="line-23"></a><span class='hs-definition'>a_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>a_RDR</span>
<a name="line-24"></a><a name="b_Expr"></a><span class='hs-definition'>b_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>b_RDR</span>
<a name="line-25"></a><a name="c_Expr"></a><span class='hs-definition'>c_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>c_RDR</span>
<a name="line-26"></a><a name="f_Expr"></a><span class='hs-definition'>f_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>f_RDR</span>
<a name="line-27"></a><a name="z_Expr"></a><span class='hs-definition'>z_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>z_RDR</span>
<a name="line-28"></a><a name="ltTag_Expr"></a><span class='hs-definition'>ltTag_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>ltTag_RDR</span>
<a name="line-29"></a><a name="eqTag_Expr"></a><span class='hs-definition'>eqTag_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>eqTag_RDR</span>
<a name="line-30"></a><a name="gtTag_Expr"></a><span class='hs-definition'>gtTag_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>gtTag_RDR</span>
<a name="line-31"></a><a name="false_Expr"></a><span class='hs-definition'>false_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>false_RDR</span>
<a name="line-32"></a><a name="true_Expr"></a><span class='hs-definition'>true_Expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlHsVar</span> <span class='hs-varid'>true_RDR</span>
<a name="line-33"></a>
<a name="line-34"></a><a name="a_Pat"></a><span class='hs-definition'>a_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>c_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>d_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>f_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>k_Pat</span><span class='hs-layout'>,</span> <span class='hs-varid'>z_Pat</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LPat</span> <span class='hs-conid'>RdrName</span>
<a name="line-35"></a><span class='hs-definition'>a_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>a_RDR</span>
<a name="line-36"></a><a name="b_Pat"></a><span class='hs-definition'>b_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>b_RDR</span>
<a name="line-37"></a><a name="c_Pat"></a><span class='hs-definition'>c_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>c_RDR</span>
<a name="line-38"></a><a name="d_Pat"></a><span class='hs-definition'>d_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>d_RDR</span>
<a name="line-39"></a><a name="f_Pat"></a><span class='hs-definition'>f_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>f_RDR</span>
<a name="line-40"></a><a name="k_Pat"></a><span class='hs-definition'>k_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>k_RDR</span>
<a name="line-41"></a><a name="z_Pat"></a><span class='hs-definition'>z_Pat</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nlVarPat</span> <span class='hs-varid'>z_RDR</span>
<a name="line-42"></a>
<a name="line-43"></a><a name="con2tag_RDR"></a><span class='hs-definition'>con2tag_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>tag2con_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>maxtag_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span>
<a name="line-44"></a><span class='hs-comment'>-- Generates Orig s RdrName, for the binding positions</span>
<a name="line-45"></a><span class='hs-definition'>con2tag_RDR</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_tc_deriv_name</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>mkCon2TagOcc</span>
<a name="line-46"></a><a name="tag2con_RDR"></a><span class='hs-definition'>tag2con_RDR</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_tc_deriv_name</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>mkTag2ConOcc</span>
<a name="line-47"></a><a name="maxtag_RDR"></a><span class='hs-definition'>maxtag_RDR</span> <span class='hs-varid'>tycon</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mk_tc_deriv_name</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>mkMaxTagOcc</span>
<a name="line-48"></a>
<a name="line-49"></a><a name="mk_tc_deriv_name"></a><span class='hs-definition'>mk_tc_deriv_name</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TyCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>OccName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OccName</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span>
<a name="line-50"></a><span class='hs-definition'>mk_tc_deriv_name</span> <span class='hs-varid'>tycon</span> <span class='hs-varid'>occ_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkAuxBinderName</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConName</span> <span class='hs-varid'>tycon</span><span class='hs-layout'>)</span> <span class='hs-varid'>occ_fun</span>
<a name="line-51"></a>
<a name="line-52"></a><a name="mkAuxBinderName"></a><span class='hs-definition'>mkAuxBinderName</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Name</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>OccName</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OccName</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span>
<a name="line-53"></a><span class='hs-definition'>mkAuxBinderName</span> <span class='hs-varid'>parent</span> <span class='hs-varid'>occ_fun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkRdrUnqual</span> <span class='hs-layout'>(</span><span class='hs-varid'>occ_fun</span> <span class='hs-layout'>(</span><span class='hs-varid'>nameOccName</span> <span class='hs-varid'>parent</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-54"></a><span class='hs-comment'>-- Was: mkDerivedRdrName name occ_fun, which made an original name</span>
<a name="line-55"></a><span class='hs-comment'>-- But: (a) that does not work well for standalone-deriving</span>
<a name="line-56"></a><span class='hs-comment'>-- (b) an unqualified name is just fine, provided it can't clash with user code</span>
</pre>\end{code}
s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
PrelNames, so PrelNames can't import PrimOp.
\begin{code}
<pre><a name="line-1"></a><a name="primOpRdrName"></a><span class='hs-definition'>primOpRdrName</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>PrimOp</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RdrName</span>
<a name="line-2"></a><span class='hs-definition'>primOpRdrName</span> <span class='hs-varid'>op</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-layout'>(</span><span class='hs-varid'>primOpId</span> <span class='hs-varid'>op</span><span class='hs-layout'>)</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="minusInt_RDR"></a><span class='hs-definition'>minusInt_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>eqInt_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>ltInt_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>geInt_RDR</span><span class='hs-layout'>,</span> <span class='hs-varid'>leInt_RDR</span><span class='hs-layout'>,</span>
<a name="line-5"></a> <span class='hs-varid'>tagToEnum_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span>
<a name="line-6"></a><span class='hs-definition'>minusInt_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>IntSubOp</span>
<a name="line-7"></a><a name="eqInt_RDR"></a><span class='hs-definition'>eqInt_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>IntEqOp</span>
<a name="line-8"></a><a name="ltInt_RDR"></a><span class='hs-definition'>ltInt_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>IntLtOp</span>
<a name="line-9"></a><a name="geInt_RDR"></a><span class='hs-definition'>geInt_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>IntGeOp</span>
<a name="line-10"></a><a name="leInt_RDR"></a><span class='hs-definition'>leInt_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>IntLeOp</span>
<a name="line-11"></a><a name="tagToEnum_RDR"></a><span class='hs-definition'>tagToEnum_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>primOpRdrName</span> <span class='hs-conid'>TagToEnumOp</span>
<a name="line-12"></a>
<a name="line-13"></a><a name="error_RDR"></a><span class='hs-definition'>error_RDR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RdrName</span>
<a name="line-14"></a><span class='hs-definition'>error_RDR</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>getRdrName</span> <span class='hs-varid'>eRROR_ID</span>
</pre>\end{code}
</body>
</html>
