formlets 0.6.1 → 0.8
raw patch · 7 files changed
Files
- LICENSE +0/−2
- README +5/−3
- Text/Blaze/Html5/Formlets.hs +169/−0
- Text/Formlets.hs +170/−47
- Text/Formlets/MassInput.hs +3/−0
- Text/XHtml/Transitional/Formlets.hs +109/−0
- formlets.cabal +19/−11
LICENSE view
@@ -1,5 +1,3 @@-Copyright (c) 2008, Tupil- All rights reserved. Redistribution and use in source and binary forms, with or without
README view
@@ -1,8 +1,10 @@-The original author of this library is Jeremy Yallop. It is currently maintained-by Chris Eidhof.+The original author of this library is Jeremy Yallop. It was packaged by Chris+Eidhof, and is currently maintained by Doug Beardsley. Other contributors:-* MightyByte * Eelco Lempsink+* Jeremy Shaw+* Judah Jacobson+* Jasper Van der Jeugt The formlets repository is hosted on github: http://github.com/chriseidhof/formlets/
+ Text/Blaze/Html5/Formlets.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Blaze.Html5.Formlets+ ( input+ , textarea+ , password+ , hidden+ , inputInteger+ , file+ , checkbox+ , radio+ , enumRadio+ , label+ , selectHtml+ , selectRaw+ , select+ , Html5Form+ , Html5Formlet+ , module Text.Formlets+ ) where++import Data.List (elemIndex)+import Text.Formlets hiding (massInput)+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Data.Monoid (mconcat)++import Control.Applicative+import Control.Applicative.Error++type Html5Form m a = Form H.Html m a+type Html5Formlet m a = Formlet H.Html m a++-- | An input field with an optional value+--+input :: Monad m => Html5Formlet m String+input = input' $ \n v -> H.input ! A.type_ "text"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)+ ! A.value (H.stringValue v)++-- | A textarea with optional rows and columns, and an optional value+--+textarea :: Monad m => Maybe Int -> Maybe Int -> Html5Formlet m String+textarea r c = input' $ \n v -> (applyAttrs n H.textarea) (H.string v)+ where+ applyAttrs n = (! A.name (H.stringValue n)) . rows r . cols c+ rows = maybe id $ \x -> (! A.rows (H.stringValue $ show x))+ cols = maybe id $ \x -> (! A.cols (H.stringValue $ show x))++-- | A password field with an optional value+--+password :: Monad m => Html5Formlet m String+password = input' $ \n v -> H.input ! A.type_ "password"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)+ ! A.value (H.stringValue v)++-- | A hidden input field+--+hidden :: Monad m => Html5Formlet m String+hidden = input' $ \n v -> H.input ! A.type_ "hidden"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)+ ! A.value (H.stringValue v)++-- | A validated integer component+--+inputInteger :: Monad m => Html5Formlet m Integer+inputInteger x = input (fmap show x) `check` asInteger++-- | A file upload form+--+file :: Monad m => Html5Form m File+file = inputFile $ \n -> H.input ! A.type_ "file"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)++-- | A checkbox with an optional default value+--+checkbox :: Monad m => Html5Formlet m Bool+checkbox d = (optionalInput (html d)) `check` asBool+ where+ asBool (Just _) = Success True+ asBool Nothing = Success False+ html (Just True) n = H.input ! A.type_ "checkbox" + ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)+ ! A.value "on"+ ! A.checked "checked"+ html _ n = H.input ! A.type_ "checkbox"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue n)+ ! A.value "on"++-- | A radio choice+--+radio :: Monad m => [(String, String)] -> Html5Formlet m String+radio choices = input' $ \n v ->+ mconcat $ map (makeRadio n v) $ zip choices [1 :: Integer ..]+ -- todo: validate that the result was in the choices+ where+ makeRadio name selected ((value, label'), idx) = do+ applyAttrs (radio' name value id')+ H.label ! A.for (H.stringValue id')+ ! A.class_ "radio"+ $ H.string label'+ where+ applyAttrs | selected == value = (! A.checked "checked")+ | otherwise = id+ id' = name ++ "_" ++ show idx++ radio' n v i = H.input ! A.type_ "radio"+ ! A.name (H.stringValue n)+ ! A.id (H.stringValue i)+ ! A.class_ "radio"+ ! A.value (H.stringValue v)++-- | An radio choice for Enums+--+enumRadio :: (Monad m, Enum a) => [(a, String)] -> Html5Formlet m a+enumRadio values defaultValue =+ radio (map toS values) (show . fromEnum <$> defaultValue)+ `check` convert `check` tryToEnum+ where+ toS = fmapFst (show . fromEnum)+ convert v = maybeRead' v "Conversion error"++-- | A label+--+label :: Monad m => String -> Form H.Html m ()+label = xml . H.label . H.string++-- | This is a helper function to generate select boxes+--+selectHtml :: [(String, H.Html)] -- ^ The values and their labels+ -> String -- ^ The name+ -> String -- ^ The value that is selected+ -> H.Html+selectHtml choices name selected =+ H.select ! A.name (H.stringValue name)+ $ mconcat $ map makeChoice choices+ where+ makeChoice (value, label') = applyAttrs $+ H.option ! A.value (H.stringValue value) $ label'+ where+ applyAttrs | selected == value = (! A.selected "selected")+ | otherwise = id++-- | A drop-down for selecting values+--+selectRaw :: (Monad m)+ => [(String, H.Html)] -- ^ Pairs of value/label+ -> Html5Formlet m String -- ^ Resulting formlet+selectRaw = input' . selectHtml -- todo: validate that result was in choices++-- | A drop-down for anything that is an instance of Eq+--+select :: (Eq a, Monad m)+ => [(a, H.Html)] -- ^ Pairs of value/label+ -> Html5Formlet m a -- ^ Resulting formlet+select ls v = selectRaw (map f $ zip [0 :: Integer ..] 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")
Text/Formlets.hs view
@@ -1,19 +1,24 @@-module Text.Formlets ( input', inputM', optionalInput, inputFile, fmapFst, nothingIfNull+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module Text.Formlets ( input', inputM', optionalInput, generalInput, generalInputMulti, inputFile, fmapFst, nothingIfNull , check, ensure, ensures , ensureM, checkM, pureM , runFormState , massInput- , xml, plug, plug'+ , xml, plug, plug2, plug' , Env , Form , Formlet , File (..), ContentType (..), FormContentType (..)+ , Rect (..), stringRect ) where +import Data.Generics+import Data.Either (partitionEithers) import Data.Monoid import Control.Applicative import Control.Applicative.Error-import Control.Applicative.State-import Data.Maybe (isJust)+import Control.Monad+import Control.Monad.Trans.State+import Data.Maybe (isJust, fromMaybe) import Data.List (intercalate) import qualified Text.Formlets.FormResult as FR import qualified Data.ByteString.Lazy as BS@@ -27,14 +32,25 @@ type S a = State FormState a type Validator a = S (FR.FormResult a) data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read)-newtype Form xml m a = Form { deform :: Env -> S (m (Validator a), m xml, FormContentType) }-data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read)+newtype Form xml m a = Form { deform :: Env -> S (m (Validator a), xml, FormContentType) }+data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read, Data, Typeable) data ContentType = ContentType { ctType :: String , ctSubtype :: String , ctParameters :: [(String, String)] }- deriving (Eq, Show, Read)+ deriving (Eq, Show, Read, Data, Typeable)+ +data Rect = Rect {rectCols :: Int, rectRows :: Int}+ deriving (Eq, Ord, Show, Read, Data, Typeable) +-- |Choose a good number of rows for a textarea input. Uses the+-- number of newlines in the string and the number of lines that+-- are too long for the desired width.+stringRect :: Int -> String -> Rect+stringRect cols s =+ Rect {rectCols = cols,+ rectRows = foldr (+) 0 (map (\ line -> 1 + (length line) `div` cols) (lines s))}+ -- | Apply a predicate to a value and return FR.Success or FR.Failure as appropriate ensure :: Show a => (a -> Bool) -- ^ The predicate@@ -62,34 +78,122 @@ where errors = [ err | (p, err) <- ps, not $ p x ] -- | Helper function for genereting input components based forms.-input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String-input' i = inputM' (\n -> return . i n)+-- +-- see also 'optionalInput', 'generalInput', and 'generalInputMulti'+input' :: Monad m + => (String -> String -> xml) -- ^ function which takes the control name, the initial value, and returns the control markup+ -> Maybe String -- ^ optional default value+ -> Form xml m String+input' i defaultValue = generalInput' i' fromLeft -- `check` maybe (Failure ["not in the data"]) Success+ where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v)+ fromLeft n Nothing = FR.NotAvailable $ n ++ " is not in the data"+ fromLeft n (Just (Left x)) = FR.Success x+ fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."] -inputM' :: Monad m => (String -> String -> m xml) -> Maybe String -> Form xml m String-inputM' i defaultValue = Form $ \env -> mkInput env <$> freshName- where mkInput env name = (lookupFreshName fromLeft env, i name (value name env), UrlEncoded)- value name env = maybe (maybe "" id defaultValue) fromLeft' (lookup name env)- fromLeft' (Left x) = x- fromLeft' _ = ""- fromLeft n Nothing = FR.NotAvailable $ n ++ " is not in the data"- fromLeft n (Just (Left x)) = FR.Success x- fromLeft n _ = FR.Failure [n ++ " is a file."]+{-# DEPRECATED inputM' "You can just use input'"#-}+-- |deprecated. See 'input''+inputM' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String+inputM' = input' +-- | Create a form control which is not required to be successful+--+-- There is no way to provide a default value, because that would+-- result in the control being successful.+-- +-- For more information on successful controls see:+--+-- <http://www.w3.org/TR/html401/interact/forms.html#successful-controls>+--+-- see also 'input'', 'generalInput', and 'generalInputMulti'+optionalInput :: Monad m + => (String -> xml) -- ^ function which takes the form name and produces the control markup+ -> Form xml m (Maybe String)+optionalInput i = generalInput' (\n _ -> i n) fromLeft+ where+ fromLeft n Nothing = FR.Success Nothing+ fromLeft n (Just (Left x)) = FR.Success (Just x)+ fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."]++-- |generate a form control+-- +-- see also 'input'', 'optionalInput', 'generalInputMulti'.+generalInput :: Monad m =>+ (String -> Maybe String -> xml) -- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup+ -> Form xml m (Maybe String)+generalInput i = generalInput' (\n v -> i n v) fromLeft+ where+ fromLeft n Nothing = FR.Success Nothing+ fromLeft n (Just (Left x)) = FR.Success (Just x)+ fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."]++-- a combination of lookup and freshName. +-- 1. generate a fresh name+-- 2. lookup that name in the environment (returns a Maybe value)+-- 3. pass the name and the Maybe value to the function 'f', which returns a value of type 'a'+lookupFreshName :: (Monad m) => (String -> Maybe (Either String File) -> a) -> Env -> m (State FormState a) lookupFreshName f env = return $ (freshName >>= \name -> return $ f name $ (lookup name env)) -optionalInput :: Monad m => (String -> xml) -> Form xml m (Maybe String)-optionalInput i = Form $ \env -> mkInput env <$> freshName- where mkInput env name = (lookupFreshName fromLeft env, return (i name), UrlEncoded)- fromLeft n Nothing = FR.Success Nothing- fromLeft n (Just (Left x)) = FR.Success (Just x)- fromLeft n _ = FR.Failure [n ++ " could not be recognized."]+-- |generate a form control+-- +-- see also 'input'', 'optionalInput', 'generalInputMulti'.+generalInput' :: Monad m =>+ (String -> Maybe String -> xml) -- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup+ -> (String -> Maybe (Either String File) -> FR.FormResult a)+ -> Form xml m a+generalInput' i fromLeft = Form $ \env -> mkInput env <$> freshName+ where mkInput env name = (lookupFreshName fromLeft env, -- return . result name,+ i name (value name env), UrlEncoded)+ -- A function to obtain the initial value used to compute the+ -- representation. The environment is the one passed to+ -- runFormState. It typically reflects the initial value of+ -- the datatype which the form is meant to represent.+ value name env =+ case lookup name env of+ Just (Left x) -> Just x+ Just (Right _) -> error $ name ++ " is a file."+ Nothing -> Nothing+ -- A function to obtain the form's return value from the+ -- environment returned after the form is run. +-- |generate a form control which can return multiple values+--+-- Useful for controls such as checkboxes and multiple select .+--+-- see also 'input'', 'optionalInput', 'generalInput'.+generalInputMulti :: forall m xml. Monad m =>+ (String -> [String] -> xml)+ -> Form xml m [String]+generalInputMulti i = Form $ \env -> mkInput env <$> freshName+ where mkInput :: Env -> String -> (m (Validator [String]), xml, FormContentType)+ mkInput env name = (return (result env),+ i name (value name env), UrlEncoded)+ -- A function to obtain the initial value used to compute the+ -- representation. The environment is the one passed to+ -- runFormState. It typically reflects the initial value of+ -- the datatype which the form is meanto to represent.+ value :: String -> Env -> [String]+ value name env =+ case partitionEithers $ lookups name env of+ (xs,[]) -> xs+ _ -> error $ name ++ " is a file."+ -- A function to obtain the form's return value from the+ -- environment returned after the form is run.+ result :: Env -> Validator [String]+ result env =+ do name <- freshName+ return $ case partitionEithers $ lookups name env of+ ([],[]) -> FR.NotAvailable $ name ++ " is not in the data."+ (xs,[]) -> FR.Success xs+ _ -> FR.Failure [name ++ " is a file."]+ lookups :: (Eq a) => a -> [(a, b)] -> [b]+ lookups k = map snd . filter ((k ==) . fst)+ -- | A File input widget. inputFile :: Monad m => (String -> xml) -- ^ Generates the xml for the file-upload widget based on the name -> Form xml m File inputFile i = Form $ \env -> mkInput env <$> freshName- where mkInput env name = (lookupFreshName fromRight env, return (i name), MultiPart)+ where mkInput env name = (lookupFreshName fromRight env, i name, MultiPart) fromRight n Nothing = FR.NotAvailable $ n ++ " is not in the data" fromRight n (Just (Right x)) = FR.Success x fromRight n _ = FR.Failure [n ++ " is not a file"]@@ -98,7 +202,7 @@ runFormState :: Monad m => Env -- ^ A previously filled environment (may be empty) -> Form xml m a -- ^ The form- -> (m (Failing a), m xml, FormContentType)+ -> (m (Failing a), xml, FormContentType) runFormState e (Form f) = fmapFst3 (liftM FR.toE . liftM es) (es (f e)) where es = flip evalState [0] @@ -120,14 +224,14 @@ --return x transform :: Monad m => (a -> m (Failing b)) -> m (Validator a) -> FormState -> m (Validator b)- transform f source st = x' (x f) source- where x :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b)- x f = fmap (liftM (return . FR.fromE)) f- x' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b)- x' f a = do a' <- a- let (a'', st') = runState a' st- val <- combine f a''- return (changeState st' val)+ transform f source st = transform' (makeValidator f) source+ where makeValidator :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b)+ makeValidator f = fmap (liftM (return . FR.fromE)) f+ transform' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b)+ transform' f a = do a' <- a+ let (a'', st') = runState a' st+ val <- combine f a''+ return (changeState st' val) changeState :: st -> State st a -> State st a changeState st' mComp = do result <- mComp put st'@@ -152,14 +256,34 @@ -- | Pure xml xml :: Monad m => xml -> Form xml m ()-xml x = Form $ \env -> pure (return (return $ FR.Success ()), return x, UrlEncoded)+xml x = Form $ \env -> pure (return (return $ FR.Success ()), x, UrlEncoded) -- | Transform the XML component-plug :: (Monad m, Monoid xml) => (xml -> xml1) -> Form xml m a -> Form xml1 m a+plug :: (xml -> xml1) -> Form xml m a -> Form xml1 m a f `plug` (Form m) = Form $ \env -> pure plugin <*> m env- where plugin (c, x, t) = (c, liftM f x, t)+ where plugin (c, x, t) = (c, f x, t) -plug' :: (Monad m, Monoid xml1) => (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a+-- | Combine the XML components of two forms using f, and combine the+-- values using g.+plug2 :: (Monad m) => (xml -> xml1 -> xml2) -> (a -> b -> Failing c) -> Form xml m a -> Form xml1 m b -> Form xml2 m c+plug2 f g (Form m) (Form n) =+ Form $ \env -> plugin <$> m env <*> n env+ where+ plugin (c1, x1, t1) (c2, x2, t2) = (combineCollectors c1 c2, f x1 x2, t2)+-- combineCollectors :: (Monad m) => m (State FormState (FR.FormResult a)) -> m (State FormState (FR.FormResult b)) -> m (State FormState (FR.FormResult c))+ combineCollectors c1 c2 =+ do a' <- c1+ b' <- c2+ return $ combiner <$> a' <*> b'+-- combiner :: (FR.FormResult a) -> (FR.FormResult b) -> (FR.FormResult c)+ combiner (FR.Failure a) (FR.Failure b) = FR.Failure (a ++ b)+ combiner (FR.Failure a) _ = FR.Failure a+ combiner _ (FR.Failure b) = FR.Failure b+ combiner (FR.NotAvailable str) _ = FR.NotAvailable str+ combiner _ (FR.NotAvailable str) = FR.NotAvailable str+ combiner (FR.Success a) (FR.Success b) = FR.fromE (g a b)++plug' :: (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a plug' transformer formlet value = plug transformer (formlet value) -- | This generates a single (or more) forms for a, and a parser function for a list of a's.@@ -180,12 +304,11 @@ [] -> return (newCollector, xml', contentType) xs -> do resetCurrentLevel xmls <- mapM (generateXml single env) xs- let xmls' = sequence xmls - return (newCollector, liftM mconcat xmls', contentType)+ return (newCollector, mconcat xmls, contentType) modify (tail.tail) return x -generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S (m xml)+generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S xml generateXml form env value = do (_, xml, _) <- (deform $ form $ Just value) env modify nextItem return xml@@ -194,14 +317,14 @@ resetCurrentLevel = do modify (tail . tail) modify (\x -> 0:0:x) -generateListXml :: (Applicative m, Monad m, Monoid xml) => Form xml m a -> Env -> S (m xml)+generateListXml :: (Applicative m, Monad m, Monoid xml) => Form xml m a -> Env -> S xml generateListXml form env = do n <- currentName case lookup n env of- Nothing -> return $ return mempty+ Nothing -> return mempty Just _ -> do (_, xml, _) <- (deform form) env modify nextItem rest <- generateListXml form env- return $ mappend <$> xml <*> rest+ return $ mappend xml rest liftCollector :: (Monad m) => FormState -> m (Validator a) -> m (Validator [a]) liftCollector st coll = do coll' <- coll@@ -250,14 +373,14 @@ orT x y = x pureF :: (Monad m, Monoid xml) => a -> Form xml m a-pureF v = Form $ \env -> pure (return (return $ FR.Success v), return mempty, UrlEncoded)+pureF v = Form $ \env -> pure (return (return $ FR.Success v), mempty, UrlEncoded) pureM :: (Monad m, Monoid xml) => m a -> Form xml m a-pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, return mempty, UrlEncoded)+pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, mempty, UrlEncoded) applyF :: (Monad m, Applicative m, Monoid xml) => Form xml m (a -> b) -> Form xml m a -> Form xml m b (Form f) `applyF` (Form v) = Form $ \env -> combine <$> f env <*> v env- where combine (v1, xml1, t1) (v2, xml2, t2) = (first v1 v2, (mappend <$> xml1 <*> xml2), t1 `orT` t2)+ where combine (v1, xml1, t1) (v2, xml2, t2) = (first v1 v2, (mappend xml1 xml2), t1 `orT` t2) first :: Monad m => m (Validator (a -> b)) -> m (Validator (a ))
Text/Formlets/MassInput.hs view
@@ -41,6 +41,9 @@ ," }" ," ));" ,""+-- Uncomment the following line if you want the newly added fields to+-- be empty.+-- ," newItem.children('input').attr('value','');" ," newItem.appendTo(item.parent());" ,"}" ,"function removeItem(button) {"
+ Text/XHtml/Transitional/Formlets.hs view
@@ -0,0 +1,109 @@+module Text.XHtml.Transitional.Formlets ( input, textarea, password, file, checkbox+ , hidden, inputInteger, radio, enumRadio+ , label+ , selectXHtml, selectRaw, select, enumSelect+ , XHtmlForm, XHtmlFormlet+ , module Text.Formlets+ ) where++import Text.Formlets hiding (massInput)+import qualified Text.Formlets as F+import qualified Text.XHtml.Transitional as X+import Text.XHtml.Transitional ((!), (+++), (<<))+import Control.Applicative+import Control.Applicative.Error+import Data.List (elemIndex)++type XHtmlForm m a = Form X.Html m a+type XHtmlFormlet m a = Formlet X.Html m a++-- | An input field with an optional value+input :: Monad m => XHtmlFormlet m String+input = input' (\n v -> X.textfield n ! [X.value v])+++-- | A textarea with optional rows and columns, and an optional value+textarea :: Monad m => Maybe Int -> Maybe Int -> XHtmlFormlet m String+textarea r c = input' (\n v -> X.textarea (X.toHtml v) ! (attrs n))+ where rows = maybe [] (\x -> [X.rows $ show x]) r+ cols = maybe [] (\x -> [X.cols $ show x]) c+ attrs n = [X.name n] ++ rows ++ cols++-- | A password field with an optional value+password :: Monad m => XHtmlFormlet m String+password = input' (\n v -> X.password n ! [X.value v])++-- | A hidden input field+hidden :: Monad m => XHtmlFormlet m String+hidden = input' X.hidden++-- | A validated integer component+inputInteger :: Monad m => XHtmlFormlet m Integer+inputInteger x = input (fmap show x) `check` asInteger ++-- | A file upload form+file :: Monad m => XHtmlForm m File+file = inputFile X.afile++-- | A checkbox with an optional default value+checkbox :: Monad m => XHtmlFormlet m Bool+checkbox d = (optionalInput (xml d)) `check` asBool+ where asBool (Just _) = Success True+ asBool Nothing = Success False+ xml (Just True) n = X.widget "checkbox" n [X.value "on", X.checked]+ xml _ n = X.checkbox n "on"++-- | A radio choice+radio :: Monad m => [(String, String)] -> XHtmlFormlet m String+radio choices = input' mkRadios -- todo: validate that the result was in the choices+ where radio n v i = X.input ! [X.thetype "radio", X.name n, X.identifier i, X.theclass "radio", X.value v]+ mkRadios name selected = X.concatHtml $ map (mkRadio name selected) (zip choices [1..])+ mkRadio name selected ((value, label), idx) = (radio name value ident) ! attrs + +++ X.label (X.toHtml label) ! [X.thefor ident, X.theclass "radio"]+ where attrs | selected == value = [X.checked]+ | otherwise = []+ ident = name ++ "_" ++ show idx++-- | An radio choice for Enums+enumRadio :: (Monad m, Enum a) => [(a, String)] -> XHtmlFormlet m 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" ++label :: (Monad m, X.HTML h) => h -> Form X.Html m ()+label = xml . X.label . X.toHtml++-- | This is a helper function to generate select boxes+selectXHtml :: (X.HTML h) + => [X.HtmlAttr] -- ^ Optional attributes for the select-box+ -> [(String, h)] -- ^ The values and their labels+ -> String -- ^ The name+ -> String -- ^ The value that is selected+ -> X.Html+selectXHtml attr choices name selected = X.select ! (X.name name:attr) $ X.concatHtml $ map (mkChoice selected) choices+ where mkChoice selected (value, label) = X.option ! (attrs ++ [X.value value]) << label+ where attrs | selected == value = [X.selected]+ | otherwise = []++-- | A drop-down for selecting values+selectRaw :: (Monad m, X.HTML h) + => [X.HtmlAttr] -- ^ Optional attributes for the select-element+ -> [(String, h)] -- ^ Pairs of value/label+ -> XHtmlFormlet m String+selectRaw attrs choices = input' $ selectXHtml attrs choices -- todo: validate that the result was in the choices++-- | A drop-down for anything that is an instance of Eq+select :: (Eq a, Monad m, X.HTML h) => [X.HtmlAttr] -> [(a, h)] -> XHtmlFormlet m a+select attrs ls v = selectRaw attrs (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")++-- | A drop-down for all the options from |a|.+enumSelect :: (Enum a, Bounded a, Show a, Eq a, Monad m) + => [X.HtmlAttr] -- Optional attributes on the select-box+ -> XHtmlFormlet m a+enumSelect attrs = select attrs (zip items (map show items)) where items = [minBound..maxBound]
formlets.cabal view
@@ -1,8 +1,8 @@ Name: formlets-Version: 0.6.1+Version: 0.8 Synopsis: Formlets implemented in Haskell-Description: A modular way to build forms based on applicative functors, as- described in:+Description: A modular way to build forms based on applicative functors,+ based on the work described in: . * Ezra Cooper, Samuel Lindley, Philip Wadler and Jeremy Yallop \"An idiom's guide to formlets\"@@ -11,24 +11,32 @@ Category: XML, Web, User Interfaces, Text License: BSD3 License-file: LICENSE-Copyright: (c) Jeremy Yallop / Tupil-Author: Jeremy Yallop / Chris Eidhof Homepage: http://github.com/chriseidhof/formlets/tree/master-Maintainer: Chris Eidhof <ce+hackage@tupil.com>+Maintainer: Doug Beardsley <mightybyte@gmail.com> Build-Type: Simple Cabal-Version: >= 1.6 Extra-Source-Files: README +Flag base4+ Description: Choose the even newer, even smaller, split-up base package.+ Library- Build-Depends: base >= 2 && < 5, - haskell98, - mtl, + Build-Depends: haskell98, xhtml, - applicative-extras >= 0.1.3, - bytestring+ applicative-extras >= 0.1.7, + bytestring,+ blaze-html >= 0.2,+ transformers == 0.2.2.0+ if flag(base4)+ Build-Depends: base >= 4 && < 5, syb+ else+ Build-Depends: base >= 2 && < 4+ Exposed-Modules: Text.Formlets , Text.Formlets.MassInput , Text.XHtml.Strict.Formlets+ , Text.XHtml.Transitional.Formlets+ , Text.Blaze.Html5.Formlets Other-Modules: Text.Formlets.FormResult