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 :: [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 checkFruits (checkboxesField optionsEnum)) "Selecting fruits: " Nothing

checkFruits :: [Fruit] -> Either Text [Fruit]
checkFruits xs | Banana `elem` xs = Left "no bananas allowed"
               | otherwise        = Right xs

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