gistfile1.lhs

> {-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}
> import Control.Applicative ((<$>), (<*>), pure)
> import Snap.Types
> import Snap.Http.Server (httpServe, defaultConfig)

> import Text.Blaze (Html, (!), string)
> import qualified Text.Blaze.Html5 as H
> import qualified Text.Blaze.Html5.Attributes as A
> import Text.Blaze.Renderer.Utf8 (renderHtml)

> import Text.Digestive.Types
> import Text.Digestive.Blaze.Html5
> import Text.Digestive.Forms.Snap
> import Text.Digestive.Validate

> import Text.Digestive.Transform

> import Text.Digestive.Forms.Html

The name of a place, and some tags.

> data Place = Place String [String]
>     deriving (Show)

> placeFormlet :: (MonadSnap m) => Maybe Place -> SnapForm m Html BlazeFormHtml Place
> placeFormlet def = Place <$> label "Name" ++> inputText Nothing <*> inputList' listCounter inputText Nothing

> placesForm :: (MonadSnap m) => SnapForm m Html BlazeFormHtml [Place]
> placesForm = inputList' listCounter placeFormlet Nothing

> requiredScripts :: Html
> requiredScripts = do
>     H.script ! A.type_ "text/javascript" ! A.src
>              "https://ajax.googleapis.com/ajax/libs/jquery/1.4.4/jquery.js"
>              $ return ()
>     H.script ! A.type_ "text/javascript" $ string inputListJs

Some code to render blaze templates:

> blaze :: Html -> Snap ()
> blaze response = do
>     modifyResponse $ addHeader "Content-Type" "text/html; charset=UTF-8"
>     writeLBS $ renderHtml response

Now, all we have to do is create a `Snap` handler to serve this form.

> weightedSumHandler :: Snap ()
> weightedSumHandler = do

Here, the digestive magic works. We will evaulate the form on a `POST` request,
and view the form on a `GET` request.

>     r <- eitherSnapForm placesForm "place-form"
>     case r of

If we get a form back, something went wrong, or the user just wants to view the
form. Either case, we just render the form using blaze.

>         Left form' -> blaze $ do
>             let (formHtml', enctype) = renderFormHtml form'
>             requiredScripts
>             H.style ! A.type_ "text/css" $ do
>                   "input {display: block;}\n"
>                   ".digestive-error-list {\n"
>                   "    color: white;\n"
>                   "    background-color: rgb(100, 0, 0);\n"
>                   "}"
>             H.h1 "Enter the names of places and some tags"
>             H.form ! A.enctype (H.stringValue $ show enctype)
>                    ! A.method "POST" ! A.action "/" $ do
>                 formHtml'
>                 H.input ! A.type_ "submit" ! A.value "Submit"

>         Right places -> blaze $ do
>             H.h1 "HUGE SUCCES"
>             H.p $ do
>                 H.strong $ "Result: "
>                 H.string $ show $ places

> main :: IO ()
> main = httpServe defaultConfig weightedSumHandler