{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Form.Types
    ( -- * Helpers
      Enctype (..)
    , FormResult (..)
    , FormMessage (..)
    , Env
    , FileEnv
    , Ints (..)
      -- * Form
    , WForm
    , MForm
    , AForm (..)
      -- * Build forms
    , 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

-- | 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.
-- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess',
-- and 'FormMissing' last of all.
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

-- | @since 1.4.5
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

-- | @since 1.4.5
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

-- | @since 1.4.15
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

-- | The encoding type required by a form. The 'ToHtml' instance produces values
-- that can be inserted directly into HTML.
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]

-- | 'MForm' variant stacking a 'WriterT'. The following code example using a
-- monadic form 'MForm':
--
-- > formToAForm $ do
-- >   (field1F, field1V) <- mreq textField MsgField1 Nothing
-- >   (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing
-- >   (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing
-- >   return
-- >     ( MyForm <$> field1F <*> field2F <*> field3F
-- >     , [field1V, field2V, field3V]
-- >     )
--
-- Could be rewritten as follows using 'WForm':
--
-- > wFormToAForm $ do
-- >   field1F <- wreq textField MsgField1 Nothing
-- >   field2F <- wreq (checkWith field1F textField) MsgField2 Nothing
-- >   field3F <- wreq (checkWith field1F textField) MsgField3 Nothing
-- >   return $ MyForm <$> field1F <*> field2F <*> field3F
--
-- @since 1.4.14
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)
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 -- ^ ID
   -> Text -- ^ Name
   -> [(Text, Text)] -- ^ Attributes
   -> Either Text a -- ^ Either (invalid text) or (legitimate result)
   -> Bool -- ^ Required?
   -> 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)