Minor rearranging and renaming

2010-08-13 16:24:51 +03:00 · 2010-08-13 16:24:51 +03:00 · c7ac7f191c
commit c7ac7f191c
parent 2a19d1a4e8
8 changed files with 146 additions and 135 deletions
--- 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
--- 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)

--- 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 ()]
--- 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

--- 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,
--- 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
--- 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
--- 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