f62f513c63
Types are less polymorphic and hopefully much easier to use/understand. Also, introduced SomeMessage existential type, should make field reuse much simpler.
72 lines
2.7 KiB
Haskell
72 lines
2.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Yesod.Form.Input
|
|
( FormInput (..)
|
|
, runInputGet
|
|
, runInputPost
|
|
, ireq
|
|
, iopt
|
|
) where
|
|
|
|
import Yesod.Form.Types
|
|
import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
|
|
import Data.Text (Text)
|
|
import Control.Applicative (Applicative (..))
|
|
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler)
|
|
import Yesod.Request (reqGetParams, languages)
|
|
import Control.Monad (liftM)
|
|
import Yesod.Widget (GWidget)
|
|
import Yesod.Message (RenderMessage (..))
|
|
|
|
type DText = [Text] -> [Text]
|
|
newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) }
|
|
instance Functor (FormInput sub master) where
|
|
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
|
|
instance Applicative (FormInput sub master) where
|
|
pure = FormInput . const . const . const . return . Right
|
|
(FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
|
|
res1 <- f c d e
|
|
res2 <- x c d e
|
|
return $ case (res1, res2) of
|
|
(Left a, Left b) -> Left $ a . b
|
|
(Left a, _) -> Left a
|
|
(_, Left b) -> Left b
|
|
(Right a, Right b) -> Right $ a b
|
|
|
|
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
|
|
ireq field name = FormInput $ \m l env -> do
|
|
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
|
emx <- fieldParse field $ filteredEnv
|
|
return $ case emx of
|
|
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
|
|
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
|
Right (Just a) -> Right a
|
|
|
|
iopt :: RenderMessage master msg => Field sub master a -> Text -> FormInput sub master (Maybe a)
|
|
iopt field name = FormInput $ \m l env -> do
|
|
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
|
emx <- fieldParse field $ filteredEnv
|
|
return $ case emx of
|
|
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
|
|
Right x -> Right x
|
|
|
|
runInputGet :: FormInput sub master a -> GHandler sub master a
|
|
runInputGet (FormInput f) = do
|
|
env <- liftM reqGetParams getRequest
|
|
m <- getYesod
|
|
l <- languages
|
|
emx <- liftIOHandler $ f m l env
|
|
case emx of
|
|
Left errs -> invalidArgs $ errs []
|
|
Right x -> return x
|
|
|
|
runInputPost :: FormInput sub master a -> GHandler sub master a
|
|
runInputPost (FormInput f) = do
|
|
env <- liftM fst runRequestBody
|
|
m <- getYesod
|
|
l <- languages
|
|
emx <- liftIOHandler $ f m l env
|
|
case emx of
|
|
Left errs -> invalidArgs $ errs []
|
|
Right x -> return x
|