packages feed

formlets 0.5 → 0.6

raw patch · 5 files changed

+271/−121 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Text.Formlets: withPrefix :: String -> Form xml m a -> Form xml m a
+ Text.Formlets: plug' :: (Monad m, Monoid xml1) => (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a
+ Text.Formlets: type Formlet xml m a = Maybe a -> Form xml m a
+ Text.Formlets.MassInput: massInput :: (Applicative m, Monad m) => (XHtmlFormlet m a) -> (Html -> Html) -> (Html -> Html) -> XHtmlFormlet m [a]
+ Text.XHtml.Strict.Formlets: type XHtmlFormlet m a = Formlet Html m a
- Text.Formlets: massInput :: (Monoid xml, Applicative m, Monad m) => (Form xml m (Maybe String)) -> Form xml m a -> ([String] -> xml) -> Form xml m [a]
+ Text.Formlets: massInput :: (Applicative m, Monad m, Monoid xml) => (Formlet xml m a) -> Formlet xml m [a]
- Text.Formlets: runFormState :: (Monad m) => Env -> String -> Form xml m a -> (m (Failing a), m xml, FormContentType)
+ Text.Formlets: runFormState :: (Monad m) => Env -> Form xml m a -> (m (Failing a), m xml, FormContentType)
- Text.XHtml.Strict.Formlets: checkbox :: (Monad m) => Maybe Bool -> XHtmlForm m Bool
+ Text.XHtml.Strict.Formlets: checkbox :: (Monad m) => XHtmlFormlet m Bool
- Text.XHtml.Strict.Formlets: enumRadio :: (Monad m, Enum a) => [(a, String)] -> Maybe a -> XHtmlForm m a
+ Text.XHtml.Strict.Formlets: enumRadio :: (Monad m, Enum a) => [(a, String)] -> XHtmlFormlet m a
- Text.XHtml.Strict.Formlets: enumSelect :: (Enum a, Bounded a, Show a, Eq a, Monad m) => [HtmlAttr] -> Maybe a -> Form Html m a
+ Text.XHtml.Strict.Formlets: enumSelect :: (Enum a, Bounded a, Show a, Eq a, Monad m) => [HtmlAttr] -> XHtmlFormlet m a
- Text.XHtml.Strict.Formlets: hidden :: (Monad m) => Maybe String -> XHtmlForm m String
+ Text.XHtml.Strict.Formlets: hidden :: (Monad m) => XHtmlFormlet m String
- Text.XHtml.Strict.Formlets: input :: (Monad m) => Maybe String -> XHtmlForm m String
+ Text.XHtml.Strict.Formlets: input :: (Monad m) => XHtmlFormlet m String
- Text.XHtml.Strict.Formlets: inputInteger :: (Monad m) => Maybe Integer -> XHtmlForm m Integer
+ Text.XHtml.Strict.Formlets: inputInteger :: (Monad m) => XHtmlFormlet m Integer
- Text.XHtml.Strict.Formlets: password :: (Monad m) => Maybe String -> XHtmlForm m String
+ Text.XHtml.Strict.Formlets: password :: (Monad m) => XHtmlFormlet m String
- Text.XHtml.Strict.Formlets: radio :: (Monad m) => [(String, String)] -> Maybe String -> XHtmlForm m String
+ Text.XHtml.Strict.Formlets: radio :: (Monad m) => [(String, String)] -> XHtmlFormlet m String
- Text.XHtml.Strict.Formlets: select :: (Eq a, Monad m, HTML h) => [HtmlAttr] -> [(a, h)] -> Maybe a -> Form Html m a
+ Text.XHtml.Strict.Formlets: select :: (Eq a, Monad m, HTML h) => [HtmlAttr] -> [(a, h)] -> XHtmlFormlet m a
- Text.XHtml.Strict.Formlets: selectRaw :: (Monad m, HTML h) => [HtmlAttr] -> [(String, h)] -> Maybe String -> Form Html m String
+ Text.XHtml.Strict.Formlets: selectRaw :: (Monad m, HTML h) => [HtmlAttr] -> [(String, h)] -> XHtmlFormlet m String
- Text.XHtml.Strict.Formlets: textarea :: (Monad m) => Maybe Int -> Maybe Int -> Maybe String -> XHtmlForm m String
+ Text.XHtml.Strict.Formlets: textarea :: (Monad m) => Maybe Int -> Maybe Int -> XHtmlFormlet m String

Files

Text/Formlets.hs view
@@ -3,9 +3,8 @@                      , ensureM, checkM, pureM                      , runFormState                       , massInput-                     , xml, plug-                     , withPrefix-                     , Env , Form+                     , xml, plug, plug'+                     , Env , Form , Formlet                      , File (..), ContentType (..), FormContentType (..)                      )                      where@@ -15,16 +14,20 @@ import Control.Applicative.Error import Control.Applicative.State import Data.Maybe (isJust)+import Data.List (intercalate)+import qualified Text.Formlets.FormResult as FR import qualified Data.ByteString.Lazy as BS import qualified Data.Traversable as T  -- Form stuff type Env = [(String, Either String File)]-type FormState = (Integer, String)+type FormState = [Integer]+type Formlet xml m a = Maybe a -> Form xml m a type Name = String-type Collector a = Env -> a+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 -> State FormState (Collector (m (Failing a)), m xml, FormContentType) }+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) data ContentType = ContentType { ctType :: String                                , ctSubtype :: String@@ -32,7 +35,7 @@                                }                                deriving (Eq, Show, Read) --- | Apply a predicate to a value and return Success or Failure as appropriate+-- | Apply a predicate to a value and return FR.Success or FR.Failure as appropriate ensure :: Show a         => (a -> Bool) -- ^ The predicate        -> String      -- ^ The error message, in case the predicate fails@@ -49,7 +52,7 @@ ensureM p msg x = do result <- p x                      return $ if result then Success x else Failure [msg] --- | Apply multiple predicates to a value, return Success or all the Failure messages+-- | Apply multiple predicates to a value, return FR.Success or all the FR.Failure messages ensures :: Show a         => [(a -> Bool, String)] -- ^ List of predicate functions and error messages, in case the predicate fails         -> a                     -- ^ The value@@ -60,64 +63,68 @@  -- | Helper function for genereting input components based forms. input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String-input' i = inputM' (\n v -> return $ i n v)+input' i = inputM' (\n -> return . i n)  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 = (return . fromLeft name . (lookup name),-                             i name (value name env), UrlEncoded)+   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         = Failure [n ++ " is not in the data"]-         fromLeft n (Just (Left x)) = Success x-         fromLeft n _               = Failure [n ++ " is a file."]+         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."] +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 = (return . fromLeft name . (lookup name),-                             return (i name), UrlEncoded)-         fromLeft n Nothing         = Success Nothing-         fromLeft n (Just (Left x)) = Success (Just x)-         fromLeft n _               = Failure [n ++ " could not be recognized."]+   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."]  -- | 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    = (return . fromRight name . (lookup name), return (i name), MultiPart)-         fromRight n Nothing          = Failure [n ++ " is not in the data"]-         fromRight n (Just (Right x)) = Success x-         fromRight n _                = Failure [n ++ " is not a file"]+  where  mkInput env name    = (lookupFreshName fromRight env, return (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"]  -- | Runs the form state runFormState :: Monad m               => Env               -- ^ A previously filled environment (may be empty)-             -> String            -- ^ A prefix for the names              -> Form xml m a      -- ^ The form              -> (m (Failing a), m xml, FormContentType)-runFormState e prefix (Form f) = let (coll, xml, typ) = evalState (f e) (0, prefix)-                                 in (coll e, xml, typ)+runFormState e (Form f) = fmapFst3 (liftM FR.toE . liftM es) (es (f e))+  where es = flip evalState [0]  -- | Check a condition or convert a result check :: (Monad m) => Form xml m a -> (a -> Failing b) -> Form xml m b check (Form frm) f = Form $ fmap checker frm- where checker = fmap $ fmapFst3 (fmap . liftM $ f')-       f' (Failure x)  = Failure x-       f' (Success x)  = f x+ where checker = fmap $ fmapFst3 (liftM $ liftM $ f')+       f' (FR.Failure x)       = FR.Failure x+       f' (FR.NotAvailable x)  = FR.NotAvailable x+       f' (FR.Success x)       = FR.fromE $ f x  -- | Monadically check a condition or convert a result checkM :: (Monad m) => Form xml m a -> (a -> m (Failing b)) -> Form xml m b-checkM (Form frm) f = Form $ fmap checker frm- where checker = fmap $ fmapFst3 (fmap f')-       f' v' = do v <- v'-                  case v of-                       Failure msg -> return $ Failure msg-                       Success x   -> f x+checkM (Form frm) f = Form $ \env -> checker f (frm env)+ where checker f frm = do currentState <- get+                          frm'         <- frm+                          return $ fmapFst3 (transform f. liftM (flip evalState currentState)) frm'+       transform f source = source >>= \x -> case x of +                              FR.Success x      -> liftM return (convert f x)+                              FR.NotAvailable x -> return . return $ FR.NotAvailable x+                              FR.Failure x      -> return . return $ FR.Failure x+       convert :: Monad m => (a -> m (Failing b)) -> (a -> m (FR.FormResult b))+       convert f = fmap (liftM FR.fromE) f  instance (Functor m, Monad m) => Functor (Form xml m) where-  fmap f (Form a) = Form $ \env -> (fmap . fmapFst3 . liftM . fmap . fmap) f (a env)+  fmap f (Form a) = Form $ \env -> (fmap . fmapFst3 . liftM . liftM . fmap) f (a env)  fmapFst  f (a, b)    = (f a, b) fmapFst3 f (a, b, c) = (f a, b, c)@@ -128,98 +135,118 @@  -- | Pure xml xml :: Monad m => xml -> Form xml m ()-xml x = Form $ \env -> pure (const $ return $ Success (), return x, UrlEncoded)+xml x = Form $ \env -> pure (return (return $ FR.Success ()), return x, UrlEncoded)  -- | Transform the XML component plug :: (Monad m, Monoid xml) => (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) --- | Takes a hidden-input field, a form of a and produces a list of a.--- | --- | The hidden input field contains a prefix, which is the pointer to the next form. --- | This form has to have the same variable-names as the original form, but prefixed by the prefix.--- | --- | Typically, some client-side code is needed to duplicate the original form and generate a unique prefix.-massInput :: (Monoid xml, Applicative m, Monad m)-          => (Form xml m (Maybe String))-          -> Form xml m a-          -> ([String] -> xml)-          -> Form xml m [a]-massInput h f showErrors = massInputHelper form showErrors- where form = (,) <$> f <*> h+plug' :: (Monad m, Monoid xml1) => (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a+plug' transformer formlet value = plug transformer (formlet value) -massInputHelper :: (Monoid xml, Applicative m, Monad m) -                => Form xml m (a, Maybe String)  -- The form-                -> ([String] -> xml)             -- How to show errors-                -> Form xml m [a]-massInputHelper f showErrors = join f-  where join :: (Monoid xml, Applicative m, Monad m) => Form xml m (a, Maybe String) -> Form xml m [a]-        join (Form f) = Form $ \env -> start (f env) env-        start :: (Monad m)-          => State FormState (Collector (m (Failing (a, Maybe String))), xml, FormContentType)-          -> Env-          -> State FormState (Collector (m (Failing [a])), xml, FormContentType)-        start f e =     do  currentState <- get-                            --todo use v-                            let (a, s) = runState f currentState-                            let (v, xml, t) = a-                            let v' = evalState (combineIt [] f (Just v)) currentState-                            put s-                            return (v', xml, t)-        combineIt p f v = do currentState <- get-                             let x = findLinkedList f currentState-                             return $ \e -> calculate p f e (maybe (x e) (\x -> x e) v) currentState-        calculate p f e v (n,_) = do x <- v-                                     case x of-                                          Success (x, Nothing)    -> return $ Success [x]-                                          Success (v, Just cont)  -> do if cont `elem` p then return $ Failure ["Infinite loop"] else do-                                                                        x <- (evalState (combineIt (cont:p) f Nothing) (n, cont)) e-                                                                        case x of-                                                                             Success ls  -> return $ Success (v:ls)-                                                                             Failure msg -> return $ Failure msg-                                          Failure msg             -> return $ Failure msg-        findLinkedList f = fst3 . evalState f+-- | This generates a single (or more) forms for a, and a parser function for a list of a's.+massInput :: (Applicative m, Monad m, Monoid xml)+          => (Formlet xml m a) -- ^ A formlet for a single a+          -> Formlet xml m [a]+massInput single defaults = Form $ \env -> do+  modify (\x -> 0:0:x)+  st <- get+  (collector, xml, contentType) <- (deform $ single Nothing) env+  resetCurrentLevel+  listXml <- generateListXml (single Nothing) env+  let newCollector = liftCollector st collector +      xml' = case env of+               [] -> xml+               _  -> listXml+  x <- case maybe [] id defaults of+       [] -> return (newCollector, xml', contentType)+       xs -> do resetCurrentLevel+                xmls <- mapM (generateXml single env) xs+                let xmls' = sequence xmls +                return (newCollector, liftM mconcat xmls', contentType)+  modify (tail.tail)+  return x -fst3 (a, b, c) = a+generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S (m xml)+generateXml form env value = do (_, xml, _) <- (deform $ form $ Just value) env+                                modify nextItem+                                return xml +resetCurrentLevel :: S ()+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 form env = do n <- currentName+                              case lookup n env of+                                Nothing -> return $ return mempty+                                Just _  -> do (_, xml, _) <- (deform form) env+                                              modify nextItem+                                              rest <- generateListXml form env+                                              return $ mappend <$> xml <*> rest++liftCollector :: (Monad m) => FormState -> m (Validator a) -> m (Validator [a])+liftCollector st coll = do coll' <- coll+                           let st'         = nextItem st+                               computeRest = liftCollector st' coll+                           case evalState coll' st of+                                 FR.Success x      -> do rest <- computeRest+                                                         return (fmap (fmap (x:)) rest)+                                 FR.NotAvailable x -> return (return (FR.Success []))+                                 FR.Failure x      -> do rest <- computeRest+                                                         return $ combineFailures x rest++nextItem st = flip execState st $ modify tail >> freshName >> modify (0:) >> get++combineFailures :: [String] -> Validator [a] -> Validator [a]+combineFailures msgs s = do x <- s+                            case x of+                                 FR.Success x -> return $ FR.Failure msgs+                                 FR.Failure f -> return $ FR.Failure (msgs ++ f)++                           -- | Returns Nothing if the result is the empty String. nothingIfNull :: (Monad m, Functor m) => Form xml m String -> Form xml m (Maybe String) nothingIfNull frm = nullToMaybe <$> frm  where nullToMaybe [] = Nothing        nullToMaybe x  = Just x -withPrefix :: String -> Form xml m a -> Form xml m a-withPrefix prefix (Form f) = Form $ \env -> (modify (const (0, prefix)) >> f env)- ----------------------------------------------- -- Private methods ----------------------------------------------- -freshName :: State FormState String+freshName :: S String freshName = do n <- currentName-               modify (\(n,prefix) -> (n+1, prefix))+               modify (changeHead (+1))                return n -currentName :: State FormState String-currentName = gets $ \(n, prefix) ->  prefix ++ "fval" ++ show n+-- TODO: think of a good name+changeHead f []     = error "changeHead: there is no head"+changeHead f (x:xs) = (f x) : xs -changePrefix :: String -> State FormState ()-changePrefix p = modify (\(n,_) -> (n, p))+currentName :: S String+currentName = gets $ \xs ->  "fval[" ++ (intercalate "." $ reverse $ map show xs) ++ "]"  orT UrlEncoded x = x orT x UrlEncoded = x orT x y          = x  pureF :: (Monad m, Monoid xml) => a -> Form xml m a-pureF v = Form $ \env -> pure (const (return $ Success v), return mempty, UrlEncoded)+pureF v = Form $ \env -> pure (return (return $ FR.Success v), return mempty, UrlEncoded)  pureM :: (Monad m, Monoid xml) => m a -> Form xml m a-pureM v = Form $ \env -> pure (const (liftM Success v), return mempty, UrlEncoded)+pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, return 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)-        first v1 v2 e = do x <- v1 e -                           y <- v2 e-                           return $ x <*> y+        first :: Monad m+              => m (Validator (a -> b)) +              -> m (Validator (a     )) +              -> m (Validator (b     )) +        first v1 v2 = do x <- v1+                         y <- v2+                         return $ do x'' <- x+                                     y'' <- y+                                     return (x'' <*> y'')
+ Text/Formlets/FormResult.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE PatternGuards #-}+module Text.Formlets.FormResult ({-maybeRead, maybeRead', asInteger, tryToEnum,-} toE, fromE, FormResult (..)) where++import Control.Applicative+import qualified Control.Applicative.Error as E++toE :: FormResult a -> E.Failing a+toE (Success a)      = E.Success a+toE (Failure f)      = E.Failure f+toE (NotAvailable e) = E.Failure [e]++fromE :: E.Failing a -> FormResult a+fromE (E.Success a) = Success a+fromE (E.Failure f) = Failure f+++data FormResult a+  = Success a+  | Failure [String]+  | NotAvailable String+  deriving (Show) -- DEBUG++instance Applicative FormResult where+   pure = Success+   Failure msgs <*> Failure msgs' = Failure (msgs ++ msgs')+   Success _ <*> Failure msgs' = Failure msgs'+   Failure msgs' <*> Success _ = Failure msgs'+   Success f <*> Success x = Success (f x)+   NotAvailable x <*> _ = NotAvailable x+   _ <*> NotAvailable x = NotAvailable x++instance Functor FormResult where+  fmap f (Success a)      = Success (f a)+  fmap f (Failure msgs)   = Failure msgs+  fmap f (NotAvailable x) = NotAvailable x++-- maybeRead :: Read a => String -> Maybe a+-- maybeRead s | [(i, "")] <- readsPrec 0 s = Just i+--             | otherwise = Nothing+-- +-- -- | Tries to read a value. Shows an error message when reading fails.+-- maybeRead' :: Read a => String -> String -> FormResult a+-- maybeRead' s msg | Just x <- maybeRead s = Success x+--                  | otherwise = Failure [msg]+-- +-- -- | Tries to read an Integer+-- asInteger :: String -> FormResult Integer+-- asInteger s = maybeRead' s (s ++ " is not a valid integer")+-- +-- -- | Tries conversion to an enum+-- tryToEnum :: Enum a => Int -> FormResult a+-- tryToEnum x | value <- toEnum x = Success value+--             | otherwise         = Failure ["Conversion error"]+-- 
+ Text/Formlets/MassInput.hs view
@@ -0,0 +1,56 @@+module Text.Formlets.MassInput where++import Text.XHtml.Strict.Formlets+import qualified Text.Formlets as F+import Text.XHtml.Strict ((!), (+++), (<<))+import Control.Applicative+import qualified Text.XHtml.Strict as X+import Data.Monoid++massInput :: (Applicative m, Monad m)+          => (XHtmlFormlet m a) -- ^ A formlet for a single a+          -> (X.Html -> X.Html) -- ^ This should add at least one wrapper tag around every item+          -> (X.Html -> X.Html) -- ^ This will add an optional wrapper tag around the whole list+          -> XHtmlFormlet m [a]+massInput formlet itemWrapper listWrapper defaults = +  plug (wrapperDiv . buttons . listWrapper) $ F.massInput (plug' (itemWrapper ! [X.theclass "massInputItem"]) formlet) defaults++wrapperDiv = X.thediv ! [X.theclass "massInput"]++buttons x = (X.thediv+  ((X.input ! [X.thetype "button", X.strAttr "onclick" "addItem(this); return false;", X.value "Add Item"]) ++++  (X.input ! [X.thetype "button", X.strAttr "onclick" "removeItem(this); return false;", X.value "Remove Last Item"]))) +++ x++jsMassInputCode = unlines+  ["function findItems(button) {"+  ,"  var mainDiv = $(button).parent();"+  ,"  while ( !mainDiv.hasClass('massInput') ) {"+  ,"    mainDiv = $(mainDiv).parent();"+  ,"  }"+  ,"  return $('.massInputItem', mainDiv);"+  ,"}"+  ,"function addItem(button) {"+  ,"  var items = findItems(button);"+  ,"  var item = $(items[items.length-1]);"+  ,"  var newItem = item.clone(true);"+  ,""+  ,"  newItem.html(newItem.html().replace(/fval\\[(\\d+\\.)*(\\d+)\\.(\\d+)\\]/g, "+  ,"    function(a, b, c, d) {"+  ,"      var newC = parseInt(c)+1;"+  ,"      return a.replace(/\\d+\\.\\d+\\]/, newC+'.'+d+']');"+  ,"    }"+  ,"  ));"+  ,""+  ,"  newItem.appendTo(item.parent());"+  ,"}"+  ,"function removeItem(button) {"+  ,"  var items = findItems(button);"+  ,"  if ( items.length > 1 ) {"+  ,"    var item = $(items[items.length-1]);"+  ,"    item.remove();"+  ,"  } else {"+  ,"    alert('Cannot remove any more rows');"+  ,"  }"+  ,"}"+  ]+
Text/XHtml/Strict/Formlets.hs view
@@ -2,40 +2,43 @@                                   , hidden, inputInteger, radio, enumRadio                                   , label                                   , selectXHtml, selectRaw, select, enumSelect-                                  , XHtmlForm+                                  , XHtmlForm, XHtmlFormlet                                   , module Text.Formlets                                   ) where -import Text.Formlets+import Text.Formlets hiding (massInput)+import qualified Text.Formlets as F import qualified Text.XHtml.Strict as X import Text.XHtml.Strict ((!), (+++), (<<)) import Control.Applicative import Control.Applicative.Error import Data.List (elemIndex) -type XHtmlForm m a = Form X.Html m a+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 => Maybe String -> XHtmlForm m String+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 -> Maybe String -> XHtmlForm m String+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 => Maybe String -> XHtmlForm m String+password :: Monad m => XHtmlFormlet m String password = input' (\n v -> X.password n ! [X.value v])  -- | A hidden input field-hidden  :: Monad m => Maybe String -> XHtmlForm m String+hidden  :: Monad m => XHtmlFormlet m String hidden  =  input' X.hidden  -- | A validated integer component-inputInteger :: Monad m => Maybe Integer -> XHtmlForm m Integer+inputInteger :: Monad m => XHtmlFormlet m Integer inputInteger x = input (fmap show x) `check` asInteger   -- | A file upload form@@ -43,7 +46,7 @@ file = inputFile X.afile  -- | A checkbox with an optional default value-checkbox :: Monad m => Maybe Bool -> XHtmlForm m Bool+checkbox :: Monad m => XHtmlFormlet m Bool checkbox d = (optionalInput (xml d)) `check` asBool   where asBool (Just _) = Success True         asBool Nothing = Success False@@ -51,7 +54,7 @@         xml _ n = X.checkbox n "on"  -- | A radio choice-radio :: Monad m => [(String, String)] -> Maybe String -> XHtmlForm m String+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..])@@ -62,7 +65,7 @@               ident = name ++ "_" ++ show idx  -- | An radio choice for Enums-enumRadio :: (Monad m, Enum a) => [(a, String)] -> Maybe a -> XHtmlForm m a+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)@@ -87,12 +90,11 @@ selectRaw :: (Monad m, X.HTML h)            => [X.HtmlAttr]  -- ^ Optional attributes for the select-element           -> [(String, h)] -- ^ Pairs of value/label-          -> Maybe String  -- ^ An optional default value-          -> Form X.Html m String+          -> 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)] -> Maybe a -> Form X.Html m a+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)@@ -103,6 +105,5 @@ -- | 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-           -> Maybe a      -- An optional value-           -> Form X.Html m a+           -> XHtmlFormlet m a enumSelect attrs = select attrs (zip items (map show items)) where items = [minBound..maxBound]
formlets.cabal view
@@ -1,5 +1,5 @@ Name:            formlets-Version:         0.5+Version:         0.6 Synopsis:        Formlets implemented in Haskell Description:     A modular way to build forms based on applicative functors, as                  described in:@@ -13,14 +13,26 @@ 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>-Exposed-Modules:   Text.Formlets-                 , Text.XHtml.Strict.Formlets Build-Type:      Simple-Build-Depends:   base >= 2 && < 5, -                 haskell98, -                 mtl, -                 xhtml, -                 applicative-extras >= 0.1.3, -                 bytestring+Cabal-Version: >= 1.6 Extra-Source-Files: README++Library+  Build-Depends:   base >= 2 && < 5, +                   haskell98, +                   mtl, +                   xhtml, +                   applicative-extras >= 0.1.3, +                   bytestring+  Exposed-Modules:   Text.Formlets+                   , Text.Formlets.MassInput+                   , Text.XHtml.Strict.Formlets+  Other-Modules:   Text.Formlets.FormResult+  +++source-repository head+  type:     git+  location: git://github.com/chriseidhof/formlets.git