Yesod Book :: Forms :: AForm

aForm.hs

{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses,
    OverloadedStrings, TypeFamilies #-}
import Yesod
import Yesod.Form.Jquery
import Data.Time (Day)
import Data.Text (Text)
import Control.Applicative ((<$>), (<*>))

data Synopsis = Synopsis

mkYesod "Synopsis" [parseRoutes|
/ RootR GET
/car CarR POST
|]

instance Yesod Synopsis

-- Tells our application to use the standard English messages.
-- If you want i18n, then you can supply a translating function instead.
instance RenderMessage Synopsis FormMessage where
    renderMessage _ _ = defaultFormMessage

-- And tell us where to find the jQuery libraries. We'll just use the defaults,
-- which point to the Google CDN.
instance YesodJquery Synopsis

data Car = Car
    { carModel :: Text
    , carYear :: Int
    }
  deriving Show

carAForm :: AForm Handler Car
carAForm = Car
    <$> areq textField "Model" Nothing
    <*> areq intField "Year" Nothing

carForm :: Html -> MForm Handler (FormResult Car, Widget)
carForm = renderTable carAForm

-- The GET handler displays the form
getRootR :: Handler Html
getRootR = do
    -- Generate the form to be displayed
    (widget, enctype) <- generateFormPost carForm
    defaultLayout [whamlet|
<p>The widget generated contains only the contents of the form, not the form tag itself. So...
<form method=post action=@{CarR} enctype=#{enctype}>
    ^{widget}
    <p>It also doesn't include the submit button.
    <input type=submit>
|]

postCarR :: Handler Html
postCarR = do
    ((result, widget), enctype) <- runFormPost carForm
    case result of
        FormSuccess car -> defaultLayout [whamlet|<p>#{show car}|]
        _ -> defaultLayout [whamlet|
<p>Invalid input, let's try again.
<form method=post action=@{CarR} enctype=#{enctype}>
    ^{widget}
    <input type=submit>
|]

main :: IO ()
main = warp 3000 Synopsis