Haskell on a Horse
==================
<style>
body{ margin-left:40px; margin-right: 15%; text-align: justify; }
.error{ color: red; }
h1,h2 { font-family; sans-serif; font-weight: normal; color: #222; }
h1{ font-size: 22pt; border-bottom: double }
h2{ font-size: 18pt; border-bottom: 3px dotted }
.oper{ border: 1px solid; padding: 4px; }
.sourceCode{ background-color: #eee; border: 1px dotted #666;
padding: 8px; width: 100%; }
.example{ background-color: #eee; width: 100%;
border-collapse: collapse; }
.example td { border: 1px dotted #666; padding: 8px; }
.example .sourceCode{ border: none; padding: 0; }
</style>
Haskell on a Horse (HoH) is a combinatorial web framework for the
programming language Haskell. It is currently at an early, unsettled
stage of development. It is available under the "BSD3" open-source
license.
Installing and Using HoH
------------------------
cabal install on-a-horse
> {-#LANGUAGE Arrows, QuasiQuotes, ScopedTypeVariables #-}
> import Web.Horse
> import Control.Applicative
> import Control.Arrow
> import Control.Monad
> import Control.Monad.Cont
> import Data.Maybe
> import Data.Monoid
> import Data.List.Split (splitOn)
> import Control.Arrow.Transformer.All
> import Text.Pandoc
Atomic Components
-------------------
An HoH application is built up from atomic components. A component is
a complete HoH application all by itself: it can render itself, and
respond to input.
<table class="example"><tr><td>
>
> ex1 = proc url -> do
> (fo,num::Maybe Integer) <- readForm "enter a number" -< ()
> returnA -< wrapForm fo
>
</td><td>EXAMPLE</td></tr></table>
run this as a web app on port 8080 using
~~~~~~~~{.haskell}
main = runHorse ex1
~~~~~~~~
Side-by-Side Components
--------------------------
Components can be rendered side-by-side within a page.
<table class=example><tr><td>
> ex2 :: HoH Url (Html ())
> ex2 = proc url -> do
> (fo1, oper) <- enumForm "operation"
> [("times", (*)),
> ("plus", (+))] -< ()
> (fo2, x::Maybe Integer) <- readForm "x" -< ()
> (fo3, y::Maybe Integer) <- readForm "y" -< ()
> let result = show <$> (oper <*> x <*> y)
> runHamlet -< [$hamlet|
> %form!method=POST!action=""
> Calculate a number!
> %br
> $fo1$ $fo2$ $fo3$
> Result:
> $maybe result res
> $res$
> %br
> %input!type=submit |]
</td><td>EXAMPLE</td></tr></table>
Replacing one Component With Another
---------------------------------------
Components can be replaced. A call to the arrow `throwAuto` will
replace the nearest enclosing `catchAuto`. The new component will be
called immediately, with no form input.
~~~~~~{.haskell}
formSum label fs def = catchAuto $ proc _ -> do
(fo,f) <- enumForm label fs -< ()
case f of
Just f' -> throwAuto -< f'
Nothing -> returnA -< setFormOut fo def
~~~~~~
Note: `def` is a default value to be used when no form is yet
selected.
<table class=example><tr><td>
> ex3 :: HoH Url (Html ())
> ex3 = formSum "example to run" [("example 1",ex1),("example 2",ex2)] mempty
> >>> arr wrapForm
</td><td>EXAMPLE</td></tr></table>
A More Complex Example
-------------------------
By combining the techniques above, sophisticated pages can be made
with little code.
<table class=example><tr><td>
> ex4 = proc url -> do
> (fo,result) <- term "expression" -< ()
> runHamlet -< [$hamlet|
> %form!method=POST!action=""
> $fo$
> Result:
> $maybe result res
> $show res$
> %input!type=submit
> %br |]
> where
> term :: String -> HoH () (FormOut, Maybe Integer)
> term label = catchAuto $ formSum label
> [("number", number label),
> ("add",oper label "add" (+)),
> ("multiply",oper label "multiply" (*))] (mempty, Nothing)
>
> number :: String -> WithError (HoH () (FormOut, Maybe Integer))
> () (FormOut, Maybe Integer)
> number termLabel = proc () -> do
> fo1 <- linkForm "cancel" (term termLabel) -< ()
> (fo2,x) <- readForm "number" -< ()
> returnA -< (fo1 `mappend` fo2, x)
>
> oper termLabel label f = proc () -> do
> (fo1) <- linkForm "cancel" (term termLabel) -< ()
> (fo2,x) <- liftError (term "x") -< ()
> (fo3,y) <- liftError (term "y") -< ()
> out <- runHamlet -< [$hamlet|
> %div.oper
> $fo1$
> $label$
> %br
> $fo2$ $fo3$ |]
> returnA -< (out, f <$> x <*> y)
</td><td>EXAMPLE</td></tr></table>
Notes:
* `throwAuto` works by adding an ErrorArrow to its argument.
When it is called recursively, as in the example above, `liftError`
may be required to avoid an infinite type.
* `linkForm` acts much like `throwAuto`, except that it waits to throw
its argument until the link it renders has been clicked.
Building Atomic Components
-------------------------
Atomic components should generally use the 'withInput' function. This
will add two inputs to an arrow: the first is a unique label for the
component, and the second is the current input to the arrow, or
Nothing if there is no input. The label should be used as a name in
any form input or query parameters. Here is the code for `linkForm`.
~~~~~~{.haskell}
linkForm linkName f = withInput $ proc ((),nm,iname) -> do
case iname of
Just _ -> throwAuto -< f
Nothing -> returnA -< (link linkName nm)
~~~~~~
(`link "name" "label"` produces `<a href="?label=1">name</a>`)
Handling urls
-------------
`runHorse` sends the URL as the sole argument to the handler. A
function, `dispatch`, is available to construct multi-page
applications.
<table class="example"><tr><td>
> ex5 = proc url -> do
> (dispatch $ staticUrls fourOhFour $
> [("", urls),
> ("ex1", ex1),
> ("ex2", ex2),
> ("ex3", ex3),
> ("ex4", ex4)]) -< (url,url)
</td><td>EXAMPLE</td></tr></table>
> fourOhFour = proc url -> do
> runHamlet -< [$hamlet| Page not found |]
> urls = proc url -> do
> runHamlet -< [$hamlet|
> %a!href=ex1 example 1
> %br
> %a!href=ex2 example 2
> %br
> %a!href=ex3 example 3
> %br
> %a!href=ex4 example 4
> %br
> %a!href=ex5 example 5
> %br |]
>
Running the Tutorial
--------------------
This tutorial is a sort of self-executing markdown (pandoc) file.
This is the code to run it.
> main = do
> tut <- readFile "tutorial.lhs"
> tmpl <- getDefaultTemplate Nothing "html"
> let pd = readMarkdown defaultParserState{ stateLiterateHaskell=True } tut
> let tut' = writeHtmlString defaultWriterOptions{
> writerStandalone=True,
> writerTemplate= either (error . show) id tmpl
> } pd
> let ts = map preEscapedString $ splitOn ("EXA"++"MPLE") tut'
> runHorse $ proc url -> do
> fo1 <- ex1 -< url
> fo2 <- ex2 -< url
> fo3 <- ex3 -< url
> fo4 <- ex4 -< url
> fo5 <- ex5 -< url
> let vals = interleave ts [fo1,fo2,fo3,fo4,fo5]
> runHamlet -< [$hamlet|
> $forall vals val
> $val$ |]
> interleave (x:xs) (y:ys) = (x:y:interleave xs ys)
> interleave [] ys = ys
> interleave xs [] = xs
<b>
> -- Jason Hart Priestley, July 26, 2010. (jason @ this domain)
</b>