fsLabel and fsTooltip are SomeMessage

This commit is contained in:
Michael Snoyman 2012-03-25 18:49:35 +02:00
parent 46308c8d1f
commit d464f85f9d
5 changed files with 19 additions and 21 deletions

View File

@ -22,8 +22,8 @@ class ToForm a where
-} -}
class ToField a master where class ToField a master where
toField :: (RenderMessage master msg, RenderMessage master FormMessage) toField :: RenderMessage master FormMessage
=> FieldSettings msg -> Maybe a -> AForm sub master a => FieldSettings master -> Maybe a -> AForm sub master a
{- FIXME {- FIXME
instance ToFormField String y where instance ToFormField String y where

View File

@ -463,7 +463,7 @@ selectFieldHelper outside onOpt inside opts' = Field
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
Just y -> Right $ Just y Just y -> Right $ Just y
fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo
fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of
@ -493,7 +493,7 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
} }
return (res, (fv :), ints', Multipart) return (res, (fv :), ints', Multipart)
fileAFormOpt :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master (Maybe FileInfo) fileAFormOpt :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master (Maybe FileInfo)
fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of

View File

@ -91,19 +91,17 @@ askFiles = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM snd x return $ liftM snd x
mreq :: (RenderMessage master msg, RenderMessage master FormMessage) mreq :: RenderMessage master FormMessage
=> Field sub master a -> FieldSettings msg -> Maybe a => Field sub master a -> FieldSettings master -> Maybe a
-> MForm sub master (FormResult a, FieldView sub master) -> MForm sub master (FormResult a, FieldView sub master)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
mopt :: RenderMessage master msg mopt :: Field sub master a -> FieldSettings master -> Maybe (Maybe a)
=> Field sub master a -> FieldSettings msg -> Maybe (Maybe a)
-> MForm sub master (FormResult (Maybe a), FieldView sub master) -> MForm sub master (FormResult (Maybe a), FieldView sub master)
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: RenderMessage master msg mhelper :: Field sub master a
=> Field sub master a -> FieldSettings master
-> FieldSettings msg
-> Maybe a -> Maybe a
-> (master -> [Text] -> FormResult b) -- ^ on missing -> (master -> [Text] -> FormResult b) -- ^ on missing
-> (a -> FormResult b) -- ^ on success -> (a -> FormResult b) -- ^ on success
@ -140,14 +138,13 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq , fvRequired = isReq
}) })
areq :: (RenderMessage master msg, RenderMessage master FormMessage) areq :: RenderMessage master FormMessage
=> Field sub master a -> FieldSettings msg -> Maybe a => Field sub master a -> FieldSettings master -> Maybe a
-> AForm sub master a -> AForm sub master a
areq a b = formToAForm . fmap (second return) . mreq a b areq a b = formToAForm . fmap (second return) . mreq a b
aopt :: RenderMessage master msg aopt :: Field sub master a
=> Field sub master a -> FieldSettings master
-> FieldSettings msg
-> Maybe (Maybe a) -> Maybe (Maybe a)
-> AForm sub master (Maybe a) -> AForm sub master (Maybe a)
aopt a b = formToAForm . fmap (second return) . mopt a b aopt a b = formToAForm . fmap (second return) . mopt a b
@ -347,7 +344,7 @@ customErrorMessage msg field = field { fieldParse = \ts -> fmap (either
(const $ Left msg) Right) $ fieldParse field ts } (const $ Left msg) Right) $ fieldParse field ts }
-- | Generate a 'FieldSettings' from the given label. -- | Generate a 'FieldSettings' from the given label.
fieldSettingsLabel :: msg -> FieldSettings msg fieldSettingsLabel :: SomeMessage master -> FieldSettings master
fieldSettingsLabel msg = FieldSettings msg Nothing Nothing Nothing [] fieldSettingsLabel msg = FieldSettings msg Nothing Nothing Nothing []
-- | Generate an 'AForm' that gets its value from the given action. -- | Generate an 'AForm' that gets its value from the given action.

View File

@ -24,6 +24,7 @@ import Data.Either (partitionEithers)
import Data.Traversable (sequenceA) import Data.Traversable (sequenceA)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Yesod.Core (SomeMessage (SomeMessage))
down :: Int -> MForm sub master () down :: Int -> MForm sub master ()
down 0 = return () down 0 = return ()
@ -97,7 +98,7 @@ withDelete af = do
Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|] Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|]
_ -> do _ -> do
(_, xml2) <- aFormToForm $ areq boolField FieldSettings (_, xml2) <- aFormToForm $ areq boolField FieldSettings
{ fsLabel = MsgDelete { fsLabel = SomeMessage MsgDelete
, fsTooltip = Nothing , fsTooltip = Nothing
, fsName = Just deleteName , fsName = Just deleteName
, fsId = Nothing , fsId = Nothing

View File

@ -94,9 +94,9 @@ instance Monoid a => Monoid (AForm sub master a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
data FieldSettings msg = FieldSettings data FieldSettings master = FieldSettings
{ fsLabel :: msg -- FIXME switch to SomeMessage? { fsLabel :: SomeMessage master
, fsTooltip :: Maybe msg , fsTooltip :: Maybe (SomeMessage master)
, fsId :: Maybe Text , fsId :: Maybe Text
, fsName :: Maybe Text , fsName :: Maybe Text
, fsAttrs :: [(Text, Text)] , fsAttrs :: [(Text, Text)]