{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Form.Types
(
Enctype (..)
, FormResult (..)
, FormMessage (..)
, Env
, FileEnv
, Ints (..)
, WForm
, MForm
, AForm (..)
, Field (..)
, FieldSettings (..)
, FieldView (..)
, FieldViewFunc
) where
import Control.Monad.Trans.RWS (RWST)
import Control.Monad.Trans.Writer (WriterT)
import Data.Text (Text)
import Data.Monoid (Monoid (..))
import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
#define Html Markup
#define ToHtml ToMarkup
#define toHtml toMarkup
import Control.Applicative ((<$>), Alternative (..), Applicative (..))
import Control.Monad (liftM)
import Control.Monad.Trans.Class
import Data.String (IsString (..))
import Yesod.Core
import qualified Data.Map as Map
import Data.Semigroup (Semigroup, (<>))
import Data.Traversable
import Data.Foldable
data FormResult a = FormMissing
| FormFailure [Text]
| FormSuccess a
deriving (Int -> FormResult a -> ShowS
forall a. Show a => Int -> FormResult a -> ShowS
forall a. Show a => [FormResult a] -> ShowS
forall a. Show a => FormResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormResult a] -> ShowS
$cshowList :: forall a. Show a => [FormResult a] -> ShowS
show :: FormResult a -> String
$cshow :: forall a. Show a => FormResult a -> String
showsPrec :: Int -> FormResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FormResult a -> ShowS
Show, FormResult a -> FormResult a -> Bool
forall a. Eq a => FormResult a -> FormResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormResult a -> FormResult a -> Bool
$c/= :: forall a. Eq a => FormResult a -> FormResult a -> Bool
== :: FormResult a -> FormResult a -> Bool
$c== :: forall a. Eq a => FormResult a -> FormResult a -> Bool
Eq)
instance Functor FormResult where
fmap :: forall a b. (a -> b) -> FormResult a -> FormResult b
fmap a -> b
_ FormResult a
FormMissing = forall a. FormResult a
FormMissing
fmap a -> b
_ (FormFailure [Text]
errs) = forall a. [Text] -> FormResult a
FormFailure [Text]
errs
fmap a -> b
f (FormSuccess a
a) = forall a. a -> FormResult a
FormSuccess forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
instance Control.Applicative.Applicative FormResult where
pure :: forall a. a -> FormResult a
pure = forall a. a -> FormResult a
FormSuccess
(FormSuccess a -> b
f) <*> :: forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
<*> (FormSuccess a
g) = forall a. a -> FormResult a
FormSuccess forall a b. (a -> b) -> a -> b
$ a -> b
f a
g
(FormFailure [Text]
x) <*> (FormFailure [Text]
y) = forall a. [Text] -> FormResult a
FormFailure forall a b. (a -> b) -> a -> b
$ [Text]
x forall a. [a] -> [a] -> [a]
++ [Text]
y
(FormFailure [Text]
x) <*> FormResult a
_ = forall a. [Text] -> FormResult a
FormFailure [Text]
x
FormResult (a -> b)
_ <*> (FormFailure [Text]
y) = forall a. [Text] -> FormResult a
FormFailure [Text]
y
FormResult (a -> b)
_ <*> FormResult a
_ = forall a. FormResult a
FormMissing
instance Data.Monoid.Monoid m => Monoid (FormResult m) where
mempty :: FormResult m
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
mappend :: FormResult m -> FormResult m -> FormResult m
mappend FormResult m
x FormResult m
y = forall a. Monoid a => a -> a -> a
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult m
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult m
y
instance Semigroup m => Semigroup (FormResult m) where
FormResult m
x <> :: FormResult m -> FormResult m -> FormResult m
<> FormResult m
y = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> FormResult m
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult m
y
instance Data.Foldable.Foldable FormResult where
foldMap :: forall m a. Monoid m => (a -> m) -> FormResult a -> m
foldMap a -> m
f FormResult a
r = case FormResult a
r of
FormSuccess a
a -> a -> m
f a
a
FormFailure [Text]
_errs -> forall a. Monoid a => a
mempty
FormResult a
FormMissing -> forall a. Monoid a => a
mempty
instance Data.Traversable.Traversable FormResult where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FormResult a -> f (FormResult b)
traverse a -> f b
f FormResult a
r = case FormResult a
r of
FormSuccess a
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> FormResult a
FormSuccess (a -> f b
f a
a)
FormFailure [Text]
errs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [Text] -> FormResult a
FormFailure [Text]
errs)
FormResult a
FormMissing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. FormResult a
FormMissing
instance Alternative FormResult where
empty :: forall a. FormResult a
empty = forall a. FormResult a
FormMissing
FormFailure [Text]
e <|> :: forall a. FormResult a -> FormResult a -> FormResult a
<|> FormResult a
_ = forall a. [Text] -> FormResult a
FormFailure [Text]
e
FormResult a
_ <|> FormFailure [Text]
e = forall a. [Text] -> FormResult a
FormFailure [Text]
e
FormSuccess a
s <|> FormSuccess a
_ = forall a. a -> FormResult a
FormSuccess a
s
FormResult a
FormMissing <|> FormResult a
result = FormResult a
result
FormResult a
result <|> FormResult a
FormMissing = FormResult a
result
data Enctype = UrlEncoded | Multipart
deriving (Enctype -> Enctype -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Enctype -> Enctype -> Bool
$c/= :: Enctype -> Enctype -> Bool
== :: Enctype -> Enctype -> Bool
$c== :: Enctype -> Enctype -> Bool
Eq, Int -> Enctype
Enctype -> Int
Enctype -> [Enctype]
Enctype -> Enctype
Enctype -> Enctype -> [Enctype]
Enctype -> Enctype -> Enctype -> [Enctype]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Enctype -> Enctype -> Enctype -> [Enctype]
$cenumFromThenTo :: Enctype -> Enctype -> Enctype -> [Enctype]
enumFromTo :: Enctype -> Enctype -> [Enctype]
$cenumFromTo :: Enctype -> Enctype -> [Enctype]
enumFromThen :: Enctype -> Enctype -> [Enctype]
$cenumFromThen :: Enctype -> Enctype -> [Enctype]
enumFrom :: Enctype -> [Enctype]
$cenumFrom :: Enctype -> [Enctype]
fromEnum :: Enctype -> Int
$cfromEnum :: Enctype -> Int
toEnum :: Int -> Enctype
$ctoEnum :: Int -> Enctype
pred :: Enctype -> Enctype
$cpred :: Enctype -> Enctype
succ :: Enctype -> Enctype
$csucc :: Enctype -> Enctype
Enum, Enctype
forall a. a -> a -> Bounded a
maxBound :: Enctype
$cmaxBound :: Enctype
minBound :: Enctype
$cminBound :: Enctype
Bounded)
instance ToHtml Enctype where
toHtml UrlEncoded = "application/x-www-form-urlencoded"
toHtml Multipart = "multipart/form-data"
instance ToValue Enctype where
toValue :: Enctype -> AttributeValue
toValue Enctype
UrlEncoded = AttributeValue
"application/x-www-form-urlencoded"
toValue Enctype
Multipart = AttributeValue
"multipart/form-data"
instance Monoid Enctype where
mempty :: Enctype
mempty = Enctype
UrlEncoded
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Semigroup Enctype where
Enctype
UrlEncoded <> :: Enctype -> Enctype -> Enctype
<> Enctype
UrlEncoded = Enctype
UrlEncoded
Enctype
_ <> Enctype
_ = Enctype
Multipart
data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where
show :: Ints -> String
show (IntSingle Int
i) = forall a. Show a => a -> String
show Int
i
show (IntCons Int
i Ints
is) = forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ (Char
'-' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Ints
is)
type Env = Map.Map Text [Text]
type FileEnv = Map.Map Text [FileInfo]
type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a
type MForm m a = RWST
(Maybe (Env, FileEnv), HandlerSite m, [Lang])
Enctype
Ints
m
a
newtype AForm m a = AForm
{ forall (m :: * -> *) a.
AForm m a
-> (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
unAForm :: (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype)
}
instance Monad m => Functor (AForm m) where
fmap :: forall a b. (a -> b) -> AForm m a -> AForm m b
fmap a -> b
f (AForm (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
a) =
forall (m :: * -> *) a.
((HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype))
-> AForm m a
AForm forall a b. (a -> b) -> a -> b
$ \(HandlerSite m, [Text])
x Maybe (Env, FileEnv)
y Ints
z -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
-> (FormResult b,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
go forall a b. (a -> b) -> a -> b
$ (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
a (HandlerSite m, [Text])
x Maybe (Env, FileEnv)
y Ints
z
where
go :: (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
-> (FormResult b,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
go (FormResult a
w, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
x, Ints
y, Enctype
z) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f FormResult a
w, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
x, Ints
y, Enctype
z)
instance Monad m => Applicative (AForm m) where
pure :: forall a. a -> AForm m a
pure a
x = forall (m :: * -> *) a.
((HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype))
-> AForm m a
AForm forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \Ints
ints -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> FormResult a
FormSuccess a
x, forall a. a -> a
id, Ints
ints, forall a. Monoid a => a
mempty)
(AForm (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult (a -> b),
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
f) <*> :: forall a b. AForm m (a -> b) -> AForm m a -> AForm m b
<*> (AForm (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
g) = forall (m :: * -> *) a.
((HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype))
-> AForm m a
AForm forall a b. (a -> b) -> a -> b
$ \(HandlerSite m, [Text])
mr Maybe (Env, FileEnv)
env Ints
ints -> do
(FormResult (a -> b)
a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
b, Ints
ints', Enctype
c) <- (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult (a -> b),
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
f (HandlerSite m, [Text])
mr Maybe (Env, FileEnv)
env Ints
ints
(FormResult a
x, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
y, Ints
ints'', Enctype
z) <- (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype)
g (HandlerSite m, [Text])
mr Maybe (Env, FileEnv)
env Ints
ints'
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult (a -> b)
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult a
x, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
y, Ints
ints'', Enctype
c forall a. Monoid a => a -> a -> a
`mappend` Enctype
z)
#if MIN_VERSION_transformers(0,6,0)
instance Monad m => Monad (AForm m) where
(AForm f) >>= k = AForm $ \mr env ints -> do
(a, b, ints', c) <- f mr env ints
case a of
FormSuccess r -> do
(x, y, ints'', z) <- unAForm (k r) mr env ints'
return (x, b . y, ints'', c `mappend` z)
FormFailure err -> pure (FormFailure err, b, ints', c)
FormMissing -> pure (FormMissing, b, ints', c)
#endif
instance (Monad m, Monoid a) => Monoid (AForm m a) where
mempty :: AForm m a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
mappend :: AForm m a -> AForm m a -> AForm m a
mappend AForm m a
a AForm m a
b = forall a. Monoid a => a -> a -> a
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AForm m a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AForm m a
b
instance (Monad m, Semigroup a) => Semigroup (AForm m a) where
AForm m a
a <> :: AForm m a -> AForm m a -> AForm m a
<> AForm m a
b = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AForm m a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AForm m a
b
instance MonadTrans AForm where
lift :: forall (m :: * -> *) a. Monad m => m a -> AForm m a
lift m a
f = forall (m :: * -> *) a.
((HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
[FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
Enctype))
-> AForm m a
AForm forall a b. (a -> b) -> a -> b
$ \(HandlerSite m, [Text])
_ Maybe (Env, FileEnv)
_ Ints
ints -> do
a
x <- m a
f
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> FormResult a
FormSuccess a
x, forall a. a -> a
id, Ints
ints, forall a. Monoid a => a
mempty)
data FieldSettings master = FieldSettings
{ forall master. FieldSettings master -> SomeMessage master
fsLabel :: SomeMessage master
, forall master. FieldSettings master -> Maybe (SomeMessage master)
fsTooltip :: Maybe (SomeMessage master)
, forall master. FieldSettings master -> Maybe Text
fsId :: Maybe Text
, forall master. FieldSettings master -> Maybe Text
fsName :: Maybe Text
, forall master. FieldSettings master -> [(Text, Text)]
fsAttrs :: [(Text, Text)]
}
instance IsString (FieldSettings a) where
fromString :: String -> FieldSettings a
fromString String
s = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings (forall a. IsString a => String -> a
fromString String
s) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing []
data FieldView site = FieldView
{ forall site. FieldView site -> Markup
fvLabel :: Html
, forall site. FieldView site -> Maybe Markup
fvTooltip :: Maybe Html
, forall site. FieldView site -> Text
fvId :: Text
, forall site. FieldView site -> WidgetFor site ()
fvInput :: WidgetFor site ()
, forall site. FieldView site -> Maybe Markup
fvErrors :: Maybe Html
, forall site. FieldView site -> Bool
fvRequired :: Bool
}
type FieldViewFunc m a
= Text
-> Text
-> [(Text, Text)]
-> Either Text a
-> Bool
-> WidgetFor (HandlerSite m) ()
data Field m a = Field
{ forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
, forall (m :: * -> *) a. Field m a -> FieldViewFunc m a
fieldView :: FieldViewFunc m a
, forall (m :: * -> *) a. Field m a -> Enctype
fieldEnctype :: Enctype
}
data FormMessage = MsgInvalidInteger Text
| MsgInvalidNumber Text
| MsgInvalidEntry Text
| MsgInvalidUrl Text
| MsgInvalidEmail Text
| MsgInvalidTimeFormat
| MsgInvalidHour Text
| MsgInvalidMinute Text
| MsgInvalidSecond Text
| MsgInvalidDay
| MsgCsrfWarning
| MsgValueRequired
| MsgInputNotFound Text
| MsgSelectNone
| MsgInvalidBool Text
| MsgBoolYes
| MsgBoolNo
| MsgDelete
| MsgInvalidHexColorFormat Text
deriving (Int -> FormMessage -> ShowS
[FormMessage] -> ShowS
FormMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormMessage] -> ShowS
$cshowList :: [FormMessage] -> ShowS
show :: FormMessage -> String
$cshow :: FormMessage -> String
showsPrec :: Int -> FormMessage -> ShowS
$cshowsPrec :: Int -> FormMessage -> ShowS
Show, FormMessage -> FormMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormMessage -> FormMessage -> Bool
$c/= :: FormMessage -> FormMessage -> Bool
== :: FormMessage -> FormMessage -> Bool
$c== :: FormMessage -> FormMessage -> Bool
Eq, ReadPrec [FormMessage]
ReadPrec FormMessage
Int -> ReadS FormMessage
ReadS [FormMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FormMessage]
$creadListPrec :: ReadPrec [FormMessage]
readPrec :: ReadPrec FormMessage
$creadPrec :: ReadPrec FormMessage
readList :: ReadS [FormMessage]
$creadList :: ReadS [FormMessage]
readsPrec :: Int -> ReadS FormMessage
$creadsPrec :: Int -> ReadS FormMessage
Read)