i18n, not entirely complete
This commit is contained in:
Michael Snoyman
parent
e7ca38515d
commit
87535d468b
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Form.Class
|
||||
( ToForm (..)
|
||||
, ToField (..)
|
||||
@ -15,12 +16,13 @@ import Data.Int (Int64)
|
||||
import Data.Time (Day, TimeOfDay)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Handler (GGHandler)
|
||||
import Yesod.Message (RenderMessage)
|
||||
|
||||
class ToForm a master monad where
|
||||
toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) monad a
|
||||
toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
|
||||
|
||||
class ToField a master monad where
|
||||
toField :: FieldSettings -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) monad a
|
||||
toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
|
||||
|
||||
{- FIXME
|
||||
instance ToFormField String y where
|
||||
@ -29,44 +31,44 @@ instance ToFormField (Maybe String) y where
|
||||
toFormField = maybeStringField
|
||||
-}
|
||||
|
||||
instance Monad m => ToField Text master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
|
||||
toField = areq textField
|
||||
instance Monad m => ToField (Maybe Text) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where
|
||||
toField = aopt textField
|
||||
|
||||
instance Monad m => ToField Int master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
|
||||
toField = areq intField
|
||||
instance Monad m => ToField (Maybe Int) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where
|
||||
toField = aopt intField
|
||||
|
||||
instance Monad m => ToField Int64 master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
|
||||
toField = areq intField
|
||||
instance Monad m => ToField (Maybe Int64) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where
|
||||
toField = aopt intField
|
||||
|
||||
instance Monad m => ToField Double master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
|
||||
toField = areq doubleField
|
||||
instance Monad m => ToField (Maybe Double) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where
|
||||
toField = aopt doubleField
|
||||
|
||||
instance Monad m => ToField Day master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
|
||||
toField = areq dayField
|
||||
instance Monad m => ToField (Maybe Day) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where
|
||||
toField = aopt dayField
|
||||
|
||||
instance Monad m => ToField TimeOfDay master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
|
||||
toField = areq timeField
|
||||
instance Monad m => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
|
||||
toField = aopt timeField
|
||||
|
||||
instance Monad m => ToField Html master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
|
||||
toField = areq htmlField
|
||||
instance Monad m => ToField (Maybe Html) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where
|
||||
toField = aopt htmlField
|
||||
|
||||
instance Monad m => ToField Textarea master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
|
||||
toField = areq textareaField
|
||||
instance Monad m => ToField (Maybe Textarea) master (GGHandler sub master m) where
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where
|
||||
toField = aopt textareaField
|
||||
|
||||
{- FIXME
|
||||
|
||||
@ -3,7 +3,9 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Form.Fields
|
||||
( textField
|
||||
( FormMessage (..)
|
||||
, defaultFormMessage
|
||||
, textField
|
||||
, passwordField
|
||||
, textareaField
|
||||
, hiddenField
|
||||
@ -13,6 +15,7 @@ module Yesod.Form.Fields
|
||||
, htmlField
|
||||
, emailField
|
||||
, searchField
|
||||
, selectField
|
||||
, AutoFocus
|
||||
, urlField
|
||||
, doubleField
|
||||
@ -41,6 +44,8 @@ import Text.Blaze.Renderer.String (renderHtml)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text (Text, unpack, pack)
|
||||
import qualified Data.Text.Read
|
||||
import Data.Monoid (mappend)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
@ -54,9 +59,32 @@ import Data.Text (Text, unpack, pack)
|
||||
#define JULIUS $julius
|
||||
#endif
|
||||
|
||||
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) i
|
||||
data FormMessage = MsgInvalidInteger Text
|
||||
| MsgInvalidNumber Text
|
||||
| MsgInvalidEntry Text
|
||||
| MsgInvalidUrl Text
|
||||
| MsgInvalidEmail Text
|
||||
| MsgInvalidTimeFormat
|
||||
| MsgInvalidHour Text
|
||||
| MsgInvalidMinute Text
|
||||
| MsgInvalidSecond Text
|
||||
| MsgInvalidDay
|
||||
|
||||
defaultFormMessage :: FormMessage -> Text
|
||||
defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidNumber t) = "Invalid number: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidEntry t) = "Invalid entry: " `mappend` t
|
||||
defaultFormMessage MsgInvalidTimeFormat = "Invalid time, must be in HH:MM[:SS] format"
|
||||
defaultFormMessage MsgInvalidDay = "Invalid day, must be in YYYY-MM-DD format"
|
||||
defaultFormMessage (MsgInvalidUrl t) = "Invalid URL: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidEmail t) = "Invalid e-mail address: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t
|
||||
defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t
|
||||
|
||||
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
|
||||
intField = Field
|
||||
{ fieldParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
|
||||
{ fieldParse = \s -> maybe (Left $ MsgInvalidInteger s) Right . readMayI $ unpack s -- FIXME Data.Text.Read
|
||||
, fieldRender = pack . showI
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
@ -69,9 +97,9 @@ intField = Field
|
||||
(x, _):_ -> Just $ fromInteger x
|
||||
[] -> Nothing
|
||||
|
||||
doubleField :: Monad monad => Field (GGWidget master monad ()) Double
|
||||
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
|
||||
doubleField = Field
|
||||
{ fieldParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
|
||||
{ fieldParse = \s -> maybe (Left $ MsgInvalidNumber s) Right . readMay $ unpack s -- FIXME use Data.Text.Read
|
||||
, fieldRender = pack . show
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
@ -79,7 +107,7 @@ doubleField = Field
|
||||
|]
|
||||
}
|
||||
|
||||
dayField :: Monad monad => Field (GGWidget master monad ()) Day
|
||||
dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
|
||||
dayField = Field
|
||||
{ fieldParse = parseDate . unpack
|
||||
, fieldRender = pack . show
|
||||
@ -89,7 +117,7 @@ dayField = Field
|
||||
|]
|
||||
}
|
||||
|
||||
timeField :: Monad monad => Field (GGWidget master monad ()) TimeOfDay
|
||||
timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
|
||||
timeField = Field
|
||||
{ fieldParse = parseTime . unpack
|
||||
, fieldRender = pack . show . roundFullSeconds
|
||||
@ -104,7 +132,7 @@ timeField = Field
|
||||
where
|
||||
fullSec = fromInteger $ floor $ todSec tod
|
||||
|
||||
htmlField :: Monad monad => Field (GGWidget master monad ()) Html
|
||||
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
|
||||
htmlField = Field
|
||||
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
||||
, fieldRender = pack . renderHtml
|
||||
@ -132,7 +160,7 @@ instance ToHtml Textarea where
|
||||
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
||||
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
||||
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) Textarea
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = Right . Textarea
|
||||
, fieldRender = unTextarea
|
||||
@ -142,7 +170,7 @@ textareaField = Field
|
||||
|]
|
||||
}
|
||||
|
||||
hiddenField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
hiddenField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
@ -152,7 +180,7 @@ hiddenField = Field
|
||||
|]
|
||||
}
|
||||
|
||||
textField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
textField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
@ -162,7 +190,7 @@ textField = Field
|
||||
|]
|
||||
}
|
||||
|
||||
passwordField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
passwordField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
@ -177,8 +205,8 @@ readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
parseDate :: String -> Either Text Day
|
||||
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
|
||||
parseDate :: String -> Either FormMessage Day
|
||||
parseDate = maybe (Left MsgInvalidDay) Right
|
||||
. readMay . replace '/' '-'
|
||||
|
||||
-- | Replaces all instances of a value in a list by another value.
|
||||
@ -186,7 +214,7 @@ parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
|
||||
replace :: Eq a => a -> a -> [a] -> [a]
|
||||
replace x y = map (\z -> if z == x then y else z)
|
||||
|
||||
parseTime :: String -> Either Text TimeOfDay
|
||||
parseTime :: String -> Either FormMessage TimeOfDay
|
||||
parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
|
||||
@ -196,25 +224,25 @@ parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
|
||||
in parseTimeHelper (h1', h2', m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
|
||||
parseTime _ = Left MsgInvalidTimeFormat
|
||||
|
||||
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
|
||||
-> Either Text TimeOfDay
|
||||
-> Either FormMessage TimeOfDay
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
| h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h
|
||||
| m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m
|
||||
| s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s
|
||||
| h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
|
||||
| m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
|
||||
| s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
|
||||
| otherwise = Right $ TimeOfDay h m s
|
||||
where
|
||||
h = read [h1, h2]
|
||||
h = read [h1, h2] -- FIXME isn't this a really bad idea?
|
||||
m = read [m1, m2]
|
||||
s = fromInteger $ read [s1, s2]
|
||||
|
||||
emailField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
emailField = Field
|
||||
{ fieldParse = \s -> if Email.isValid (unpack s)
|
||||
then Right s
|
||||
else Left "Invalid e-mail address"
|
||||
else Left $ MsgInvalidEmail s
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
@ -223,7 +251,7 @@ emailField = Field
|
||||
}
|
||||
|
||||
type AutoFocus = Bool
|
||||
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) Text
|
||||
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
|
||||
searchField autoFocus = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
@ -240,10 +268,10 @@ searchField autoFocus = Field
|
||||
|]
|
||||
}
|
||||
|
||||
urlField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
urlField = Field
|
||||
{ fieldParse = \s -> case parseURI $ unpack s of
|
||||
Nothing -> Left "Invalid URL"
|
||||
Nothing -> Left $ MsgInvalidUrl s
|
||||
Just _ -> Right s
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHtml
|
||||
@ -251,3 +279,25 @@ urlField = Field
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|
||||
|]
|
||||
}
|
||||
|
||||
selectField :: (Eq a, Monad monad) => [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
||||
selectField opts = Field -- FIXME won't work for optional yet
|
||||
{ fieldParse = \s ->
|
||||
case Data.Text.Read.decimal s of
|
||||
Right (a, "") ->
|
||||
case lookup a pairs of
|
||||
Nothing -> Left $ MsgInvalidEntry s
|
||||
Just x -> Right $ snd x
|
||||
_ -> Left $ MsgInvalidNumber s
|
||||
, fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
<select id=#{theId} name=#{name}
|
||||
$if not isReq
|
||||
<option value=none>
|
||||
$forall pair <- pairs
|
||||
<option value=#{show $ fst pair} :(==) val (fst $ snd pair):selected>#{fst $ snd pair}
|
||||
|]
|
||||
}
|
||||
where
|
||||
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
||||
rpairs = zip (map snd opts) [1 :: Int ..]
|
||||
|
||||
@ -31,13 +31,15 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM, join)
|
||||
import Text.Blaze (Html, toHtml)
|
||||
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent)
|
||||
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
|
||||
import Yesod.Core (RenderMessage)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
|
||||
import Network.Wai (requestMethod)
|
||||
import Text.Hamlet.NonPoly (html)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
@ -48,7 +50,7 @@ import Data.Maybe (fromMaybe)
|
||||
#endif
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newFormIdent :: Monad m => Form m Text
|
||||
newFormIdent :: Monad m => Form msg m Text
|
||||
newFormIdent = do
|
||||
i <- get
|
||||
let i' = incrInts i
|
||||
@ -58,56 +60,65 @@ newFormIdent = do
|
||||
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
||||
|
||||
formToAForm :: Monad m => Form m (FormResult a, xml) -> AForm ([xml] -> [xml]) m a
|
||||
formToAForm form = AForm $ \env ints -> do
|
||||
((a, xml), ints', enc) <- runRWST form env ints
|
||||
formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a
|
||||
formToAForm form = AForm $ \(master, langs) env ints -> do
|
||||
((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
|
||||
return (a, (:) xml, ints', enc)
|
||||
|
||||
aFormToForm :: Monad m => AForm xml m a -> Form m (FormResult a, xml)
|
||||
aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)
|
||||
aFormToForm (AForm aform) = do
|
||||
ints <- get
|
||||
env <- ask
|
||||
(a, xml, ints', enc) <- lift $ aform env ints
|
||||
(env, master, langs) <- ask
|
||||
(a, xml, ints', enc) <- lift $ aform (master, langs) env ints
|
||||
put ints'
|
||||
tell enc
|
||||
return (a, xml)
|
||||
|
||||
askParams :: Monad m => Form m (Maybe Env)
|
||||
askParams = liftM (liftM fst) ask
|
||||
askParams :: Monad m => Form msg m (Maybe Env)
|
||||
askParams = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM fst x
|
||||
|
||||
askFiles :: Monad m => Form m (Maybe FileEnv)
|
||||
askFiles = liftM (liftM snd) ask
|
||||
askFiles :: Monad m => Form msg m (Maybe FileEnv)
|
||||
askFiles = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM snd x
|
||||
|
||||
mreq :: Monad m => Field xml a -> FieldSettings -> Maybe a
|
||||
-> Form (GGHandler sub master m) (FormResult a, FieldView xml)
|
||||
mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe a
|
||||
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
|
||||
mreq field fs mdef = mhelper field fs mdef (FormFailure ["Value is required"]) FormSuccess True -- TRANS
|
||||
|
||||
mopt :: Monad m => Field xml a -> FieldSettings -> Maybe (Maybe a)
|
||||
-> Form (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
|
||||
mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
|
||||
mopt field fs mdef = mhelper field fs (join mdef) (FormSuccess Nothing) (FormSuccess . Just) False
|
||||
|
||||
mhelper :: Monad m
|
||||
=> Field xml a
|
||||
-> FieldSettings
|
||||
mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a
|
||||
-> FieldSettings msg2
|
||||
-> Maybe a
|
||||
-> FormResult b -- ^ on missing
|
||||
-> (a -> FormResult b) -- ^ on success
|
||||
-> Bool -- ^ is it required?
|
||||
-> Form (GGHandler sub master m) (FormResult b, FieldView xml)
|
||||
-> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
|
||||
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
mp <- askParams
|
||||
name <- maybe newFormIdent return fsName
|
||||
theId <- lift $ maybe (liftM pack newIdent) return fsId
|
||||
(_, master, langs) <- ask
|
||||
let mr = renderMessage master langs
|
||||
let mr2 = renderMessage master langs
|
||||
let (res, val) =
|
||||
case mp of
|
||||
Nothing -> (FormMissing, maybe "" fieldRender mdef)
|
||||
Just p ->
|
||||
case fromMaybe "" $ lookup name p of
|
||||
"" -> (onMissing, "") -- TRANS
|
||||
x -> (either (FormFailure . return) onFound $ fieldParse x, x)
|
||||
x -> (either (FormFailure . return . mr) onFound $ fieldParse x, x)
|
||||
return (res, FieldView
|
||||
{ fvLabel = fsLabel
|
||||
, fvTooltip = fsTooltip
|
||||
{ fvLabel = toHtml $ mr2 fsLabel
|
||||
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
|
||||
, fvId = theId
|
||||
, fvInput = fieldView theId name val isReq
|
||||
, fvErrors =
|
||||
@ -117,18 +128,20 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
, fvRequired = isReq
|
||||
})
|
||||
|
||||
areq :: Monad m => Field xml a -> FieldSettings -> Maybe a
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) (GGHandler sub master m) a
|
||||
areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe a
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
|
||||
areq a b = formToAForm . mreq a b
|
||||
|
||||
aopt :: Monad m => Field xml a -> FieldSettings -> Maybe (Maybe a)
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) (GGHandler sub master m) (Maybe a)
|
||||
aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
|
||||
aopt a b = formToAForm . mopt a b
|
||||
|
||||
runFormGeneric :: Monad m => Form m a -> Maybe (Env, FileEnv) -> m (a, Enctype)
|
||||
runFormGeneric form env = evalRWST form env (IntSingle 1)
|
||||
runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)
|
||||
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
|
||||
|
||||
runFormPost :: (Html -> Form (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPost :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPost form = do
|
||||
req <- getRequest
|
||||
let nonceKey = "_nonce"
|
||||
@ -139,7 +152,9 @@ runFormPost form = do
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
((res, xml), enctype) <- runFormGeneric (form nonce) env
|
||||
m <- getYesod
|
||||
langs <- languages
|
||||
((res, xml), enctype) <- runFormGeneric (form nonce) m langs env
|
||||
let res' =
|
||||
case (res, env) of
|
||||
(FormSuccess{}, Just (params, _))
|
||||
@ -151,15 +166,17 @@ runFormPost form = do
|
||||
csrfWarning :: Text
|
||||
csrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission." -- TRANS
|
||||
|
||||
runFormPostNoNonce :: (Html -> Form (GHandler sub master) a) -> GHandler sub master (a, Enctype)
|
||||
runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPostNoNonce form = do
|
||||
req <- getRequest
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
runFormGeneric (form mempty) env
|
||||
langs <- languages
|
||||
m <- getYesod
|
||||
runFormGeneric (form mempty) m langs env
|
||||
|
||||
runFormGet :: Monad m => (Html -> Form (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
|
||||
runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
|
||||
runFormGet form = do
|
||||
let key = "_hasdata"
|
||||
let fragment = [HTML|<input type=hidden name=#{key}>|]
|
||||
@ -168,14 +185,16 @@ runFormGet form = do
|
||||
case lookup key gets of
|
||||
Nothing -> Nothing
|
||||
Just _ -> Just (gets, [])
|
||||
runFormGeneric (form fragment) env
|
||||
langs <- languages
|
||||
m <- getYesod
|
||||
runFormGeneric (form fragment) m langs env
|
||||
|
||||
type FormRender master m a =
|
||||
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) m a
|
||||
type FormRender master msg m a =
|
||||
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a
|
||||
-> Html
|
||||
-> Form m (FormResult a, GGWidget master m ())
|
||||
-> Form msg m (FormResult a, GGWidget master m ())
|
||||
|
||||
renderTable, renderDivs :: Monad m => FormRender master m a
|
||||
renderTable, renderDivs :: Monad m => FormRender master msg m a
|
||||
renderTable aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
|
||||
@ -10,47 +10,52 @@ module Yesod.Form.Input
|
||||
import Yesod.Form.Types
|
||||
import Data.Text (Text, append)
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest)
|
||||
import Yesod.Request (reqGetParams)
|
||||
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
|
||||
import Yesod.Request (reqGetParams, languages)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Control.Monad (liftM)
|
||||
import Yesod.Widget (GWidget)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
type DText = [Text] -> [Text]
|
||||
newtype FormInput a = FormInput { unFormInput :: Env -> Either DText a }
|
||||
instance Functor FormInput where
|
||||
fmap a (FormInput f) = FormInput $ \e -> either Left (Right . a) $ f e
|
||||
instance Applicative FormInput where
|
||||
pure = FormInput . const . Right
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \e ->
|
||||
case (f e, x e) of
|
||||
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
|
||||
instance Functor (FormInput master) where
|
||||
fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
|
||||
instance Applicative (FormInput master) where
|
||||
pure = FormInput . const . const . const . Right
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
|
||||
case (f c d e, x c d e) of
|
||||
(Left a, Left b) -> Left $ a . b
|
||||
(Left a, _) -> Left a
|
||||
(_, Left b) -> Left b
|
||||
(Right a, Right b) -> Right $ a b
|
||||
|
||||
ireq :: Field (GWidget sub master ()) a -> Text -> FormInput a
|
||||
ireq field name = FormInput $ \env ->
|
||||
ireq :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
|
||||
ireq field name = FormInput $ \m l env ->
|
||||
case lookup name env of
|
||||
Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
|
||||
Just x -> either (Left . (:)) Right $ fieldParse field x
|
||||
Just x -> either (Left . (:) . renderMessage m l) Right $ fieldParse field x
|
||||
|
||||
iopt :: Field (GWidget sub master ()) a -> Text -> FormInput (Maybe a)
|
||||
iopt field name = FormInput $ \env ->
|
||||
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
|
||||
iopt field name = FormInput $ \m l env ->
|
||||
case fromMaybe "" $ lookup name env of
|
||||
"" -> Right Nothing
|
||||
x -> either (Left . (:)) (Right . Just) $ fieldParse field x
|
||||
x -> either (Left . (:) . renderMessage m l) (Right . Just) $ fieldParse field x
|
||||
|
||||
runInputGet :: Monad monad => FormInput a -> GGHandler sub master monad a
|
||||
runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
|
||||
runInputGet (FormInput f) = do
|
||||
env <- liftM reqGetParams getRequest
|
||||
case f env of
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
runInputPost :: FormInput a -> GHandler sub master a
|
||||
runInputPost :: FormInput master a -> GHandler sub master a
|
||||
runInputPost (FormInput f) = do
|
||||
env <- liftM fst runRequestBody
|
||||
case f env of
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
@ -63,10 +63,10 @@ class YesodJquery a where
|
||||
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
||||
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||
|
||||
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) Day
|
||||
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
|
||||
jqueryDayField jds = Field
|
||||
{ fieldParse = maybe
|
||||
(Left "Invalid day, must be in YYYY-MM-DD format")
|
||||
(Left MsgInvalidDay)
|
||||
Right
|
||||
. readMay
|
||||
. unpack
|
||||
@ -118,7 +118,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
|
||||
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
|
||||
in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
|
||||
|
||||
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) UTCTime
|
||||
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
|
||||
jqueryDayTimeField = Field
|
||||
{ fieldParse = parseUTCTime . unpack
|
||||
, fieldRender = pack . jqueryDayTimeUTCTime
|
||||
@ -135,7 +135,7 @@ $(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}
|
||||
|]
|
||||
}
|
||||
|
||||
parseUTCTime :: String -> Either Text UTCTime
|
||||
parseUTCTime :: String -> Either FormMessage UTCTime
|
||||
parseUTCTime s =
|
||||
let (dateS, timeS) = break isSpace (dropWhile isSpace s)
|
||||
dateE = parseDate dateS
|
||||
@ -145,7 +145,7 @@ parseUTCTime s =
|
||||
ifRight (parseTime timeS)
|
||||
(UTCTime date . timeOfDayToTime)
|
||||
|
||||
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) Text
|
||||
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
|
||||
jqueryAutocompleteField src = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
|
||||
@ -26,7 +26,7 @@ class YesodNic a where
|
||||
urlNicEdit :: a -> Either (Route a) Text
|
||||
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||
|
||||
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) Html
|
||||
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
|
||||
nicHtmlField = Field
|
||||
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
|
||||
, fieldRender = pack . renderHtml
|
||||
|
||||
@ -69,38 +69,38 @@ instance Show Ints where
|
||||
type Env = [(Text, Text)] -- FIXME use a Map
|
||||
type FileEnv = [(Text, FileInfo)]
|
||||
|
||||
type Form m a = RWST (Maybe (Env, FileEnv)) Enctype Ints m a
|
||||
type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a
|
||||
|
||||
newtype AForm xml m a = AForm
|
||||
{ unAForm :: Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
|
||||
newtype AForm xml master m a = AForm
|
||||
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
|
||||
}
|
||||
instance Monad m => Functor (AForm xml m) where
|
||||
instance Monad m => Functor (AForm xml msg m) where
|
||||
fmap f (AForm a) =
|
||||
AForm $ \x y -> liftM go $ a x y
|
||||
AForm $ \x y z -> liftM go $ a x y z
|
||||
where
|
||||
go (w, x, y, z) = (fmap f w, x, y, z)
|
||||
instance (Monad m, Monoid xml) => Applicative (AForm xml m) where
|
||||
pure x = AForm $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
|
||||
(AForm f) <*> (AForm g) = AForm $ \env ints -> do
|
||||
(a, b, ints', c) <- f env ints
|
||||
(x, y, ints'', z) <- g env ints'
|
||||
instance (Monad m, Monoid xml) => Applicative (AForm xml msg m) where
|
||||
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
|
||||
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
(x, y, ints'', z) <- g mr env ints'
|
||||
return (a <*> x, b `mappend` y, ints'', c `mappend` z)
|
||||
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml m a) where
|
||||
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where
|
||||
mempty = pure mempty
|
||||
mappend a b = mappend <$> a <*> b
|
||||
instance Monoid xml => MonadTrans (AForm xml) where
|
||||
lift mx = AForm $ const $ \ints -> do
|
||||
instance Monoid xml => MonadTrans (AForm xml msg) where
|
||||
lift mx = AForm $ const $ const $ \ints -> do
|
||||
x <- mx
|
||||
return (pure x, mempty, ints, mempty)
|
||||
|
||||
data FieldSettings = FieldSettings
|
||||
{ fsLabel :: Html -- FIXME do we need Text?
|
||||
, fsTooltip :: Maybe Html
|
||||
data FieldSettings msg = FieldSettings
|
||||
{ fsLabel :: msg
|
||||
, fsTooltip :: Maybe msg
|
||||
, fsId :: Maybe Text
|
||||
, fsName :: Maybe Text
|
||||
}
|
||||
|
||||
instance IsString FieldSettings where
|
||||
instance IsString a => IsString (FieldSettings a) where
|
||||
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
|
||||
|
||||
data FieldView xml = FieldView
|
||||
@ -112,8 +112,8 @@ data FieldView xml = FieldView
|
||||
, fvRequired :: Bool
|
||||
}
|
||||
|
||||
data Field xml a = Field
|
||||
{ fieldParse :: Text -> Either Text a -- FIXME probably want to make this more sophisticated, handle no form, no field
|
||||
data Field xml msg a = Field
|
||||
{ fieldParse :: Text -> Either msg a -- FIXME probably want to make this more sophisticated, handle no form, no field
|
||||
, fieldRender :: a -> Text
|
||||
, fieldView :: Text -- ^ ID
|
||||
-> Text -- ^ name
|
||||
|
||||
@ -13,7 +13,7 @@ homepage: http://www.yesodweb.com/
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.8.1 && < 0.9
|
||||
, yesod-core >= 0.8.2 && < 0.9
|
||||
, time >= 1.1.4 && < 1.3
|
||||
, hamlet >= 0.8.1 && < 0.9
|
||||
, persistent >= 0.5 && < 0.6
|
||||
|
||||
Loading…
Reference in New Issue
Block a user