[improvements to example/happs-hsp
jeremy@n-heptane.com**20080831232132] {
hunk ./HSP/Formlets.hs 11
+import Data.List
hunk ./HSP/Formlets.hs 17
-import HAppS.Server (Response,ServerPart,Method(POST,GET), method, withDataFn, lookPairs, dir, ok, WebT(..), toResponse, simpleHTTP, nullConf, validateConf, waitForTermination, Result(..), multi, anyRequest)
+-- import HAppS.Server (Response,ServerPart,Method(POST,GET), method, withDataFn, lookPairs, dir, ok, WebT(..), toResponse, simpleHTTP, nullConf, validateConf, waitForTermination, Result(..), multi, anyRequest)
hunk ./HSP/Formlets.hs 28
--- input :: (Monad v, Monad x) => Maybe String -> Form [XMLGenT (HSPT' x) XML] v String
hunk ./HSP/Formlets.hs 31
+-- |An input text area with optional value
+textarea :: (Monad v, HSX.XMLGenerator x) => Maybe String -> FormHSXT x v String
+textarea = input' (\n v -> [])
+
hunk ./HSP/Formlets.hs 50
+
+
+-- | A radio choice
+radio :: (Monad v, HSX.XMLGenerator x) => [(String, String)] -> Maybe String -> FormHSXT x v String
+radio choices = input' mkRadios -- todo: validate that the result was in the choices
+ where radio n v i True =
+ radio n v i False =
+ mkRadios name selected = concatMap (mkRadio name selected) (zip choices [1..])
+ mkRadio name selected ((value, label), idx) =
+ [ (radio name value ident (selected == value)) -- ! attrs
+ ,
+ ]
+ where
+ ident = name ++ "_" ++ show idx
+
+
+-- | An radio choice for Enums
+enumRadio :: (Enum a, Monad v, HSX.XMLGenerator x) => [(a, String)] -> Maybe a -> FormHSXT x v a
+enumRadio values defaultValue = radio (map toS values) (fmap (show . fromEnum) defaultValue)
+ `check` convert `check` tryToEnum
+ where toS = fmapFst (show . fromEnum)
+ convert v = maybeRead' v "Conversion error"
+
+
+selectRaw :: (Monad v, HSX.XMLGenerator x) => [(String, String)] -> Maybe String -> FormHSXT x v String
+selectRaw choices = input' mkChoices -- todo: validate that the result was in the choices
+ where mkChoices name selected =
+ [
+ ]
+ mkChoice selected (value, label)
+ | selected == value = -- X.option ! (attrs ++ [X.value value]) << label
+ | otherwise =
+
+-- | A drop-down for anything that is an instance of Eq
+select :: (Eq a, Monad v, HSX.XMLGenerator x) => [(a, String)] -> Maybe a -> FormHSXT x v a
+select ls v = selectRaw (map f $ zip [0..] ls) selected `check` asInt `check` convert
+ where selected = show <$> (v >>= flip elemIndex (map fst ls))
+ f (idx, (_,l)) = (show idx, l)
+ convert i | i >= length ls || i < 0 = Failure ["Out of bounds"]
+ | otherwise = Success $ fst $ ls !! i
+ asInt s = maybeRead' s (s ++ " is not a valid int")
hunk ./examples/happs-hsp/Index.hs 29
-createForm :: (HSX.XMLGenerator x, Monad m) => Env -> String -> String -> [String] -> Form (XMLGenT x (HSX.XML x)) m a -> XMLGenT x (HSX.XML x)
+createForm :: (HSX.XMLGenerator x, Monad m) => Env -> String -> String -> [String] -> Form [XMLGenT x (HSX.XML x)] m a -> XMLGenT x (HSX.XML x)
hunk ./examples/happs-hsp/Index.hs 49
-page :: (EmbedAsChild m [Char], EmbedAsChild m xml) =>
- Form xml m1 a -> Form (XMLGenT m (HSX.XML m)) m1 a
-page form = template `plug` form
- where
- template xml =
-
-
- HAppS + HSP + Formlets
-
-
- <% xml %>
-
-
+page :: (EmbedAsChild x String, EmbedAsChild x c) => c -> XMLGenT x (HSX.XML x)
+page xml =
+
+
+ HAppS + HSP + Formlets
+
+
+ <% xml %>
+
+
hunk ./examples/happs-hsp/Index.hs 60
-inputPage :: Form (XMLGenT Identity XML) IO String
-inputPage = page (input Nothing <* (submit "go!"))
+inputFrm :: Form [XMLGenT Identity XML] IO String
+inputFrm = input Nothing <* (submit "go!")
hunk ./examples/happs-hsp/Index.hs 63
-datePage :: (HSX.XMLGenerator x, Monad m, Applicative m) => Form (XMLGenT x (HSX.XML x)) m Date
-datePage = page dateFull
+dateForm :: (HSX.XMLGenerator x, Monad v, Applicative v) =>
+ Form [XMLGenT x (HSX.XML x)] v Date
+dateForm =
+ (\x -> [
<% x %>
]) `plug` dateFull
+
+selectForm :: Form [XMLGenT Identity XML] IO String
+selectForm =
+ let fruit = ["apple", "banana", "coconut" ]
+ in
+ (\x -> [
<% x %>
]) `plug` (select (zip fruit fruit) (Just "banana") <* submit "Drink Up!")
+
+{-
hunk ./examples/happs-hsp/Index.hs 79
+-}
hunk ./examples/happs-hsp/Main.hs 1
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}
hunk ./examples/happs-hsp/Main.hs 45
- toMessage xml = L.fromString (renderAsHTML xml)
+ toMessage xml = toMessage (html4Strict, xml) -- L.fromString (renderAsHTML xml)
hunk ./examples/happs-hsp/Main.hs 60
- do tid <- forkIO $ simpleHTTP nullConf $ impl
+ do tid <- forkIO $ simpleHTTP validateConf $ impl
hunk ./examples/happs-hsp/Main.hs 64
+ putStrLn "shutting down..."
hunk ./examples/happs-hsp/Main.hs 67
-impl = handleForm "prefix" "/" (datePage :: Form (XMLGenT Identity XML) IO Date) (ok . toResponse . show)
+impl = [ dir "date" $ handleForm "prefix" "/date" page dateForm (ok . toResponse . show)
+ , dir "select" $ handleForm "prefix" "/select" page selectForm (ok . toResponse)
+ , method GET $
+ ok (toResponse
+ (evalIdentity
+ (
+
+ Index of HAppS+HSP+Formlets examples
+
+
+