module Yesod.Form.Core
( FormResult (..)
, GForm (..)
, newFormIdent
, deeperFormIdent
, shallowerFormIdent
, Env
, FileEnv
, Enctype (..)
, Ints (..)
, requiredFieldHelper
, optionalFieldHelper
, fieldsToInput
, mapFormXml
, checkForm
, checkField
, askParams
, askFiles
, liftForm
, IsForm (..)
, RunForm (..)
, GFormMonad
, FieldInfo (..)
, FormFieldSettings (..)
, FieldProfile (..)
, Form
, Formlet
, FormField
, FormletField
, FormInput
) where
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
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
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
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
newtype GForm s m xml a = GForm
{ deform :: FormInner s m (FormResult a, xml, Enctype)
}
type GFormMonad s m a = WriterT Enctype (FormInner s m) a
type FormInner s m =
StateT Ints (
ReaderT Env (
ReaderT FileEnv (
GHandler s m
)))
type Env = [(Text, Text)]
type FileEnv = [(Text, FileInfo)]
newFormIdent :: Monad m => StateT Ints m Text
newFormIdent = do
i <- get
let i' = incrInts i
put i'
return $ pack $ 'f' : show i'
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
instance Monoid xml => Functor (GForm sub url xml) where
fmap f (GForm g) =
GForm $ liftM (first3 $ fmap f) g
where
first3 f' (x, y, z) = (f' x, y, z)
instance Monoid xml => Applicative (GForm sub url xml) where
pure a = GForm $ return (pure a, mempty, mempty)
(GForm f) <*> (GForm g) = GForm $ do
(f1, f2, f3) <- f
(g1, g2, g3) <- g
return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
requiredFieldHelper
:: IsForm f
=> FieldProfile (FormSub f) (FormMaster f) (FormType f)
-> FormFieldSettings
-> Maybe (FormType f)
-> f
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
env <- lift ask
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 = 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, UrlEncoded)
class IsForm f where
type FormSub f
type FormMaster f
type FormType f
toForm :: FormInner
(FormSub f)
(FormMaster f)
(FormResult (FormType f),
FieldInfo (FormSub f) (FormMaster f),
Enctype) -> f
instance IsForm (FormField s m a) where
type FormSub (FormField s m a) = s
type FormMaster (FormField s m a) = m
type FormType (FormField s m a) = a
toForm x = GForm $ do
(a, b, c) <- x
return (a, [b], c)
instance (FormResult ~ formResult) => IsForm (GFormMonad s m (formResult a, FieldInfo s m)) where
type FormSub (GFormMonad s m (formResult a, FieldInfo s m)) = s
type FormMaster (GFormMonad s m (formResult a, FieldInfo s m)) = m
type FormType (GFormMonad s m (formResult a, FieldInfo s m)) = a
toForm x = do
(res, fi, enctype) <- lift x
tell enctype
return (res, fi)
class RunForm f where
type RunFormSub f
type RunFormMaster f
type RunFormType f
runFormGeneric :: Env -> FileEnv -> f
-> GHandler (RunFormSub f)
(RunFormMaster f)
(RunFormType f)
instance RunForm (GForm s m xml a) where
type RunFormSub (GForm s m xml a) = s
type RunFormMaster (GForm s m xml a) = m
type RunFormType (GForm s m xml a) =
(FormResult a, xml, Enctype)
runFormGeneric env fe (GForm f) =
runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
instance RunForm (GFormMonad s m a) where
type RunFormSub (GFormMonad s m a) = s
type RunFormMaster (GFormMonad s m a) = m
type RunFormType (GFormMonad s m a) = (a, Enctype)
runFormGeneric e fe f =
runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe
optionalFieldHelper
:: (IsForm f, Maybe b ~ FormType f)
=> FieldProfile (FormSub f) (FormMaster f) b
-> FormFieldSettings
-> Maybe (Maybe b)
-> f
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
env <- lift ask
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, UrlEncoded)
fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
fieldsToInput = map fiInput
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
mapFormXml f (GForm g) = GForm $ do
(res, xml, enc) <- g
return (res, f xml, enc)
data FieldInfo sub y = FieldInfo
{ fiLabel :: Html
, fiTooltip :: Html
, fiIdent :: Text
, fiInput :: GWidget sub y ()
, 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
data FieldProfile sub y a = FieldProfile
{ fpParse :: Text -> Either Text a
, fpRender :: a -> Text
, fpWidget :: Text -> Text -> Text -> Bool -> 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 ()]
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)
checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b
checkField f (GForm form) = GForm $ 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 :: Monad m => StateT Ints (ReaderT Env m) Env
askParams = lift ask
askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv
askFiles = lift $ lift ask
liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a
liftForm = lift . lift . lift