From 879d5657bac213b874a6ee676d24761813c737ba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 2 Jul 2010 09:22:15 +0300 Subject: [PATCH] Remove old content from Form module --- Yesod/Form.hs | 195 +++----------------------------------------------- 1 file changed, 10 insertions(+), 185 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4f10e95f..62dab6b3 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -20,38 +20,21 @@ module Yesod.Form -- * Type classes , IsForm (..) , IsFormField (..) - -- * Pre-built fields + -- * Field/form helpers , requiredField + , mapFormXml + , newFormIdent + -- * Pre-built fields + , fieldsToTable , stringField , intField , dayField , boolField , htmlField , stringInput - , fieldsToTable + -- * Template Haskell , share2 , mkIsForm - , mapFormXml - {- FIXME - -- * Create your own formlets - , incr - , input - , check - -- * Error display - , wrapperRow - , sealFormlet - , sealForm - , sealRow - -- * Formable - , Formable (..) - , deriveFormable - , share2 - -- * Pre-built form - , optionalField - , requiredField - , notEmptyField - , boolField - -} ) where import Text.Hamlet @@ -158,7 +141,7 @@ requiredField :: FieldProfile sub y a -> Html () -> Html () -> Maybe a -> FormField sub y a requiredField (FieldProfile parse render mkXml w) label tooltip orig = GForm $ \env _ -> do - name <- incr + name <- newFormIdent let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -232,7 +215,7 @@ instance IsFormField Day where boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do - name <- incr + name <- newFormIdent let (res, val) = if null env then (FormMissing, fromMaybe False orig) @@ -287,8 +270,8 @@ stringInput n = GForm $ \env _ -> return --------------------- End prebuilt inputs -incr :: Monad m => StateT Int m String -incr = do +newFormIdent :: Monad m => StateT Int m String +newFormIdent = do i <- get let i' = i + 1 put i' @@ -330,164 +313,6 @@ runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f -{- - --------- Prebuilt -optionalField :: String -> Form sub master (Maybe String) -optionalField n = Form $ \env _ -> - return (FormSuccess $ lookup n env, mempty) -- FIXME - -requiredField :: String -> Form sub master String -requiredField n = Form $ \env _ -> - return (maybe FormMissing FormSuccess $ lookup n env, mempty) -- FIXME - -notEmptyField :: String -> Form sub master String -notEmptyField n = Form $ \env _ -> return - (case lookup n env of - Nothing -> FormMissing - Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] - Just x -> FormSuccess x, mempty) -- FIXME - -boolField :: String -> Form sub master Bool -boolField n = Form $ \env _ -> return - (FormSuccess $ isJust $ lookup n env, mempty) -- FIXME - -class Formable a where - formable :: Formlet sub master a - ---------------- Formable instances -instance Formable String where - formable x = input go x `check` notEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - notEmpty s - | null s = Left ["Value required"] - | otherwise = Right s - -instance Formable (Maybe String) where - formable x = input go (join x) `check` isEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - isEmpty s - | null s = Right Nothing - | otherwise = Right $ Just s - -instance Formable (Html ()) where - formable = fmap preEscapedString - . input go - . fmap (U.toString . renderHtml) - where - go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] - -instance Formable Day where - formable x = input go (fmap show x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid day"] - -instance Formable Int64 where - formable x = input go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -instance Formable Double where - formable x = input go (fmap numstring x) `check` asDouble - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asDouble s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid double"] - numstring d = - let s = show d - in case reverse s of - '0':'.':y -> reverse y - _ -> s - -instance Formable (Maybe Day) where - formable x = input go (fmap show $ join x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay "" = Right Nothing - asDay s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid day"] - -instance Formable (Maybe Int) where - formable x = input go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable (Maybe Int64) where - formable x = input go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable Bool where - formable x = Form $ \env _ -> do - i <- incr - let param = lookup i env - let def = if null env then fromMaybe False x else isJust param - return (FormSuccess $ isJust param, go i def) - where - go name val = addBody [$hamlet| -%input!type=checkbox!name=$string.name$!:val:checked -|] - -instance Formable Int where - formable x = input go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -newtype Slug = Slug { unSlug :: String } - deriving (Read, Eq, Show, SinglePiece, PersistField) - -instance Formable Slug where - formable x = input go (fmap unSlug x) `check` asSlug - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - asSlug [] = Left ["Slug must be non-empty"] - asSlug x' - | all (\c -> c `elem` "-_" || isAlphaNum c) x' = - Right $ Slug x' - | otherwise = Left ["Slug must be alphanumeric, - and _"] --} - share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do f' <- f a