From c7ac7f191c9cc16984c73a549237e46ae2f22483 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Aug 2010 16:24:51 +0300 Subject: [PATCH] Minor rearranging and renaming --- Yesod/Form.hs | 8 ++- Yesod/Form/Class.hs | 1 + Yesod/Form/Core.hs | 135 ++++++++++++++++++++++++++++++++++++++++- Yesod/Form/Fields.hs | 118 +---------------------------------- Yesod/Form/Jquery.hs | 2 +- Yesod/Form/Nic.hs | 2 +- Yesod/Form/Profiles.hs | 13 +--- Yesod/Helpers/Crud.hs | 2 +- 8 files changed, 146 insertions(+), 135 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 8cff7183..70eb0882 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -8,7 +8,13 @@ module Yesod.Form ( -- * Data types GForm , FormResult (..) - , Enctype (..) + , Enctype + -- * Type synonyms + , Form + , Formlet + , FormField + , FormletField + , FormInput -- * Unwrapping functions , runFormGet , runFormPost diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 78af7e9c..58c4df15 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -8,6 +8,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields +import Yesod.Form.Core import Data.Int (Int64) import Data.Time (Day, TimeOfDay) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index f05437ec..81aab78d 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Yesod.Form.Core ( FormResult (..) , GForm (..) @@ -8,14 +9,32 @@ module Yesod.Form.Core , FileEnv , Enctype (..) , Ints (..) + , requiredFieldHelper + , optionalFieldHelper + , fieldsToInput + , mapFormXml + -- * Data types + , FieldInfo (..) + , FormFieldSettings (..) + , FieldProfile (..) + -- * Type synonyms + , Form + , Formlet + , FormField + , FormletField + , FormInput ) where import Control.Monad.Trans.State import Yesod.Handler +import Yesod.Widget import Data.Monoid (Monoid (..)) import Control.Applicative import Yesod.Request import Control.Monad (liftM) +import Text.Hamlet +import Data.String +import Control.Monad (join) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -44,9 +63,10 @@ instance Monoid m => Monoid (FormResult m) where -- | The encoding type required by a form. The 'Show' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart -instance Show Enctype where - show UrlEncoded = "application/x-www-form-urlencoded" - show Multipart = "multipart/form-data" + deriving (Eq, Enum, Bounded) +instance ToHtml Enctype where + toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" + toHtml Multipart = unsafeByteString "multipart/form-data" instance Monoid Enctype where mempty = UrlEncoded mappend UrlEncoded UrlEncoded = UrlEncoded @@ -101,3 +121,112 @@ instance Monoid xml => Applicative (GForm sub url xml) where (f1, f2, f3) <- f env fe (g1, g2, g3) <- g env fe return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) + +-- | Create a required field (ie, one that cannot be blank) from a +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormMissing, "") + Just "" -> (FormFailure ["Value is required"], "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +-- | Create an optional field (ie, one that can be blank) from a +-- 'FieldProfile'. +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> FormletField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + let orig = join orig' + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormSuccess Nothing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormSuccess Nothing, "") + Just "" -> (FormSuccess Nothing, "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess $ Just y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] +fieldsToInput = map fiInput + +-- | Convert the XML in a 'GForm'. +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + +-- | Using this as the intermediate XML representation for fields allows us to +-- write generic field functions and then different functions for producing +-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. +data FieldInfo sub y = FieldInfo + { fiLabel :: Html + , fiTooltip :: Html + , fiIdent :: String + , fiName :: String + , fiInput :: GWidget sub y () + , fiErrors :: Maybe Html + } + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html + , ffsTooltip :: Html + , ffsId :: Maybe String + , ffsName :: Maybe String + } +instance IsString FormFieldSettings where + fromString s = FormFieldSettings (string s) mempty Nothing Nothing + +-- | A generic definition of a form field that can be used for generating both +-- required and optional fields. See 'requiredFieldHelper and +-- 'optionalFieldHelper'. +data FieldProfile sub y a = FieldProfile + { fpParse :: String -> Either String a + , fpRender :: a -> String + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) + , fpWidget :: String -> GWidget sub y () + } + +type Form sub y = GForm sub y (GWidget sub y ()) +type Formlet sub y a = Maybe a -> Form sub y a +type FormField sub y = GForm sub y [FieldInfo sub y] +type FormletField sub y a = Maybe a -> FormField sub y a +type FormInput sub y = GForm sub y [GWidget sub y ()] diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 09204f76..846e6b2e 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,17 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} module Yesod.Form.Fields - ( -- * Type synonyms - Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - -- * Fields + ( -- * Fields -- ** Required - , stringField + stringField , textareaField , hiddenField , intField @@ -46,11 +37,6 @@ module Yesod.Form.Fields -- ** Optional , maybeStringInput , maybeDayInput - -- * Utils - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml ) where import Yesod.Form.Core @@ -61,34 +47,6 @@ import Text.Hamlet import Data.Monoid import Control.Monad (join) import Data.Maybe (fromMaybe) -import Data.String - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiName :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] stringField :: FormFieldSettings -> FormletField sub y String stringField = requiredFieldHelper stringFieldProfile @@ -269,78 +227,6 @@ maybeDayInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val True) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val False) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ \e fe -> do - (res, xml, enc) <- g e fe - return (res, f xml, enc) - urlField :: FormFieldSettings -> FormletField sub y String urlField = requiredFieldHelper urlFieldProfile diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 915a017d..a4c39349 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -11,7 +11,7 @@ module Yesod.Form.Jquery ) where import Yesod.Handler -import Yesod.Form +import Yesod.Form.Core import Yesod.Form.Profiles import Yesod.Widget import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index b0c02192..a52be361 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -6,7 +6,7 @@ module Yesod.Form.Nic ) where import Yesod.Handler -import Yesod.Form +import Yesod.Form.Core import Yesod.Form.Profiles import Yesod.Hamlet import Yesod.Widget diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index b86f8149..557cf2fc 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -15,24 +15,13 @@ module Yesod.Form.Profiles , parseTime ) where -import Yesod.Widget -import Yesod.Handler +import Yesod.Form.Core import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) - , fpWidget :: String -> GWidget sub y () - } - intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 06c031e6..ba22569e 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -160,7 +160,7 @@ crudHelper title me isPost = do %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$ -%form!method=post!enctype=$show.enctype$ +%form!method=post!enctype=$enctype$ %table ^form^ %tr