{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, RecordWildCards #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import Control.Applicative import Control.Monad import qualified Data.ByteString.Char8 as C import Text.Blaze ((!), Html) import Text.Formettes import Text.Formettes.HSP import Text.Formettes.Happstack import HSP.ServerPartT import Happstack.Server import Happstack.Server.HSP.HTML instance FormError String where type ErrorInputType String = [Input] commonFormError = show data Greek = Greek { alpha :: Bool , beta :: Bool , gamma :: Bool } deriving (Show) greek :: Greek -> Form (ServerPartT IO) [Input] String [XMLGenT (ServerPartT IO) XML] () Greek greek Greek{..} = Greek <$> (label "α" ++> inputCheckbox alpha) <*> (label "β" ++> inputCheckbox beta) <*> (label "γ" ++> inputCheckbox gamma) data Vice = Sex | Drugs | RockAndRoll deriving (Show, Eq, Enum) vices :: [Vice] -> Form (ServerPartT IO) [Input] String [XMLGenT (ServerPartT IO) XML] () [Vice] vices vs = inputCheckboxes $ map mkVice [Sex .. RockAndRoll] where mkVice v = (v, show v, v `elem` vs) vices2 :: [Vice] -> Form (ServerPartT IO) [Input] String [XMLGenT (ServerPartT IO) XML] () [Vice] vices2 vs = inputMultiSelect $ map mkVice [Sex .. RockAndRoll] where mkVice v = (v, show v, v `elem` vs) data Stars = OneStar | TwoStars | ThreeStars | FourStars | FiveStars deriving (Eq, Enum) instance Show Stars where show OneStar = "★" show TwoStars = "★★" show ThreeStars = "★★★" show FourStars = "★★★★" show FiveStars = "★★★★★" stars :: Stars -> Form (ServerPartT IO) [Input] String [XMLGenT (ServerPartT IO) XML] () (Maybe Stars) stars def = inputRadio (== def) [(s, show s) | s <- [OneStar .. FiveStars]] hsxForm :: (XMLGenerator x) => [XMLGenT x (XMLType x)] -> [XMLGenT x (XMLType x)] hsxForm html = [] formHandler :: (EmbedAsChild (ServerPartT IO) error, Show a) => Form (ServerPartT IO) [Input] error [XMLGenT (ServerPartT IO) XML] proof a -> ServerPart Response formHandler form = msum [ do method GET formHtml <- viewForm "user" form html <- unXMLGenT $ <% hsxForm $ formHtml %> ok $ toResponse $ html , do method POST (view, r) <- runForm' "user" environment form case r of (Just a) -> do html <- unXMLGenT $ <% show a %> <% hsxForm $ view %> ok $ toResponse $ html Nothing -> do html <- unXMLGenT $ <% hsxForm $ view %> ok $ toResponse $ html ] main :: IO () main = do let greekForm = (greek $ Greek False True False) viceForm = vices [Sex, RockAndRoll] vice2Form = vices2 [Sex, RockAndRoll] starsForm = stars TwoStars simpleHTTP nullConf $ do decodeBody (defaultBodyPolicy "/tmp" 0 10000 10000) formHandler starsForm