SelectionTest.hs

#!/usr/bin/env stack
-- stack --resolver lts-11.15 script --package text --package yesod

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

module SelTest where

import           Control.Arrow ((&&&))
import           Data.Text     (Text, pack)
import           Prelude
import           Yesod

data App = App

data Fruit = Apple | Banana | Coconut deriving (Show, Eq, Bounded, Enum)

data FormData = FormData
  { foo :: Int
  , bar :: Int
  , baz :: Fruit
  } deriving (Show)

mkYesod "App" [parseRoutes|
  / HomeR GET POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
  renderMessage _ _ = defaultFormMessage

form :: Html -> MForm Handler (FormResult FormData, Widget)
form = renderDivs $ FormData
   <$> areq (check checkRange intField) "Entering Int: " Nothing
   <*> areq (check checkRange (selectField options)) "Selecting Int: " Nothing
   <*> areq (check checkFruit (selectField optionsEnum)) "Selecting enum: " Nothing
  where
    options = optionsPairs (map (pack . show &&& id) [1..10])

checkFruit :: Fruit -> Either Text Fruit
checkFruit Banana = Left "no bananas please"
checkFruit x      = Right x

checkRange :: Int -> Either Text Int
checkRange n | n < 3 || n > 7 = Left "out of range"
             | otherwise = Right n

getHomeR, postHomeR :: Handler Html
getHomeR = postHomeR
postHomeR = do
  ((result, widget), enctype) <- runFormPost form
  case result of
    FormSuccess formData -> defaultLayout [whamlet|<p>#{show formData}|]
    _ -> defaultLayout
        [whamlet|
          <p>Invalid input, let's try again.
          <form method=post action=@{HomeR} enctype=#{enctype}>
            ^{widget}
            <button>Submit
        |]

main = warp 3040 App