Created
July 19, 2018 11:35
-
-
Save nmk/ffe31e6a0af7784112f4532e31d9ab99 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment