299 lines
9.6 KiB
Haskell
299 lines
9.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
-- | Users of the forms library should not need to use this module in general.
|
|
-- It is intended only for writing custom forms and form fields.
|
|
module Yesod.Form.Core
|
|
( FormResult (..)
|
|
, GForm (..)
|
|
, newFormIdent
|
|
{- FIXME
|
|
, deeperFormIdent
|
|
, shallowerFormIdent
|
|
-}
|
|
, Env
|
|
, FileEnv
|
|
, Enctype (..)
|
|
, Ints (..)
|
|
, requiredFieldHelper
|
|
, optionalFieldHelper
|
|
, mapFormXml
|
|
{- FIXME
|
|
, checkForm
|
|
, checkField
|
|
-}
|
|
, askParams
|
|
, askFiles
|
|
-- * Data types
|
|
, FieldInfo (..)
|
|
, FormFieldSettings (..)
|
|
, FieldProfile (..)
|
|
-- * Type synonyms
|
|
{- FIXME
|
|
, Form
|
|
, Formlet
|
|
, FormField
|
|
, FormletField
|
|
, FormInput
|
|
-}
|
|
) where
|
|
|
|
import Control.Monad.Trans.RWS
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Yesod.Handler
|
|
import Yesod.Widget
|
|
import Data.Monoid (Monoid (..))
|
|
import Control.Applicative
|
|
import Yesod.Request
|
|
import Control.Monad (liftM)
|
|
import Text.Hamlet
|
|
import Text.Blaze (ToHtml (..))
|
|
import Data.String
|
|
import Control.Monad (join)
|
|
import Data.Text (Text, pack)
|
|
import qualified Data.Text as T
|
|
import Prelude hiding ((++))
|
|
|
|
(++) :: Monoid a => a -> a -> a
|
|
(++) = mappend
|
|
|
|
-- | A form can produce three different results: there was no data available,
|
|
-- the data was invalid, or there was a successful parse.
|
|
--
|
|
-- The 'Applicative' instance will concatenate the failure messages in two
|
|
-- 'FormResult's.
|
|
data FormResult a = FormMissing
|
|
| FormFailure [Text]
|
|
| FormSuccess a
|
|
deriving Show
|
|
instance Functor FormResult where
|
|
fmap _ FormMissing = FormMissing
|
|
fmap _ (FormFailure errs) = FormFailure errs
|
|
fmap f (FormSuccess a) = FormSuccess $ f a
|
|
instance Applicative FormResult where
|
|
pure = FormSuccess
|
|
(FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
|
|
(FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
|
|
(FormFailure x) <*> _ = FormFailure x
|
|
_ <*> (FormFailure y) = FormFailure y
|
|
_ <*> _ = FormMissing
|
|
instance Monoid m => Monoid (FormResult m) where
|
|
mempty = pure mempty
|
|
mappend x y = mappend <$> x <*> y
|
|
|
|
-- | The encoding type required by a form. The 'ToHtml' instance produces values
|
|
-- that can be inserted directly into HTML.
|
|
data Enctype = UrlEncoded | Multipart
|
|
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
|
|
mappend _ _ = Multipart
|
|
|
|
data Ints = IntCons Int Ints | IntSingle Int
|
|
instance Show Ints where
|
|
show (IntSingle i) = show i
|
|
show (IntCons i is) = show i ++ ('-' : show is)
|
|
|
|
incrInts :: Ints -> Ints
|
|
incrInts (IntSingle i) = IntSingle $ i + 1
|
|
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
|
|
|
type GForm xml m a = RWST (Env, FileEnv) (Enctype, xml) Ints m a -- FIXME rename to Form
|
|
type Env = [(Text, Text)]
|
|
type FileEnv = [(Text, FileInfo)]
|
|
|
|
-- | Get a unique identifier.
|
|
newFormIdent :: (Monoid xml, Monad m) => GForm xml m Text
|
|
newFormIdent = do
|
|
i <- get
|
|
let i' = incrInts i
|
|
put i'
|
|
return $ pack $ 'f' : show i'
|
|
|
|
{- FIXME
|
|
deeperFormIdent :: Monad m => StateT Ints m ()
|
|
deeperFormIdent = do
|
|
i <- get
|
|
let i' = 1 `IntCons` incrInts i
|
|
put i'
|
|
|
|
shallowerFormIdent :: Monad m => StateT Ints m ()
|
|
shallowerFormIdent = do
|
|
IntCons _ i <- get
|
|
put i
|
|
-}
|
|
|
|
-- | Create a required field (ie, one that cannot be blank) from a
|
|
-- 'FieldProfile'.
|
|
requiredFieldHelper
|
|
:: (Monoid xml', Monad m)
|
|
=> FieldProfile xml a
|
|
-> FormFieldSettings
|
|
-> Maybe a
|
|
-> GForm xml' m (FormResult a, FieldInfo xml)
|
|
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = do
|
|
env <- askParams
|
|
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"], "") -- TRANS
|
|
Just x ->
|
|
case parse x of
|
|
Left e -> (FormFailure [e], x)
|
|
Right y -> (FormSuccess y, x)
|
|
let fi = FieldInfo
|
|
{ fiLabel = toHtml label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = theId
|
|
, fiInput = mkWidget theId name val True
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ toHtml x
|
|
_ -> Nothing
|
|
, fiRequired = True
|
|
}
|
|
let res' = case res of
|
|
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
|
|
_ -> res
|
|
return (res', fi)
|
|
|
|
-- | Create an optional field (ie, one that can be blank) from a
|
|
-- 'FieldProfile'.
|
|
optionalFieldHelper
|
|
:: (Monad m, Monoid xml')
|
|
=> FieldProfile xml b
|
|
-> FormFieldSettings
|
|
-> Maybe (Maybe b)
|
|
-> GForm xml' m (FormResult (Maybe b), FieldInfo xml)
|
|
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = do
|
|
env <- askParams
|
|
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 = toHtml label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = theId
|
|
, fiInput = mkWidget theId name val False
|
|
, fiErrors = case res of
|
|
FormFailure x -> Just $ toHtml $ T.unlines x
|
|
_ -> Nothing
|
|
, fiRequired = False
|
|
}
|
|
let res' = case res of
|
|
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
|
|
_ -> res
|
|
return (res', fi)
|
|
|
|
-- | Convert the XML in a 'GForm'.
|
|
mapFormXml :: Monad m => (xml1 -> xml2) -> GForm xml1 m a -> GForm xml2 m a
|
|
mapFormXml f = mapRWST $ \x -> do
|
|
(a, b, (c, d)) <- x
|
|
return (a, b, (c, f d))
|
|
|
|
-- | 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 xml = FieldInfo
|
|
{ fiLabel :: Html
|
|
, fiTooltip :: Html
|
|
, fiIdent :: Text
|
|
, fiInput :: xml
|
|
, fiErrors :: Maybe Html
|
|
, fiRequired :: Bool
|
|
}
|
|
|
|
data FormFieldSettings = FormFieldSettings
|
|
{ ffsLabel :: Text
|
|
, ffsTooltip :: Html
|
|
, ffsId :: Maybe Text
|
|
, ffsName :: Maybe Text
|
|
}
|
|
instance IsString FormFieldSettings where
|
|
fromString s = FormFieldSettings (pack 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 xml a = FieldProfile
|
|
{ fpParse :: Text -> Either Text a
|
|
, fpRender :: a -> Text
|
|
-- | ID, name, value, required
|
|
, fpWidget :: Text -> Text -> Text -> Bool -> xml
|
|
}
|
|
|
|
{- FIXME
|
|
type Form sub y = GForm sub y (GWidget sub y ())
|
|
type Formlet sub y a = Maybe a -> Form sub y a
|
|
type FormInput sub y = GForm sub y [GWidget sub y ()]
|
|
type FormField xml m = GForm xml m [FieldInfo xml]
|
|
type FormletField xml m a = Maybe a -> FormField xml a
|
|
-}
|
|
|
|
{- FIXME
|
|
-- | Add a validation check to a form.
|
|
--
|
|
-- Note that if there is a validation error, this message will /not/
|
|
-- automatically appear on the form; for that, you need to use 'checkField'.
|
|
checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
|
|
checkForm f (GForm form) = GForm $ do
|
|
(res, xml, enc) <- form
|
|
let res' = case res of
|
|
FormSuccess a -> f a
|
|
FormFailure e -> FormFailure e
|
|
FormMissing -> FormMissing
|
|
return (res', xml, enc)
|
|
|
|
-- | Add a validation check to a 'FormField'.
|
|
--
|
|
-- Unlike 'checkForm', the validation error will appear in the generated HTML
|
|
-- of the form.
|
|
checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b
|
|
checkField f form = do
|
|
(res, xml, enc) <- form
|
|
let (res', merr) =
|
|
case res of
|
|
FormSuccess a ->
|
|
case f a of
|
|
Left e -> (FormFailure [e], Just e)
|
|
Right x -> (FormSuccess x, Nothing)
|
|
FormFailure e -> (FormFailure e, Nothing)
|
|
FormMissing -> (FormMissing, Nothing)
|
|
let xml' =
|
|
case merr of
|
|
Nothing -> xml
|
|
Just err -> flip map xml $ \fi -> fi
|
|
{ fiErrors = Just $
|
|
case fiErrors fi of
|
|
Nothing -> toHtml err
|
|
Just x -> x
|
|
}
|
|
return (res', xml', enc)
|
|
-}
|
|
|
|
askParams :: (Monoid xml, Monad m) => GForm xml m Env
|
|
askParams = liftM fst ask
|
|
|
|
askFiles :: (Monoid xml, Monad m) => GForm xml m FileEnv
|
|
askFiles = liftM snd ask
|