HappstackJeremy Shaw2013-01-11T22:28:45Zurn:uuid:fa6cf090-84d7-11e1-8001-0021cc712949Comparison of 4 approaches to implementing URL routing combinators including the free and operational monadsurn:uuid:6876bff7-41a3-4c41-b5c3-12b8c092964astepcut2013-01-11T22:28:45Z<p>There has been a lot of discussion recently about free (and operational) monads. And
perhaps you know <em>what</em> a free monad is. But you may still be confused
as to <em>when</em> or <em>why</em>.</p>
<p>You might wonder if the free and operational monads actually solve any
useful problems in the real world, or if they are just theoretical
wanking.</p>
<p>In this post I will show how we can rewrite the routing combinators in
Happstack to use the <code>Free</code> and <code>operational</code> monads and in the
process solve a couple real world problems.</p>
<p><code>Happstack</code> is a Haskell web programming toolkit. There are two url
routing systems you can use in <code>Happstack</code>. <code>web-routes</code> provides a
flexible system for type-safe URL routing. But we also have an older
system that works around simple string based combinators. In this
post, we are going to look into improvements we can make to the
simple, combinator based approach.</p>
<p>To provide basic url routing you need three things:</p>
<ol>
<li><code>match</code> - a way to match on a static path segment.</li>
<li><code>capture</code> - a way to capture a path segment and try to decode it.</li>
<li><code>choice</code> - a way to pick from multiple alternatives.</li>
</ol>
<p><code>match</code> and <code>capture</code> work on entire path segments. If we have a url like:</p>
<pre><code>/foo/bar/baz
</code></pre>
<p>we first split it on the / and then decode the path segments to get a list like:</p>
<pre><code>["foo","bar","baz"]
</code></pre>
<p>That is what gets feed into the routing system.</p>
<p><code>match</code> is really just a special case of <code>capture</code>. But we will keep it as a separate case for two reasons:</p>
<ol>
<li>the implementation of <code>match</code> is easier to understand than <code>capture</code></li>
<li>there are optimizations we can only perform when <code>match</code> is a separate case</li>
</ol>
<h2>Version 1: Monad Transformers</h2>
<p>The traditional way to implement a router like this is by using some common monads and monad transformers. So let's start with that.</p>
<p>First we need some imports:</p>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>{-# LANGUAGE DeriveFunctor, GADTs, GeneralizedNewtypeDeriving, ExistentialQuantification #-}</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control.Monad</span> <span class='hs-layout'>(</span><span class='hs-conid'>MonadPlus</span><span class='hs-layout'>(</span><span class='hs-varid'>mzero</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>msum</span><span class='hs-layout'>,</span> <span class='hs-varid'>join</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control.Monad.State</span> <span class='hs-layout'>(</span><span class='hs-conid'>StateT</span><span class='hs-layout'>,</span> <span class='hs-conid'>MonadState</span><span class='hs-layout'>(</span><span class='hs-varid'>get</span><span class='hs-layout'>,</span> <span class='hs-varid'>put</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>evalStateT</span><span class='hs-layout'>,</span> <span class='hs-varid'>modify</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control.Monad.Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span><span class='hs-layout'>(</span><span class='hs-conid'>Pure</span><span class='hs-layout'>,</span> <span class='hs-conid'>Free</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>liftF</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control.Monad.Operational</span> <span class='hs-layout'>(</span><span class='hs-conid'>Program</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-conid'>ProgramT</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-conid'>ProgramView</span><span class='hs-layout'>,</span> <span class='hs-conid'>ProgramViewT</span><span class='hs-layout'>(</span><span class='hs-conid'>Return</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-conop'>:>>=</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>singleton</span><span class='hs-layout'>,</span> <span class='hs-varid'>view</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Data.List</span> <span class='hs-layout'>(</span><span class='hs-varid'>groupBy</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Data.Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>isNothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Text.PrettyPrint.HughesPJ</span> <span class='hs-layout'>(</span><span class='hs-conid'>Doc</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varop'><+></span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varop'>$+$</span><span class='hs-layout'>)</span><span class='hs-layout'>,</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'>char</span><span class='hs-layout'>,</span> <span class='hs-varid'>doubleQuotes</span><span class='hs-layout'>,</span> <span class='hs-varid'>nest</span><span class='hs-layout'>,</span> <span class='hs-varid'>space</span><span class='hs-layout'>,</span> <span class='hs-varid'>text</span><span class='hs-layout'>,</span> <span class='hs-varid'>vcat</span><span class='hs-layout'>,</span> <span class='hs-varid'>empty</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Text.Show.Functions</span> <span class='hs-conid'>()</span> <span class='hs-comment'>-- instance Show (a -> b)</span>
</pre>
<p>You will need to install the <code>free</code> and <code>operational</code> libraries from hackage (used in later sections).</p>
<p>Next we define a <code>newtype</code> for our routing monad:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>newtype</span> <span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RouteMT</span> <span class='hs-layout'>{</span> <span class='hs-varid'>unRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>StateT</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span> <span class='hs-layout'>}</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Functor</span><span class='hs-layout'>,</span> <span class='hs-conid'>Monad</span><span class='hs-layout'>,</span> <span class='hs-conid'>MonadPlus</span><span class='hs-layout'>,</span> <span class='hs-conid'>MonadState</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRouteMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRouteMT</span> <span class='hs-varid'>route</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalStateT</span> <span class='hs-layout'>(</span><span class='hs-varid'>unRoute</span> <span class='hs-varid'>route</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span>
</pre>
<p><code>MT</code> is short for <code>MonadTransformer</code> here. Our <code>RouteMT</code> monad is
created by combining two familiar monads: <code>State</code> and <code>Maybe</code>. <code>StateT
[String]</code> contains the path segments in the url. Everytime we
successfully consume a path segment, we pop it off the list. We use
<code>String</code> instead of <code>Text</code> just to keep this blog post simple. A real
implementation would probably use <code>Text</code>.</p>
<p><code>Maybe</code> is used to indicate failure. We can use its <code>MonadPlus</code>
instance to provide the <code>choice</code> operation.</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>choiceMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>choiceMT</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>msum</span>
</pre>
<p>So, we need only implement <code>match</code> and <code>capture</code>. We can define <code>match</code> as:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>matchMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ path segment to match on</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteMT</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>matchMT</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>put</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mzero</span>
</pre>
<p>If the path matches, then we pop it off the stack, otherwise we call <code>mzero</code>.</p>
<p>We can implement capture as:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>captureMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ function to decode path segment</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>captureMT</span> <span class='hs-varid'>parse</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span> <span class='hs-conop'>:</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>parse</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>mzero</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-varid'>mzero</span>
</pre>
<p><code>capture</code> is very much like <code>match</code> except we use the supplied parsing function instead of plain old <code>==</code>.</p>
<p>We will also want a helper function so that we can use <code>read</code> with <code>captureMT</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>readMaybe</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Read</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>readMaybe</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>reads</span> <span class='hs-varid'>s</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>n</span><span class='hs-layout'>,</span><span class='hs-conid'>[]</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-varid'>n</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
</pre>
<p>Now we can implement a simple route:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1MT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteMT</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route1MT</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>choiceMT</span> <span class='hs-keyglyph'>[</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchMT</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>captureMT</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchMT</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>captureMT</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /bar/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Double</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchMT</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>matchMT</span> <span class='hs-str'>"cat"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/cat"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
</pre>
<p>Being lazy programmers, we will define some unit tests rather than a formal proof of correctness. Here is our simple test function:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>testRouteMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>RouteMT</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<span class='hs-varop'>></span> <span class='hs-definition'>testRouteMT</span> <span class='hs-varid'>r</span> <span class='hs-varid'>tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>all</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-varid'>paths</span><span class='hs-layout'>,</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>runRouteMT</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-varid'>tests</span>
</pre>
<p>And to make things pretty, we will define <code>==></code> as an alias for <code>(,)</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varop'>==></span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></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-varop'>></span> <span class='hs-definition'>a</span> <span class='hs-varop'>==></span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</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>
</pre>
<p>Now we can write down our unit tests for route:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1_results</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>[</span> <span class='hs-keyglyph'>[</span><span class='hs-str'>"foo"</span><span class='hs-layout'>,</span> <span class='hs-str'>"1"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>==></span> <span class='hs-conid'>Just</span> <span class='hs-str'>"You are looking at /foo/1"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-str'>"foo"</span><span class='hs-layout'>,</span> <span class='hs-str'>"cat"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>==></span> <span class='hs-conid'>Just</span> <span class='hs-str'>"You are looking at /foo/cat"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-str'>"bar"</span><span class='hs-layout'>,</span> <span class='hs-str'>"3.141"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>==></span> <span class='hs-conid'>Just</span> <span class='hs-str'>"You are looking at /bar/3.141"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-str'>"baz"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>==></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
</pre>
<p>and combining it all together:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1MT_test</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>testRouteMT</span> <span class='hs-varid'>route1MT</span> <span class='hs-varid'>route1_results</span>
</pre>
<h2>Version 2: Interpreter Approach</h2>
<p>While the monad transformer code works fine, there are ways it could be better:</p>
<ol>
<li><p>In order to find the matching route, it has to start at the top of the list and work all the way to the bottom until it finds a match or gets to the end of the list. For example, we have one route that starts with <code>"/foo"</code> at the top and another that starts with <code>"/foo"</code> at the bottom. Additionally, if we match on <code>"bar"</code> but fail to decode the next path as an <code>Int</code>, there is no point in trying any additional routes, because no other routes start with <code>"/bar"</code>. But there is no way to impart that information into the router.</p></li>
<li><p>when routes fail, there is no record of why it failed. We just get back <code>Nothing</code>. On a live site, that is fine, but during development, you sometimes do care.</p></li>
</ol>
<p>We can solve both these issues by using a data-type to build the router instead:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Match'</span> <span class='hs-conid'>String</span> <span class='hs-layout'>(</span><span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-keyword'>forall</span> <span class='hs-varid'>b</span><span class='hs-varop'>.</span> <span class='hs-conid'>Capture'</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>b</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Term'</span> <span class='hs-varid'>a</span>
</pre>
<p>The last argument of the <code>Match'</code> and <code>Capture'</code> constructors is what
to do next if that match or capture succeeds.</p>
<p>We can create <code>Functor</code> and <code>Monad</code> instances for the <code>Route'</code> type:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>instance</span> <span class='hs-conid'>Functor</span> <span class='hs-conid'>Route'</span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-varid'>s</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Match'</span> <span class='hs-varid'>s</span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture'</span> <span class='hs-varid'>p</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Capture'</span> <span class='hs-varid'>p</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'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-varid'>r</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-varid'>rs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Choice'</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varid'>rs</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>fmap</span> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Term'</span> <span class='hs-layout'>(</span><span class='hs-varid'>f</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>instance</span> <span class='hs-conid'>Monad</span> <span class='hs-conid'>Route'</span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Term'</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>f</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-varid'>str</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Match'</span> <span class='hs-varid'>str</span> <span class='hs-layout'>(</span><span class='hs-varid'>r</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-varid'>rs</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Choice'</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>r</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>r</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span> <span class='hs-varid'>rs</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture'</span> <span class='hs-varid'>p</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Capture'</span> <span class='hs-varid'>p</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'>r</span> <span class='hs-varid'>b</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span>
</pre>
<p>These instances can be a little tricky to understand at first. You
might want to finish this section and then come back to them after you
have seen the bigger picture and some examples.</p>
<p>Our routing functions no longer do any real work directly. Instead
they just construct <code>Route'</code> values:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>match'</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>match'</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Match'</span> <span class='hs-varid'>p</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>capture'</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>b</span>
<span class='hs-varop'>></span> <span class='hs-definition'>capture'</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Capture'</span> <span class='hs-varid'>p</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-conid'>Term'</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>choice'</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>choice'</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Choice'</span>
</pre>
<p>Now all the real work happens in <code>runRoute'</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-varid'>p'</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runRoute'</span> <span class='hs-varid'>r</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-layout'>(</span><span class='hs-varid'>r</span><span class='hs-conop'>:</span><span class='hs-varid'>rs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>runRoute'</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-varid'>rs</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture'</span> <span class='hs-varid'>parse</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>parse</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>runRoute'</span> <span class='hs-layout'>(</span><span class='hs-varid'>r</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-varid'>ps</span>
</pre>
<p>We can test a <code>Route'</code> with <code>runRoute'</code> and see that it acts just like
<code>RouteMT</code>. We can reimplement <code>route1MT</code> using the new functions. The only difference is that the names have been changed from <code>fooMT</code> to <code>foo'</code>. If we did not change the names then the new implementation would be a drop-in replacement for the old code:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1'</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route1'</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match'</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>capture'</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match'</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>capture'</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /bar/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Double</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match'</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match'</span> <span class='hs-str'>"cat"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/cat"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>testRoute'</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Route'</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<span class='hs-varop'>></span> <span class='hs-definition'>testRoute'</span> <span class='hs-varid'>r</span> <span class='hs-varid'>tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>all</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-varid'>paths</span><span class='hs-layout'>,</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>runRoute'</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-varid'>tests</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1'_test</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>testRoute'</span> <span class='hs-varid'>route1'</span> <span class='hs-varid'>route1_results</span>
</pre>
<p>If you look at <code>runRoute'</code> closely you will notice that we don't ever
pass back the unconsumed path segments. So you might wonder how
something like this could work:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>match'</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>match'</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match'</span> <span class='hs-str'>"baz"</span>
</pre>
<p>Specifically, after <code>choice'</code> has successfully matched on <code>"foo"</code> or <code>"bar"</code>, how does the <code>match'</code> function get access to the remaining path segments?</p>
<p>If we expand the functions and monad operations, though, the answer becomes clearer. First let's substitute in the <code>match'</code>, <code>capture'</code>, and <code>choice'</code> operations:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'1</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'1</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
</pre>
<p>Next let's desugar the monad syntax:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'2</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'2</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
</pre>
<p>And now we can substitute the <code>>>=</code> using this rule from the <code>Monad</code> instance:</p>
<pre><code>(Choice' rs) >>= f = Choice' (map (\r -> r >>= f) rs)
</code></pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'3</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'3</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>r</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>r</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
</pre>
<p>substituting the <code>map</code> gives us:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'4</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'4</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>
<p>now we can apply this rule to expand the remaining <code>>>=</code>:</p>
<pre><code>(Match' str r) >>= f = Match' str (r >>= f)
</code></pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'5</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'5</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>
<p>next we can apply this rule:</p>
<pre><code>(Term' a) >>= f = f a
</code></pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'6</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'6</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>
<p>and finally, we can apply the <code>\_ -></code> to <code>()</code> which gives us:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'7</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route'</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2'Expanded'7</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice'</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"foo"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-conid'>Match'</span> <span class='hs-str'>"bar"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match'</span> <span class='hs-str'>"baz"</span> <span class='hs-layout'>(</span><span class='hs-conid'>Term'</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>
<p>So, we can see here that the monad syntax is just used to build a
tree. Each valid parse is represented as a straight path from the
root to a leaf. So, we need to pass the remaining segments in as we
travel down the tree. But we don't have to worry about coming back up
again, so the recursive <code>runRoute'</code> calls don't have to return the
unconsumed path segments to the callers.</p>
<h2>Alternative Interpreters</h2>
<p>The monad transformer version was a lot shorter to write, and easy to
understand. For people studying the implementation, it leverages
existing knowledge about the <code>State</code> and <code>Maybe</code> monads.</p>
<p>The new interpreter version has a far more complex type and the
<code>runRoute'</code> function is harder to understand. For the end user, none
of this really matters, because the API is exactly the same -- we only
changed the names so we could shove this entire example in a single
literate Haskell file.</p>
<p>So, what have we gained?</p>
<p>One thing we can do is write alternative interpreters which address
the two complaints we had about the monad transformer based direct
implementation.</p>
<p>For example, we can analyze the <code>Route'</code> type and optimize the routes. As an example, we can rewrite this:</p>
<pre><code>choice' [ do match' "foo"
match' "bar"
return "/foo/bar"
, do match' "foo"
match' "baz"
return "/foo/baz"
]
</code></pre>
<p>to this:</p>
<pre><code>choice' [ do match' "foo"
choice' [ do match' "bar"
return "/foo/bar"
, do match' "baz"
return "/foo/baz"
]
]
</code></pre>
<p>Because routes with the same prefix are now nested, we do not need to do any backtracking. if <code>"foo"</code> matches, but <code>"bar"</code> and <code>"baz"</code> fail, we do not need to backtrack and see if there are any other routes that start with <code>"foo"</code>. We could implement this as an alternative function to <code>runRoute'</code> leaving <code>runRoute'</code> still intact.</p>
<p>We could also implement a <code>debugRoute</code> function that shows us what path we tried to match at each step and whether it succeeded or not. We are not going to implement these functions quite yet though.</p>
<h2>Version 3: Free Monad</h2>
<p>As we saw, the <code>Route'</code> type is essentially building a specialized
tree with the values at the leaves. As Haskell users, we like to
abstract and reuse things. What if we could get rid of the explicit
recursion in the <code>Route'</code> type and get a valid <code>Monad</code> instance with
out having to do any real work? That should simplify our code, and
reduce the chances of introducing a bug. This is where the <code>Free</code>
monad comes into play. The <code>Free</code> type is defined as:</p>
<pre><code>data Free f a = Pure a | Free (f (Free f a))
</code></pre>
<p>If we look at that type we can see how we might be able to use the <code>Pure</code> constructor for the values in the leaves, and the <code>Free</code> constructor to provide the recusion. So, now we can define a non-recursive type that just operates on a single path segment.</p>
<p>Using the GADT syntax makes things a bit prettier, because the constructor types look like the related function types:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>Segment</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Match</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Segment</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Capture</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Segment</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Choice</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-conid'>Segment</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Zero</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Segment</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Functor</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
</pre>
<p>we can be extra lazy and derive the <code>Functor</code> instance automatically (and correctly!).</p>
<p>Compared to the <code>Route'</code> type, we see that the constructors are a little simpler now. For example, <code>Match</code> takes the <code>String</code> to match on and the value to return on success. But, we do not have to explicitly spell out the recursion. And, because <code>Capture</code> does not have a <code>forall b.</code> anymore, we can use the <code>DeriveFunctor</code> extension to derive the <code>Functor</code> instance automatically.</p>
<p>While we do not explicitly have recursion in the <code>Segment</code> type -- we do leave holes where recursion can happen. For example we can write:</p>
<pre><code>Match "foo" (Match "bar" Zero)
</code></pre>
<p><code>Free</code> already has a <code>Monad</code> instance, so to make a <code>Monad</code> out of <code>Segment</code> we can just use a type alias:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>type</span> <span class='hs-conid'>Route</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Free</span> <span class='hs-conid'>Segment</span>
</pre>
<p>So, this is pretty nice! We got valid <code>Functor</code> and <code>Monad</code> instances
for free! You might think that is why it is called the <code>Free</code> monad --
and it sort of is. The term free actually comes from abstract
algebra and category theory -- and they have some other idea about
what the <em>free</em> part is.</p>
<p>All sorts of things like monoids, functors, monads, etc can be
free. Something is free if it satisfies exactly the required laws but
nothing extra. In our example, we created the <code>Route</code> monad by just
making the type alias <code>type Route = Free Segment</code>. By design the
Haskell <code>Free</code> monad doesn't do anything except satisfy the monad
laws. And adding the type alias <code>type Route = Free Segment</code> is clearly
not going to suddenly make it do more things. So, presumably <code>Route</code>
is free as well. Yes, it really is that simple.</p>
<p>There are a bunch of other blog posts and wiki pages about the
underlying theory, so we are just going to move on. We are aiming for
gaining an hands-on understanding in this post, not a theoretical one.</p>
<p>We define the routing combinators similar to how we did for <code>Route'</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | match on a static path segment</span>
<span class='hs-varop'>></span> <span class='hs-definition'>match</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>match</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftF</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
</pre>
<p><code>liftF</code> has the type:</p>
<pre><code>liftF :: Functor f => f a -> Free f a
</code></pre>
<p>we could have written match as:</p>
<pre><code>match p = Free (Match p (Pure ()))
</code></pre>
<p>but liftF gets rid of some of the noise for us. The other combinators
are pretty much the same:</p>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | match on a path segment and attempt to convert it to a type</span>
<span class='hs-varop'>></span> <span class='hs-definition'>capture</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>capture</span> <span class='hs-varid'>convert</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>liftF</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture</span> <span class='hs-varid'>convert</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | try several routes, using the first that succeeds</span>
<span class='hs-varop'>></span> <span class='hs-definition'>choice</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>choice</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>join</span> <span class='hs-varop'>$</span> <span class='hs-varid'>liftF</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | a route that will always fail</span>
<span class='hs-varop'>></span> <span class='hs-definition'>zero</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>zero</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftF</span> <span class='hs-conid'>Zero</span>
</pre>
<p>To perform the routing, we create a <code>runRoute</code> function like before:</p>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | run a route, full backtracking on failure</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Pure</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p'</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture</span> <span class='hs-varid'>convert</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>convert</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>runRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>choices</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>msum</span> <span class='hs-varop'>$</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>flip</span> <span class='hs-varid'>runRoute</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varid'>choices</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-conid'>Zero</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span>
</pre>
<p>You'll note that this <code>runRoute</code> function looks quite a bit like the
previous <code>runRoute'</code> function. It does contain a bit of extra noise
because we of the <code>Free</code> constructors.</p>
<p>As before, the API remains unchanged (aside from renames to avoid name
clashes):</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1Free</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route1Free</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>choice</span> <span class='hs-keyglyph'>[</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>capture</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>capture</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /bar/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Double</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"cat"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/cat"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
</pre>
<p>And our test results remain unchanged:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>testRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<span class='hs-varop'>></span> <span class='hs-definition'>testRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>all</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-varid'>paths</span><span class='hs-layout'>,</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>runRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-varid'>tests</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1Free_tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>testRoute</span> <span class='hs-varid'>route1Free</span> <span class='hs-varid'>route1_results</span>
</pre>
<p>As with <code>Route'</code>, we are just building a tree. For example if we have `route2' again:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route2</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route2</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>choice</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>match</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"baz"</span>
</pre>
<p>and we show it using the <code>show</code> function we get:</p>
<pre><code>Free (Choice [ Free (Match "foo" (Free (Match "baz" (Pure ()))))
, Free (Match "bar" (Free (Match "baz" (Pure ()))))
]
)
</code></pre>
<p>That looks nearly identical to <code>route2'Expanded'7</code> except for with <code>Pure</code> instead of <code>Term</code> and with a bunch of <code>Free</code> constructors inserted. The same basic tree structure still remains.</p>
<h2>Interpreter with Debugging</h2>
<p>Now, let's look at actually implementing the alternative interpreters we mentioned earlier.</p>
<p>We can implement <code>debugRoute</code> like this:</p>
<pre><span class='hs-varop'>></span> <span class='hs-comment'>-- | run a route, also returning debug log</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>Doc</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Pure</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"Pure"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"-- ran out of path segments before finding 'Pure'"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p'</span> <span class='hs-varid'>next</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>debugRoute</span> <span class='hs-varid'>next</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>in</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"dir"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p'</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- matched"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"dir"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p'</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- did not match"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- aborted"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture</span> <span class='hs-varid'>convert</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>convert</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"path <func>"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- was not able to convert"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- aborted"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>debugRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>ps</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>in</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"path <func>"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-str'>"-- matched"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-varid'>p</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>choices</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>let</span> <span class='hs-varid'>debugs</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-conop'>:</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>debugs</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>doc</span><span class='hs-conop'>:</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>debugs</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>r</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>r</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>docs</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>debugs</span> <span class='hs-layout'>(</span><span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-varid'>reverse</span> <span class='hs-varop'>$</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>flip</span> <span class='hs-varid'>debugRoute</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varid'>choices</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>in</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"choice"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>showPrettyList</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>d</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>text</span> <span class='hs-str'>"do"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>d</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-varid'>reverse</span> <span class='hs-varid'>docs</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>ma</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>debugRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-conid'>Zero</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-str'>"zero"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>showPrettyList</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Doc</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Doc</span>
<span class='hs-varop'>></span> <span class='hs-definition'>showPrettyList</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"[]"</span>
<span class='hs-varop'>></span> <span class='hs-definition'>showPrettyList</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>char</span> <span class='hs-chr'>'['</span> <span class='hs-varop'><+></span> <span class='hs-varid'>x</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>char</span> <span class='hs-chr'>']'</span>
<span class='hs-varop'>></span> <span class='hs-definition'>showPrettyList</span> <span class='hs-layout'>(</span><span class='hs-varid'>h</span><span class='hs-conop'>:</span><span class='hs-varid'>tl</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>char</span> <span class='hs-chr'>'['</span> <span class='hs-varop'><+></span> <span class='hs-varid'>h</span> <span class='hs-varop'>$+$</span> <span class='hs-layout'>(</span><span class='hs-varid'>vcat</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>showTail</span> <span class='hs-varid'>tl</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>char</span> <span class='hs-chr'>']'</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>showTail</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>char</span> <span class='hs-chr'>','</span> <span class='hs-varop'><+></span> <span class='hs-varid'>x</span>
</pre>
<p><code>debugRoute</code> is pretty straight-forward. Feel free to skip over the implementation. The interesting part is that with out modifying <code>route2</code> we can next get a debug log:</p>
<pre><code>*GHCi> let (d, r) = debugRoute route2 ["foo","bar"] in (print d >> print r)
choice [ do dir foo -- matched foo
dir baz -- did not match bar
-- aborted
, do dir bar -- did not match foo
-- aborted
]
Nothing
</code></pre>
<h2>Route optimizing</h2>
<p>Because the routing is now represented by a data-type, we can also write a simple optimizing function for it:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>optimize</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimize</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-layout'>(</span><span class='hs-varid'>optimize</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimize</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>cs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>optimize'</span> <span class='hs-varid'>cs</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimize</span> <span class='hs-varid'>r</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>r</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimize'</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimize'</span> <span class='hs-varid'>cs</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>map</span> <span class='hs-varid'>flatten</span> <span class='hs-varop'>$</span> <span class='hs-varid'>groupBy</span> <span class='hs-varid'>sameDir</span> <span class='hs-varid'>cs</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>zero</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>x</span>
<span class='hs-varop'>></span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>choice</span> <span class='hs-varid'>xs</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zero</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-varid'>xs</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-layout'>(</span><span class='hs-varid'>optimize'</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>next</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>next</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>xs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>error</span> <span class='hs-str'>"flatten assertion failed."</span>
<span class='hs-varop'>></span> <span class='hs-varid'>sameDir</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p'</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'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span>
<span class='hs-varop'>></span> <span class='hs-varid'>sameDir</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>
<p>And a helper function that shows the <code>Route</code> type as if it was Haskell code:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Show</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Doc</span>
<span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Pure</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"return"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>text</span> <span class='hs-layout'>(</span><span class='hs-varid'>show</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p</span> <span class='hs-varid'>next</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"match"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>doubleQuotes</span> <span class='hs-layout'>(</span><span class='hs-varid'>text</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-varop'>$+$</span> <span class='hs-varid'>prettyRoute</span> <span class='hs-varid'>next</span>
<span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture</span> <span class='hs-varid'>f</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"capture <func>"</span> <span class='hs-varop'><></span> <span class='hs-varid'>text</span> <span class='hs-layout'>(</span><span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-varid'>f</span> <span class='hs-str'>""</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>cs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"choice"</span> <span class='hs-varop'><+></span> <span class='hs-layout'>(</span><span class='hs-varid'>showPrettyList</span> <span class='hs-varop'>$</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>r</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>text</span> <span class='hs-str'>"do"</span> <span class='hs-varop'><+></span> <span class='hs-layout'>(</span><span class='hs-varid'>nest</span> <span class='hs-num'>4</span> <span class='hs-varop'>$</span> <span class='hs-varid'>prettyRoute</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>cs</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>prettyRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-conid'>Zero</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"zero"</span>
</pre>
<p>Consider this route table:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route4</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route4</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>choice</span> <span class='hs-keyglyph'>[</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"one"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-str'>"foo/bar/one"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"two"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-str'>"foo/bar/two"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>match</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"baz"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>match</span> <span class='hs-str'>"three"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-str'>"foo/baz/three"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
</pre>
<p>It has a bunch of overlapping in the patterns -- they all start with
<code>match "foo"</code> which means that the router is going to have to do a
linear search of all the patterns to make sure that none
match. Additionally it will have to keep rematching on "foo" even
though it already has.</p>
<p>If we call <code>prettyRoute</code> on <code>route4</code> we get the original route map:</p>
<pre><code>prettyRoute route4
choice [ do match "foo"
match "bar"
match "one"
return "foo/bar/one"
, do match "foo"
match "bar"
match "two"
return "foo/bar/two"
, do match "foo"
match "baz"
match "three"
return "foo/baz/three"
]
</code></pre>
<p>And if we optimize the route:</p>
<pre><code>prettyRoute (optimize route4)
</code></pre>
<p>Then we see that the overlapping prefixes have been combined:</p>
<pre><code>match "foo"
choice [ do match "bar"
choice [ do match "one"
return "foo/bar/one"
, do match "two"
return "foo/bar/two"
]
, do match "baz"
match "three"
return "foo/baz/three"
]
</code></pre>
<p>This version should run a bit faster than the original version because it will only need to match on "foo" once. And the embedded lists are shorter than the original. So when it does need to try all the alternatives, there are fewer to try.</p>
<p>One remaining problem is that for a url like <code>"/foo/bar/apple"</code>, <code>runRoute</code> is going to backtrack and try the <code>"baz"</code> branch. But, that is pointless, because the optimizer ensures that backtracking is never going to be needed. (Actually that is not true, but let's pretend for a second that it is).</p>
<p>So, we can instead use this non-backtracking variant to run the route:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Route</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Pure</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Match</span> <span class='hs-varid'>p'</span> <span class='hs-varid'>next</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p'</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-varid'>snd</span> <span class='hs-varop'>$</span> <span class='hs-varid'>runOptRoute</span> <span class='hs-varid'>next</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Capture</span> <span class='hs-varid'>convert</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>p</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>convert</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>r</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-varid'>snd</span> <span class='hs-varop'>$</span> <span class='hs-varid'>runOptRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>ps</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-layout'>(</span><span class='hs-conid'>Choice</span> <span class='hs-varid'>choices</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>tryChoices</span> <span class='hs-varid'>paths</span> <span class='hs-varid'>choices</span>
<span class='hs-varop'>></span> <span class='hs-definition'>runOptRoute</span> <span class='hs-layout'>(</span><span class='hs-conid'>Free</span> <span class='hs-conid'>Zero</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>tryChoices</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Route</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>tryChoices</span> <span class='hs-conid'>[]</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>tryChoices</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>tryChoices</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>r</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runOptRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span>
<span class='hs-varop'>></span> <span class='hs-definition'>tryChoices</span> <span class='hs-varid'>paths</span> <span class='hs-layout'>(</span><span class='hs-varid'>r</span><span class='hs-conop'>:</span><span class='hs-varid'>rs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>runOptRoute</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>tryChoices</span> <span class='hs-varid'>paths</span> <span class='hs-varid'>rs</span>
<span class='hs-varop'>></span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>x</span>
</pre>
<p>Unfortunately, this won't actually work correctly. We said that we would never have to backtrack once a <code>match</code> succeeds because the optimizer has combined all the other branches that matched on the same path into a single branch of the tree. However, the optimizer has no way of knowing what the <code>capture</code> clauses are matching on because <code>capture</code> just takes an arbitrary function to do the matching.</p>
<p>Also, it is valid for there to be more than one possible match for a particular URL. The route that matches <em>first</em> is the correct route. However, the optimizer does not take that into consideration. So, it is possible that after optimization a different route will start matching.</p>
<p>These problems can be addressed, but are outside the scope of this blog post. We just wanted to see that the possibility exists. A correct, and more powerful, solution will likely appear in Happstack 8.</p>
<h2>Version 4: Operational Monad</h2>
<p>Instead of using the <code>Free</code> monad we could use the <code>operational</code>
monad.</p>
<p>The <code>operational</code> monad was designed from the ground up to be used for
defining programs which are run by interpreters -- like what we have
been doing in the last couple sections.</p>
<p>In the original <code>Route</code> type we had explicit recursive types. In the
<code>Free</code> monad section, we simplified that and had the <code>Segment</code> type
which had polymorphic places where you could use recursion, but you
were not forced to. But, that made the type a bit odd -- looking at
the <code>Segment</code> type by itself, it is not really clear what the point of
<code>a</code> type variable is supposed to be.</p>
<p>A much more natural way of encoding a program that matches on routes
would be something like this (using GADTs):</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-conid'>MatchOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-conid'>CaptureOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>ChoiceOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-conid'>FailOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span>
</pre>
<p>the monad provided by the <code>operational</code> package is actually called
<code>Program</code> not <code>Operational</code>. As with the <code>Free</code> monad, we create our
route monad via a simple type alias.</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>type</span> <span class='hs-conid'>RouteOp</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-conid'>SegmentCommand</span>
</pre>
<p>The <code>SegmentCommand</code> type now shows no signs of recursion at all. And
the constructor types look just like the corresponding function types.</p>
<p>To turn a single command (like <code>SegmentCommand</code>) into a program (like
<code>RouteOp</code>) we use the <code>singleton</code> function.</p>
<pre><code>singleton :: instr a -> ProgramT instr m a
</code></pre>
<p>Using that we can define our familiar routing combinators very trivially:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>matchOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>matchOp</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>MatchOp</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>captureOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>captureOp</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>CaptureOp</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>choiceOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>choiceOp</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>ChoiceOp</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>failOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>failOp</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>FailOp</span>
</pre>
<p>Next we can define an interpreter for our program. The <code>Program</code> monad does not expose its internals directly. Instead we use the <code>view</code> function:</p>
<pre><code>view :: Program instr a -> ProgramView instr a
</code></pre>
<p>to produce a <code>ProgramView</code>:</p>
<pre><code>type ProgramView instr = ProgramViewT instr Identity
data ProgramViewT instr m a where
Return :: a -> ProgramViewT instr m a
(:>>=) :: (instr b)
-> (b -> ProgramT instr m a)
-> ProgramViewT instr m a
</code></pre>
<p>We see that the <code>ProgramViewT</code> data-type looks almost exactly like the <code>Monad</code> type-class.</p>
<p>Knowing that, we can now define an interpreter for our <code>RouteOp</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>interpretRouteOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-definition'>interpretRouteOp</span> <span class='hs-varid'>router'</span> <span class='hs-varid'>paths</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>paths</span> <span class='hs-varid'>router'</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>go</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>go</span> <span class='hs-varid'>paths</span> <span class='hs-varid'>router</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>view</span> <span class='hs-varid'>router</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Return</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchOp</span> <span class='hs-varid'>p</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>p'</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>p</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-varid'>go</span> <span class='hs-varid'>ps</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>CaptureOp</span> <span class='hs-varid'>pat</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>paths</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>p'</span><span class='hs-conop'>:</span><span class='hs-varid'>ps</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>pat</span> <span class='hs-varid'>p'</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>go</span> <span class='hs-varid'>ps</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>ChoiceOp</span> <span class='hs-conid'>[]</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>ChoiceOp</span> <span class='hs-varid'>choices</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>let</span> <span class='hs-varid'>tryChoiceOps</span> <span class='hs-varid'>cs</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cs</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>c</span><span class='hs-conop'>:</span><span class='hs-varid'>cs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>go</span> <span class='hs-varid'>paths</span> <span class='hs-varid'>c</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>paths'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>go</span> <span class='hs-varid'>paths'</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>tryChoiceOps</span> <span class='hs-varid'>cs'</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>in</span> <span class='hs-varid'>tryChoiceOps</span> <span class='hs-varid'>choices</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>FailOp</span> <span class='hs-conop'>:>>=</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>route1Op</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteOp</span> <span class='hs-conid'>String</span>
<span class='hs-varop'>></span> <span class='hs-definition'>route1Op</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>choiceOp</span> <span class='hs-keyglyph'>[</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchOp</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>captureOp</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchOp</span> <span class='hs-str'>"bar"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>captureOp</span> <span class='hs-varid'>readMaybe</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /bar/"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-layout'>(</span><span class='hs-varid'>i</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Double</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchOp</span> <span class='hs-str'>"foo"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>matchOp</span> <span class='hs-str'>"cat"</span>
<span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You are looking at /foo/cat"</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>testRouteOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Maybe</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<span class='hs-varop'>></span> <span class='hs-definition'>testRouteOp</span> <span class='hs-varid'>r</span> <span class='hs-varid'>tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>all</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-layout'>(</span><span class='hs-varid'>paths</span><span class='hs-layout'>,</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>fst</span> <span class='hs-varop'>$</span> <span class='hs-varid'>interpretRouteOp</span> <span class='hs-varid'>r</span> <span class='hs-varid'>paths</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-varid'>result</span><span class='hs-layout'>)</span> <span class='hs-varid'>tests</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>route1Op_tests</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-varid'>testRouteOp</span> <span class='hs-varid'>route1Op</span> <span class='hs-varid'>route1_results</span>
</pre>
<p>Clearly, we could make an interpreter that included debug information
as well. What is a little less obvious is how to create an optimizer. With the <code>Free</code> monad approach, the optimize function had the type:</p>
<pre><code>optimize :: Route a -> Route a
</code></pre>
<p>where <code>Route</code> had the type:</p>
<pre><code>type Route = Free Segment
</code></pre>
<p>We were able to directly inspect the <code>Free</code> monad structure and
transform it. However, the <code>operational</code> monad does not directly
expose its internals to us. Instead we have to use the <code>view</code> function
to turn the <code>Program</code> into a <code>ProgramView</code>.</p>
<p>We also need to convert a <code>ProgramView</code> back into a <code>Program</code>. The <code>operational</code> library does not provide an <code>unview/unviewT</code> function, but we can define it ourselves as:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>unviewT</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-varid'>instr</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProgramT</span> <span class='hs-varid'>instr</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>unviewT</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>unviewT</span> <span class='hs-layout'>(</span><span class='hs-varid'>instr</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varid'>instr</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span>
</pre>
<p>Once that is done, we can then create a route optimizer:</p>
<pre><span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimizeOp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimizeOp</span> <span class='hs-varid'>route</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>view</span> <span class='hs-varid'>route</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>ChoiceOp</span> <span class='hs-varid'>cs</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>optimizeOp'</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>view</span> <span class='hs-varid'>cs</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-varid'>k</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>route</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimizeOp'</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ProgramView</span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-definition'>optimizeOp'</span> <span class='hs-varid'>cs</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>map</span> <span class='hs-varid'>flatten</span> <span class='hs-varop'>$</span> <span class='hs-varid'>groupBy</span> <span class='hs-varid'>sameDir</span> <span class='hs-varid'>cs</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>failOp</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>x</span>
<span class='hs-varop'>></span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>choiceOp</span> <span class='hs-varid'>xs</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ProgramView</span> <span class='hs-conid'>SegmentCommand</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteOp</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>failOp</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unviewT</span> <span class='hs-varid'>x</span>
<span class='hs-varop'>></span> <span class='hs-varid'>flatten</span> <span class='hs-varid'>xs</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-conid'>MatchOp</span> <span class='hs-varid'>p</span> <span class='hs-conop'>:>>=</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>matchOp</span> <span class='hs-varid'>p</span>
<span class='hs-varop'>></span> <span class='hs-varid'>optimizeOp'</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>view</span> <span class='hs-layout'>(</span><span class='hs-varid'>next</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchOp</span> <span class='hs-keyword'>_</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>next</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>]</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-varid'>sameDir</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchOp</span> <span class='hs-varid'>p1</span> <span class='hs-conop'>:>>=</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>MatchOp</span> <span class='hs-varid'>p2</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'>p1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p2</span>
<span class='hs-varop'>></span> <span class='hs-varid'>sameDir</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>
<p>As with the <code>Free</code> monad solution, we could define a function to run the optimized route. However, it would have the same issues outlined before. So we will skip it.</p>
<h1>Conclusions</h1>
<p>In the original <code>RouteMT</code> based around monad transformers, the set of
primitives can easily be extended by adding new functions. For
example, we could add a primitive that reverses the order of all the
remaining path segments:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>reverseMT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteMT</span> <span class='hs-conid'>()</span>
<span class='hs-varop'>></span> <span class='hs-definition'>reverseMT</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>modify</span> <span class='hs-varid'>reverse</span>
</pre>
<p>In <code>Route'</code> and <code>Route</code>, we would need to extend the data-type and
also the interpreter functions. But we get the ability to inspect,
rewrite, or interpret the actions differently.</p>
<p>As we saw, we don't need the <code>Free</code> or <code>operational</code> monads to reap these benefits. So, a big question is, what do those monads actually buy us?</p>
<p>In this example, we saw that it allowed us to derive the <code>Functor</code> instance and we got the <code>Monad</code> instance automatically too. So, we can be sure that our <code>Functor</code> and <code>Monad</code> instances actually follow the laws.</p>
<p>But, we also paid a price. In the <code>Free</code> implementation, our interpreter functions are cluttered up by a bunch of <code>Free</code> and <code>Pure</code> constructors.</p>
<p>The <code>operational</code> monad provided benefits similar to the <code>Free</code> monad, but with a nicer interface. The <code>operational</code> monad is reportedly nearly isomorphic to the <code>Free</code> monad. So, it should be able to do almost everything the <code>Free</code> monad can.</p>
<p>I've heard rumors that the <code>Free</code> monad can have quadratic runtime, while the <code>operational</code> monad does stuff to avoid that? Though there is also some way to use the <code>codensity</code> monad to fix the <code>Free</code> monad?</p>
<p>So, experts, which implementation should I use for this example? And what are the benefits of that solution over the other alternatives? My inclination is to use the <code>operational</code>. The interpretive solution clearly provides the most flexibility. Of the three intepretive solutions, the <code>operational</code> monad seems like the easiest solution to implement and to understand. I am not sure what (if anything) I am missing out on by using <code>operational</code> instead of <code>Free</code>...</p>
<p>Discussion can be <a href="http://www.reddit.com/r/haskell/comments/16ede8/comparison_of_4_approaches_to_implementing_url/">found here</a></p>
Happstack, Fay, & Acid-State: Shared Datatypes are Awesomeurn:uuid:c5354cf6-50a4-46cc-a116-93736d643e75stepcut2012-11-15T18:52:04Z<p>Haskell is slowly moving onto the browser -- and that is very
exciting. We have Fay, GHCJS, UHCJS, Haskell-like languages such as
Elm, and more!</p>
<p>In this post I want to demonstrate two ways in which this is awesome.</p>
<ol>
<li><p>we can now define a data-type once and use it everywhere</p></li>
<li><p>we can now define a type-checked AJAX interface between the
browser and the server.</p></li>
</ol>
<p>In this post we will be using:</p>
<ul>
<li><code>happstack-server</code> - a modern Haskell based web application server</li>
<li><code>acid-state</code> - a native Haskell database system</li>
<li><code>fay</code> - a compiler which compiles a subset of Haskell to Javascript</li>
</ul>
<h2>The Bad Old Days</h2>
<p>Let's first consider a more traditional system where we use
<code>happstack-server</code>, a SQL database, and Javascript. If we have a value
we want to store in the database, manipulate on the server, and send
to the client, we need to manually create several representations of
this value and manually write code to marshal to and from the various
representations.</p>
<p>In the SQL database, the value needs to be represented via columns and
relations in one or more tables. On the server-side we need to create
an algebraic data type to represent the value. To transmit the value
to the client we need to the convert the value into a JSON object. And
then on the client-side we may then need to convert the JSON value
into a Javascript object.</p>
<p>To switch between each of these representations we need to manually
write code. For example, we need to write the SQL statements to update
and retrieve the value from the database.</p>
<p>So in addition to the four representations of our data, we have 3
bidirectional conversions to manage as well:</p>
<pre><code>SQL <=> ADT <=> JSON <=> JAVASCRIPT
</code></pre>
<p>Now let's say we need to make a change to our datatype -- we have to
correctly update 10 different aspects of our code.</p>
<p>Because SQL and Javascript are outside of the domain of Haskell, we
don't even get the help of the typechecker to make sure we have keep
all the types in-sync.</p>
<p>A popular mantra in computer programming is <code>DRY</code> - "Don't repeat
yourself". Yet, here we have to repeat ourselves 10 times!</p>
<p>In addition to keeping everything in sync, we still have the problem
of having to think about the same data in 4 different ways:</p>
<ol>
<li>as relational data</li>
<li>as an algebraic data type</li>
<li>as a JSON object</li>
<li>as a Javascript object</li>
</ol>
<h2>The Path to Awesome</h2>
<p>The picture when using <code>happstack-server</code>, <code>acid-state</code>, and <code>fay</code> is
radically different. In this system we define our data type as a nice
algebraic data type which can be stored in acid-state, manipulated on
the server, and sent to the client, where it is also treated as the
same ADT. This definition occurs in <em>once</em> in a normal Haskell file
that is shared by all three pieces of the system.</p>
<p>The data does still need to be serialized by <code>acid-state</code> and for
communication to/from the client (via AJAX), however, this serialization
is done entirely automatically via template haskell and generics.</p>
<h2>mastermind</h2>
<p>I have created a simple example of using <code>happstack-server</code>,
<code>acid-state</code>, and <code>fay</code> to implement an interactive web 2.0 mastermind
clone. The board updates all occur client side and communication is
done over a typed AJAX communication channel.</p>
<p>You can find all the source code here:</p>
<p><a href="http://hub.darcs.net/stepcut/mastermind">http://hub.darcs.net/stepcut/mastermind</a></p>
<p>A demonstration of the game play is shown is this video:</p>
<p><a href="http://www.youtube.com/watch?v=K2jdUlhX_E8">http://www.youtube.com/watch?v=K2jdUlhX_E8</a></p>
<p>There are some bugs in the code, unimplemented features, etc. It seems
to display correctly in Chrome, but not Firefox (and possibly others). If any of these
things bother you, feel free to submit patches. These issues, do not
get in the way of the interesting things we want to demonstrate, and
so they will likely remain unfixed.</p>
<p>The tree is organized as follows:</p>
<ul>
<li><code>MasterMind.Client.*</code> - client-side Fay code</li>
<li><code>MasterMind.Server.*</code> - server-side Haskell code</li>
<li><code>MasterMind.Shared.*</code> - code that is shared between the client and server</li>
</ul>
<h2>shared types</h2>
<p><a href="http://hub.darcs.net/stepcut/mastermind/browse/MasterMind/Shared/Core.hs"><code>MasterMind.Shared.Core</code></a>
contains the datatypes needed to define the state of the game
board. There is not much to say about these types -- they are
basically what you would expect to see for a game like mastermind.</p>
<p>In
<a href="http://hub.darcs.net/stepcut/mastermind/browse/MasterMind/Server/Acid.hs"><code>MasterMind.Server.Acid</code></a>
those types are stored persistently using <code>acid-state</code>. All played
games are retained in the database, though there is currently no code
implemented to browse them.</p>
<p>In
<a href="http://hub.darcs.net/stepcut/mastermind/browse/MasterMind/Client/Main.hs"><code>MasterMind.Client.Main</code></a>
those same types (such as <code>Color</code>, <code>Guess</code>, and <code>Board</code>) are imported and used for the client-side
interactions.</p>
<p>By virtue of the fact that everything fits together so seamlessly --
there isn't much to say. It looks like we just defined some normal
Haskell datatypes and used them in normal Haskell code -- just like
any other Haskell program. The interesting part is really what is
missing! We've managed to eliminate all that manual conversion,
having to think about multiple representation of the same data,
javascript, SQL, etc, and left ourselves with nice, simple Haskell
code! When we want to change the type, we just change the type in one
place. If we need to update code, the type-checker will complain and
let us know!</p>
<p>Best of all, we do not need to rely on special syntax introduced via
QuasiQuotation. We define the types using normal Haskell data
declarations.</p>
<p>There is a bit of Template Haskell code in the <code>acid-state</code> portions
of the code. To create <code>SafeCopy</code> instances we use
<code>deriveSafeCopy</code>. In principle this is not much different from the
standard <code>deriving Data, Typeable</code> mechanism. However, for those that
eschew Template Haskell, there is work on allowing <code>SafeCopy</code> to use
the new <code>Generics</code> features in GHC 7.2.</p>
<p>There is also a Template Haskell function <code>makeAcidic</code> which would be
a bit more difficult to remove.</p>
<h2>The typed AJAX interface</h2>
<p>Now that we have a way to share types between the client and server,
it is relatively straight-forward to use those types to build a
type-safe communication channel between the client and server.</p>
<p>At the end of <a href="http://hub.darcs.net/stepcut/mastermind/browse/MasterMind/Shared/Core.hs"><code>MasterMind.Shared.Core</code></a> there is a type:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>Command</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SendGuess</span> <span class='hs-conid'>Guess</span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Row</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>FetchBoard</span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Board</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Read</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>,</span> <span class='hs-conid'>Data</span><span class='hs-layout'>,</span> <span class='hs-conid'>Typeable</span><span class='hs-layout'>)</span>
</pre>
<p>The <code>Command</code> type defines the AJAX interface between the server and
the client. The constructors 'SendGuess' and 'FetchBoard' are commands
that the client wants to send, and the <code>ResponseType a</code> is what the
server will return.</p>
<p>It would be far more sensible to declare <code>Command</code> as a <code>GADT</code>:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>Command</span> <span class='hs-varid'>r</span> <span class='hs-keyword'>where</span>
<span class='hs-varop'>></span> <span class='hs-conid'>SendGuess</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Guess</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Command</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Row</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-conid'>FetchBoard</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Command</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Board</span><span class='hs-layout'>)</span>
</pre>
<p>Unfortuantely, Fay does not support <code>GADTs</code> at this time, so we have
to use a series of hacks to get the type safety we are hoping
for. <code>Language.Fay.AJAX</code> (from <code>happstack-fay</code>) defines a type:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>ResponseType</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ResponseType</span>
</pre>
<p>This gives us a phantom type variable that we can use to encode the
type of the response.</p>
<p>Looking at the <code>Command</code> type again, you will see that the last argument to every constructor is a <code>ResponseType</code> value:</p>
<pre><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>Command</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SendGuess</span> <span class='hs-conid'>Guess</span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Row</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>FetchBoard</span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Board</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Read</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>,</span> <span class='hs-conid'>Data</span><span class='hs-layout'>,</span> <span class='hs-conid'>Typeable</span><span class='hs-layout'>)</span>
</pre>
<p>On the client-side we can use <code>call</code> to send an AJAX command:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>call</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Foreign</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>,</span> <span class='hs-conid'>Foreign</span> <span class='hs-varid'>res</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span>
<span class='hs-varop'>></span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ URL to @POST@ AJAX request to</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-varid'>res</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>cmd</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ AJAX command to send to server</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>res</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Fay</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ callback function to handle response</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Fay</span> <span class='hs-conid'>()</span>
</pre>
<p>For example:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>call</span> <span class='hs-str'>"/ajax"</span> <span class='hs-layout'>(</span><span class='hs-conid'>SendGuess</span> <span class='hs-varid'>guess</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>mRow</span> <span class='hs-keyglyph'>-></span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>mRow</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>alert</span> <span class='hs-str'>"Invalid game id"</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>row</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>updateBoard</span> <span class='hs-varid'>row</span>
</pre>
<p>You will note that the type signature for <code>call</code> is a bit funny. The type for the <code>cmd</code> argument is:</p>
<pre><span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>ResponseType</span> <span class='hs-varid'>res</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>cmd</span><span class='hs-layout'>)</span>
</pre>
<p>instead of just</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>cmd</span>
</pre>
<p>But on closer examination, we see that is how the type-checker is able
to enforce that command and response handler types match. When we
actually use <code>call</code> we just leave off the last argument to the
constructor, and the code is quite readable.</p>
<p>Also, note that <code>call</code> is asynchronous -- meaning that <code>call</code> we
return immediately, and the handler will be called after the server
sends back a response. That is why we pass in a callback function
instead of just doing:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>mRow</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>call</span> <span class='hs-str'>"/ajax"</span> <span class='hs-layout'>(</span><span class='hs-conid'>SendGuess</span> <span class='hs-varid'>guess</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- this is not how it actually works</span>
</pre>
<p>We could create a synchronous version of call, however the underlying
javascript engine is single-threaded and that could result in the UI
blocking. We could probably give the appearance of a blocking <code>call</code>
by using continuations in some fashion, but we will consider that
another time.</p>
<p>On the server-side we use a pair of functions:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>handleCommand</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span> <span class='hs-varid'>cmd</span><span class='hs-layout'>,</span> <span class='hs-conid'>Happstack</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-varid'>cmd</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>Response</span><span class='hs-layout'>)</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>Response</span>
<span class='hs-varop'>></span>
<span class='hs-varop'>></span> <span class='hs-definition'>fayResponse</span> <span class='hs-keyglyph'>::</span> <span class='hs-layout'>(</span><span class='hs-conid'>Happstack</span> <span class='hs-varid'>m</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=></span>
<span class='hs-varop'>></span> <span class='hs-conid'>ResponseType</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>Response</span>
</pre>
<p><code>handleCommand</code> decodes the AJAX request and passes it to a
handler. <code>fayResponse</code> is used to convert a return value into a valid
Fay response. The <code>ResponseType a</code> parameter is used to enforce type
safety. So in the code we are going to have something like this in our
top-level route:</p>
<pre><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>dir</span> <span class='hs-str'>"json"</span> <span class='hs-varop'>$</span> <span class='hs-varid'>handleCommand</span> <span class='hs-layout'>(</span><span class='hs-varid'>commandR</span> <span class='hs-varid'>acid</span><span class='hs-layout'>)</span>
</pre>
<p>where <code>commandR</code> looks like:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>commandR</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>AcidState</span> <span class='hs-conid'>Games</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Command</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ServerPart</span> <span class='hs-conid'>Response</span>
<span class='hs-varop'>></span> <span class='hs-definition'>commandR</span> <span class='hs-varid'>acid</span> <span class='hs-varid'>cmd</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>cmd</span> <span class='hs-keyword'>of</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>SendGuess</span> <span class='hs-varid'>guess</span> <span class='hs-varid'>rt</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>fayResponse</span> <span class='hs-varid'>rt</span> <span class='hs-varop'>$</span> <span class='hs-varid'>sendGuessC</span> <span class='hs-varid'>acid</span> <span class='hs-varid'>guess</span>
<span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>FetchBoard</span> <span class='hs-varid'>rt</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>fayResponse</span> <span class='hs-varid'>rt</span> <span class='hs-varop'>$</span> <span class='hs-varid'>fetchBoardC</span> <span class='hs-varid'>acid</span>
</pre>
<p>We see that we pull the <code>ResponseType</code> value from the constructor and
pass it to <code>fayResponse</code>, so that the type checker will enforce that
constraint.</p>
<p>The command handlers have types like:</p>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>sendGuessC</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>AcidState</span> <span class='hs-conid'>Games</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Guess</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ServerPart</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Row</span><span class='hs-layout'>)</span>
</pre>
<pre><span class='hs-varop'>></span> <span class='hs-definition'>fetchBoardC</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>AcidState</span> <span class='hs-conid'>Games</span>
<span class='hs-varop'>></span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ServerPart</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Board</span><span class='hs-layout'>)</span>
</pre>
<p>Hopefully we can add <code>GADTs</code> to Fay soon, which will remove some of
the boilerplate.</p>
<h2>Cabal</h2>
<p>If we want to use cabal to build and install our web application, then
we need to tell cabal how to compile the Fay code to Javscript. I
believe the long term plan is for Cabal to somehow directly support
Fay packages. But in the meantime, this custom Setup.hs seems to do
the trick:</p>
<p><a href="http://hub.darcs.net/stepcut/mastermind/browse/Setup.hs">Setup.hs for building Fay code</a></p>
<p>Note that in <code>mastermind.cabal</code> we have <code>build-type: Custom</code> instead
of that standard <code>build-type: Simple</code>. You need to specify <code>Custom</code> or
cabal will ignore the <code>Setup.hs</code>.</p>
<h2>What Still Sucks</h2>
<p>Fay is still very raw and buggy. In order to get this simple
application working I had to file four bugs against Fay and commit
several other patches myself. When the developers say that Fay is
still alpha <em>they mean it</em>.</p>
<p>On the other hand, the Fay team was very responsive and fixed my issues quickly!</p>
<p>If you want to experiment with Fay, I highly recommend it -- but be
prepared to run into some issues.</p>
<p>Programming in Fay is far nicer than Javascript. But, ultimately we
still have to deal with the DOM model that the browser is based
around. And, even in Fay, that still sucks (even with bootstrap and
jQuery to help). However, now that we have a nice language to work
with, we can hopefully create a nice Fay-based library for client-side
UI development.</p>
<h2>Conclusion</h2>
<p>Fay (and friends) are definitely a huge step in the right
direction. Things are still just getting started, but they are
definitely set to revolution Haskell web programming. We already have
mature solutions for web 1.0 programming such as <code>happstack-server</code>
and <code>reform</code>. But, technologies like Fay are making it far easier to
provide web 2.0 solutions with rich client-side functionality.</p>
<p>I have released <a href="http://hackage.haskell.org/package/happstack-fay">happstack-fay on
hackage</a> which
provides the glue code needed for AJAX communication.</p>
<p>In future blog posts I hope to cover three additional topics:</p>
<ol>
<li><p>how to incorporate type-safe routing using <code>web-routes</code></p></li>
<li><p>how to add client-side validation to reform using Fay</p></li>
<li><p>how to use HSX for client-side HTML generation</p></li>
</ol>
<p>We would love to hear your feedback!</p>
Happstack Irregular News Issue #2urn:uuid:8d103025-bad6-41fa-a506-f707cb3652c5stepcut2012-07-02T16:40:29Z<p>Hello! It is I, your editor Jeremy Shaw. I am pleased to bring you
Happstack Irregular News Issue #2. Some exciting things have happened
since the last issue!</p>
<h2>clckwrks</h2>
<p>The biggest news since the last issue is the release of clckwrks:</p>
<p><a href="http://www.clckwrks.com/">clckwrks</a></p>
<p>clckwrks is a Haskell-based blog and CMS framework with support for
editing pages via the browser plus downloadable themes and plugins.</p>
<p>clckwrks is now powering happstack.com and clckwrks.com.</p>
<p>We are currently focusing on making the clckwrks blogging portion
solid. We have moved the official Happstack blog to clckwrks in order
to encourage us to make it better :)</p>
<p>If you want to help out, you can <a href="http://www.clckwrks.com/B/Timeline">browse our bug
list</a> and find something to take
action on. We are more than happy to provide guidance and other
assistance.</p>
<h2>reform</h2>
<p>The other new big release was
<a href="http://www.happstack.com/C/ViewPage/11">reform</a>. <code>reform</code> is a form
generation library that continues in the footsteps of <code>formlets</code> and
<code>digestive-functors <= 0.2</code>. <code>digestive-functors 0.3</code> has gone off to
explore a different direction, and we wanted to continue pushing the
development in this direction. There are still many ideas we can share
between the two libraries. Two changes we want to make in the next
release include:</p>
<ol>
<li><p>switch to <code>Bifunctors</code> package instead of homebrewed
<code>IndexedApplicative</code> (thanks to Leonid Onokhov for pointing that
out). (Another alternative might be <code>index-core</code>, though it does not
yet export the <code>Applicative</code> instances).</p></li>
<li><p>consider using a <code>Free Applicative</code> / <code>Operational Applicative</code> for
implementing the <code>reform</code> applicative instances. <code>digestive functors
0.3</code> does something like this and Jasper Van der Jeugt said it was
very beneficial and we should try it in <code>reform</code> as well.</p></li>
</ol>
<h2>happstack-yui</h2>
<p>Dag Odenhall has released <code>happstack-yui</code>, which makes it easy to use
YUI with Happstack. According the YUI website:</p>
<p>"YUI is a free, open source JavaScript and CSS framework for building richly interactive web applications."</p>
<p><a href="http://www.happstack.com/docs/happstack-yui-7351.4.1/doc/html/happstack-yui/index.html">happstack-yui</a></p>
<p><a href="http://yuilibrary.com/">YUI website</a></p>
<h2>HSX</h2>
<p>Niklas Broberg and I (Jeremy Shaw) did some work on HSX. It now builds
with GHC 7.4 and we also fixed some hidden bugs in
<code>HSX.Transform</code>. One thing we have been experimenting with is a
<code>QuasiQuoter</code> for HSX. A demo version can be found here:</p>
<pre><code>darcs get http://src.seereason.com/hsx-qq/
</code></pre>
<p>The QQ provides an alternative to the <code>trhsx</code> preprocessor and
allows you to write things like:</p>
<pre><code>html :: (XMLGenerator m) => XMLGenT m (XMLType m)
html = [hsx| <p class="foo"><% map toUpper "hello, world!" %></p> |]
</code></pre>
<p>This should be included in the next release of HSX.</p>
<p>The next release of HSX will also contain a major refactoring of the
packages. Mostly we are just planning to move modules into different
packages and divide things up differently. One major benefit of the
new arrangement is that you will no longer be required to install
<code>HJavaScript</code> and <code>HJScript</code> even though you probably never use them.</p>
<h2>Other Minor Fixes</h2>
<ul>
<li><p>changed types in <code>happstack-lite</code> so that <code>serveFile</code> and <code>asContentType</code>
work better together, and added <code>guessContentType</code>, <code>MimeMap</code>, <code>mimeType</code></p></li>
<li><p>patched <code>happstack-jmacro</code> to work with older versions of <code>template haskell</code></p></li>
<li><p>tweaks to <code>ixset.cabal</code> so that it does not require the latest <code>Cabal</code> to build</p></li>
</ul>
<h2>acid-state and hackage2</h2>
<p>I have started research into why hackage2 requires so much RAM to
run. I will be blogging about that separately. I do expect that we can
substantially reduce that amount of RAM it requires. So far I have
uncovered two minor issues:</p>
<ol>
<li><p>it turns out that <code>mapM Lazy.readFile fileList</code> returns the file
contents lazily but opens all the files immediately. This means you
can run out of file descriptors if you have a lot of checkpoints or
event files. A patch has been submitted for <code>acid-state</code> and it will
be fixed in the next release.</p></li>
<li><p><code>acid-state</code> reads the entire checkpoint file into RAM before
decoding it. There are a couple places in the code that cause this to
happen. The first place is in <code>cereal</code>. The <code>getLazyByteString</code>
function does return a lazy <code>ByteString</code>.. but it does it by first
reading a strict <code>ByteString</code> of the required length and then
converting it into a lazy <code>ByteString</code>. Changing the behavior of
<code>getLazyByteString</code> is actually quite difficult, as <code>cereal</code> was
designed to allow for value-level error handling, instead of throwing
async exceptions.</p>
<p>We can probably work around this by using <code>runGetState</code> to get
one-chunk at a time and build the lazy <code>ByteString</code> that way. That
might actually be a lot less hackish than it sounds at first, because
it allows us to explicity detect and handle failure cases and control
how much and when things are read into RAM. Though, at that point, it
starts to feel a bit like enumerators/iteratee/etc. Perhaps we will
switch to <code>pipes</code> at some point in time. <code>pipes</code> provides streaming for
pure (non-IO) values -- which is probably what we want here.</p></li>
</ol>
<h2>ELM</h2>
<p>Evan Czaplicki has been doing a ton of work on ELM recently. As described on the <a href="http://elm-lang.org/">ELM Language Homepage</a>:</p>
<p>"Elm is a type-safe, functional reactive language that compiles to HTML, CSS, and JavaScript."</p>
<p>It is easy to use ELM with Happstack -- no special support is
required. (i.e., we do not need <code>happstack-elm</code>). Vincent Ambo has
created a simple demo here:</p>
<p><a href="https://github.com/tazjin/Elm/tree/master/Examples/elm-happstack">elm-happstack demo</a></p>
<h2>web-routes + Hamlet</h2>
<p>Vincent also wrote a nice blog post showing how to combine <code>web-routes</code>
(type-safe URL routing) with <code>Hamlet</code> (a <code>QuasiQuoter</code> for generating
<code>blaze-html</code> from HTML-like syntax):</p>
<p><a href="http://tazj.in/en/1335123720">Best of both worlds: Using Hamlet and web-routes with Happstack</a></p>
<h2>quasi-quoter for language-css</h2>
<p><code>JMacro</code> is great for creating JavaScript, but we still have a hole
when it comes to generating CSS. The
<a href="http://hackage.haskell.org/package/language-css">language-css</a>
library already contains combinators and a syntax ADT for CSS3.</p>
<p>If it had a parser, then we could also create a syntax-checking
<code>[css| |]</code> <code>QuasiQuoter</code>.</p>
<p>I have discussed the idea with Anton Kholomiov, and he is interested
-- but we could use some one else to help write the parser. If you
love writing parsers, this should be a fun little project.</p>
<h2>happstack.com theme</h2>
<p>Finally, if you could suggest one thing that would make the
happstack.com website nicer that would be awesome. There are four
things we already plan to change:</p>
<ol>
<li><p>use black on white text instead of gray on white</p></li>
<li><p>fix the paragraph width so that paragraphs are around 45em wide.</p></li>
<li><p>fix the grid alignment so that things are properly aligned to the
grid</p></li>
<li><p>add more dates to the pages so that it clear that the site and
project is still active</p></li>
</ol>
<p>If you have other suggestions, we would love to hear them! If you want
to hack on the theme directly, that is even better!</p>
<p>Until next time, happy hacking.</p>
<p><em>Jeremy Shaw</em></p>
ANN: Reformurn:uuid:2a25e596-a38f-11e1-8001-aa0000f54932stepcut2012-05-21T22:13:36Z<p>I am pleased to annouce the release of 'reform'. A full tutorial is available here:</p>
<p><a href="http://www.happstack.com/docs/crashcourse/Reform.html">http://www.happstack.com/docs/crashcourse/Reform.html</a></p>
<p>Reform is an HTML form generation and validation library. It follows
in the footsteps of formlets and digestive-functors <= 0.2. In fact,
much of the code in reform comes from the digestive-functors-0.2 code
base.</p>
<p>Reform is designed to be usuable with a wide variety of Haskell web
servers and templating libraries. You can find the following packages
on hackage:</p>
<ul>
<li>reform - the core library</li>
<li>reform-happstack - support for using reform with the Happstack server</li>
<li>reform-blaze - support for creating forms for blaze-html</li>
<li>reform-hsp - support for creating forms for HSP (another xml/html template library)</li>
</ul>
<p>The source code is available via darcs at:</p>
<p>http://patch-tag.com/r/stepcut/reform</p>
<p>The darcs repo also includes proof-of-concept support for 'Heist'.</p>
<p>Reform will feel very familiar to formlets and digestive-functors <=
0.2 users.</p>
<p>The primary motivation behind this library is to provide a supported
alternative to digestive-functors 0.2 for users that prefer 0.2 over
0.3.</p>
<p>The key new feature in reform is the ability to separate the
validation code from the view generation code. This allows library
authors to provide validators (known as Proofs) which the users can
use when constructing their forms. The proof names appear in the
type-signatures. This allows the library author to ensure that the
value returned by a user created form is not merely the correct type,
but has also passed validation.</p>
<p>The reform-happstack package also provides simple and transparent
Cross-Site Request Forgery (CSRF) protection, using the double-submit
method. This method has some weaknesses. For example, I believe it can
be circumvented if your site is vulnerable to cross-site scripting
(XSS) attacks. If you have suggestions on how to improve the CSRF
protection -- please let us know!</p>
<p>I hope to do a full comparison of reform vs digestive-functors 0.3 vs
yesod forms in a few weeks.</p>
New Official Happstack Blogurn:uuid:5fb7a674-915e-11e1-8001-aa0000f54932stepcut2012-05-21T21:51:38Z<p>I am pleased to announce that the Happstack blog is now hosted on happstack.com.</p>