module HSP.Formlets
( input
, textarea
, file
, label
, hidden
, submit
, password
, checkboxes
, select
, selectMulti
, radio
, div
, span
, withAttrs
, fset
) where
import Control.Arrow (first)
import Control.Applicative (Applicative(pure),(<$>))
import Control.Applicative.Error (Failing(Success), maybeRead')
import Data.Maybe (catMaybes)
import Data.Monoid (Monoid)
import Data.Traversable (sequenceA)
import HSP
import qualified HSX.XMLGenerator as HSX
import Text.Formlets (Form, File, Rect(rectRows, rectCols), check, generalInput, generalInputMulti, input', inputFile, plug, xml)
import Prelude hiding (div, span)
input :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
input = input' (\n v -> [<input type="text" name=n value=v />])
textarea :: (XMLGenerator x, Monad v) => (String -> Rect) -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
textarea calcRect =
input' (\n v ->
let rect = calcRect v
in [ <textarea rows=(rectRows rect) cols=(rectCols rect) name=n ><% v %></textarea> ])
file :: (XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v File
file = inputFile $ \name -> [<input type="file" name=name />]
label :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v ()
label str = xml $ [<label><% str %></label>]
hidden :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
hidden = input' (\n v -> [<input type="hidden" name=n value=v />])
submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v Bool
submit val = (generalInput (\n _ -> [<div><input type="submit" name=n value=val /></div>])) `check`
(\res ->
case res of
Nothing -> pure False
(Just "") -> pure False
_ -> pure True
)
password :: (Monad v, HSX.XMLGenerator x) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
password = input' (\n v -> [<input type="password" name=n value=v />])
checkboxes :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v [a]
checkboxes items = checkboxes' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse checkbox data") strs)
checkboxes' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]
checkboxes' items =
plug (\listItems -> [<ul class="checkboxes"><% listItems %></ul>]) (catMaybes <$> (sequenceA $ map mkCheckbox items))
where
mkCheckbox (val, labelText) =
generalInput (\n mv ->
if mv == (Just val)
then [<li><input type="checkbox" name=n value=val checked="checked"/><% labelText %></li>]
else [<li><input type="checkbox" name=n value=val /> <% labelText %></li>])
radio :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
radio items = radio'' (map (first show) items) `check` checkItem
where
checkItem Nothing = Success Nothing
checkItem (Just str) = Just <$> maybeRead' str ("Could not parse radio data: " ++ str)
radio'' :: (XMLGenerator x, Applicative v, Monad v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)
radio'' items = generalInput (\n mv -> [<ul class="radios"><% concatMap (radioItem n mv) items %></ul>])
radioItem :: (XMLGenerator x) => String -> Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]
radioItem n mv (val, labelText) =
if mv == (Just val)
then [<li><p><input type="radio" name=n value=val checked="checked"/><% labelText %></p></li>]
else [<li><p><input type="radio" name=n value=val /> <% labelText %></p></li>]
select :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => Maybe a -> [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
select defaultSelection items = select' (show <$> defaultSelection) (map (first show) items) `check` checkOption
where
checkOption Nothing = Success Nothing
checkOption (Just str) = Just <$> maybeRead' str ("Could not parse select data: " ++ str)
select' :: (XMLGenerator x, Applicative v, Monad v) => Maybe String -> [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)
select' defaultSelection items = generalInput (\n mv -> [<select name=n><% concatMap (selectOption (maybe defaultSelection Just mv)) items %></select>])
selectOption :: (XMLGenerator x) => Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]
selectOption mv (val, labelText) =
if mv == (Just val)
then [<option value=val selected="selected"><% labelText %></option>]
else [<option value=val ><% labelText %></option>]
selectMulti :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v [a]
selectMulti items = selectMulti' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse select data") strs)
selectMulti' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]
selectMulti' items =
generalInputMulti $ \name selectedValues ->
[<select name=name multiple="multiple">
<% mapM (mkOption selectedValues) items %>
</select>]
where
mkOption selectedValues (value, label)
| value `elem` selectedValues =
[<option value=value selected="selected"><% label %></option>]
| otherwise =
[<option value=value ><% label %></option>]
div :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b
div c frm = (\ xml -> [<div class=c><% xml %></div>]) `plug` frm
span :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b
span c frm = (\ xml -> [<span class=c><% xml %></span>]) `plug` frm
withAttrs :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a -> Form [XMLGenT x (HSX.XML x)] v a
withAttrs attrs = plug (map (`set` attrs))
fset :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v a -> [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a
fset = flip withAttrs