haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Preparing type changes for multiple select inputs.

Browse Source
This commit is contained in:
DavidM 2011-06-20 20:41:43 -04:00
parent 9ec28d5544
commit 64e2082049
6 changed files with 98 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
Yesod/Form/Fields.hs
View File

@ -104,10 +104,12 @@ defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
defaultFormMessage MsgBoolYes = "Yes" defaultFormMessage MsgBoolYes = "Yes"
defaultFormMessage MsgBoolNo = "No" defaultFormMessage MsgBoolNo = "No"
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a) blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
blank _ Nothing = Right Nothing blank _ [] = Right Nothing
blank _ (Just "") = Right Nothing blank _ ("":_) = Right Nothing
blank f (Just t) = either Left (Right . Just) $ f t blank f (x:_) = either Left (Right . Just) $ f x
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
intField = Field intField = Field
@ -115,13 +117,14 @@ intField = Field
case Data.Text.Read.signed Data.Text.Read.decimal s of case Data.Text.Read.signed Data.Text.Read.decimal s of
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s _ -> Left $ MsgInvalidInteger s
, fieldRender = pack . showI
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
|] |]
} }
where where
showVal = maybe "" (pack . showI)
showI x = show (fromIntegral x :: Integer) showI x = show (fromIntegral x :: Integer)
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
@ -130,33 +133,34 @@ doubleField = Field
case Data.Text.Read.double s of case Data.Text.Read.double s of
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s _ -> Left $ MsgInvalidNumber s
, fieldRender = pack . show
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
|] |]
} }
where showVal = maybe "" (pack . show)
dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
dayField = Field dayField = Field
{ fieldParse = blank $ parseDate . unpack { fieldParse = blank $ parseDate . unpack
, fieldRender = pack . show
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|] |]
} }
where showVal = maybe "" (pack . show)
timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
timeField = Field timeField = Field
{ fieldParse = blank $ parseTime . unpack { fieldParse = blank $ parseTime . unpack
, fieldRender = pack . show . roundFullSeconds
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|] |]
} }
where where
showVal = maybe "" (pack . show . roundFullSeconds)
roundFullSeconds tod = roundFullSeconds tod =
TimeOfDay (todHour tod) (todMin tod) fullSec TimeOfDay (todHour tod) (todMin tod) fullSec
where where
@ -165,12 +169,12 @@ timeField = Field
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
htmlField = Field htmlField = Field
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
, fieldRender = pack . renderHtml
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<textarea id="#{theId}" name="#{name}" .html>#{val} <textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|] |]
} }
where showVal = maybe "" (pack . renderHtml)
-- | A newtype wrapper around a 'String' that converts newlines to HTML -- | A newtype wrapper around a 'String' that converts newlines to HTML
-- br-tags. -- br-tags.
@ -192,41 +196,37 @@ instance ToHtml Textarea where
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
textareaField = Field textareaField = Field
{ fieldParse = blank $ Right . Textarea { fieldParse = blank $ Right . Textarea
, fieldRender = unTextarea
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<textarea id="#{theId}" name="#{name}">#{val} <textarea id="#{theId}" name="#{name}">#{maybe "" unTextarea val}
|] |]
} }
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
hiddenField = Field hiddenField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldRender = id
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input type="hidden" id="#{theId}" name="#{name}" value="#{val}"> <input type="hidden" id="#{theId}" name="#{name}" value="#{maybe "" id val}">
|] |]
} }
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
textField = Field textField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldRender = id
, fieldView = \theId name val isReq -> , fieldView = \theId name val isReq ->
[WHAMLET| [WHAMLET|
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{val}"> <input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{maybe "" id val}">
|] |]
} }
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
passwordField = Field passwordField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldRender = id
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{maybe "" id val}">
|] |]
} }
@ -274,21 +274,19 @@ emailField = Field
\s -> if Email.isValid (unpack s) \s -> if Email.isValid (unpack s)
then Right s then Right s
else Left $ MsgInvalidEmail s else Left $ MsgInvalidEmail s
, fieldRender = id
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{maybe "" id val}">
|] |]
} }
type AutoFocus = Bool type AutoFocus = Bool
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = blank Right { fieldParse = blank Right
, fieldRender = id
, fieldView = \theId name val isReq -> do , fieldView = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}"> <input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{maybe "" id val}">
|] |]
when autoFocus $ do when autoFocus $ do
addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
@ -305,10 +303,9 @@ urlField = Field
case parseURI $ unpack s of case parseURI $ unpack s of
Nothing -> Left $ MsgInvalidUrl s Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s Just _ -> Right s
, fieldRender = id
, fieldView = \theId name val isReq -> addHtml , fieldView = \theId name val isReq -> addHtml
[HAMLET| [HAMLET|
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}> <input ##{theId} name=#{name} type=url :isReq:required value=#{maybe "" id val}>
|] |]
} }
@ -334,29 +331,29 @@ radioField = selectFieldHelper
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
boolField = Field boolField = Field
{ fieldParse = \s -> { fieldParse = boolParser
case s of , fieldView = \theId name val isReq -> [WHAMLET|
Nothing -> Right Nothing $if not isReq
Just "" -> Right Nothing <input id=#{theId}-none type=radio name=#{name} value=none checked>
Just "none" -> Right Nothing <label for=#{theId}-none>_{MsgSelectNone}
Just "yes" -> Right $ Just True
Just "no" -> Right $ Just False
Just t -> Left $ MsgInvalidBool t
, fieldRender = \a -> if a then "yes" else "no"
, fieldView = \theId name val isReq -> [WHAMLET|
$if not isReq
<input id=#{theId}-none type=radio name=#{name} value=none :isNone val:checked>
<label for=#{theId}-none>_{MsgSelectNone}
<input id=#{theId}-yes type=radio name=#{name} value=yes :(==) val "yes":checked>
<input id=#{theId}-yes type=radio name=#{name} value=yes :maybe False id val:checked>
<label for=#{theId}-yes>_{MsgBoolYes} <label for=#{theId}-yes>_{MsgBoolYes}
<input id=#{theId}-no type=radio name=#{name} value=no :(==) val "no":checked> <input id=#{theId}-no type=radio name=#{name} value=no :maybe False not val:checked>
<label for=#{theId}-no>_{MsgBoolNo} <label for=#{theId}-no>_{MsgBoolNo}
|] |]
} }
where where
isNone val = not $ val `elem` ["yes", "no"] boolParser [] = Right Nothing
boolParser (x:_) = case x of
"" -> Right Nothing
"none" -> Right Nothing
"yes" -> Right $ Just True
"no" -> Right $ Just False
t -> Left $ MsgInvalidBool t
selectFieldHelper :: (Eq a, Monad monad) selectFieldHelper :: (Eq a, Monad monad)
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ()) => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
@ -364,29 +361,29 @@ selectFieldHelper :: (Eq a, Monad monad)
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ()) -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
selectFieldHelper outside onOpt inside opts = Field selectFieldHelper outside onOpt inside opts = Field
{ fieldParse = \s -> { fieldParse = selectParser
case s of
Nothing -> Right Nothing
Just "" -> Right Nothing
Just "none" -> Right Nothing
Just x ->
case Data.Text.Read.decimal x of
Right (a, "") ->
case lookup a pairs of
Nothing -> Left $ MsgInvalidEntry x
Just y -> Right $ Just $ snd y
_ -> Left $ MsgInvalidNumber x
, fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs
, fieldView = \theId name val isReq -> , fieldView = \theId name val isReq ->
outside theId name $ do outside theId name $ do
unless isReq $ onOpt theId name $ not $ val `elem` map (pack . show . fst) pairs unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
flip mapM_ pairs $ \pair -> inside flip mapM_ pairs $ \pair -> inside
theId theId
name name
(pack $ show $ fst pair) (pack $ show $ fst pair)
(val == pack (show $ fst pair)) ((render val) == pack (show $ fst pair))
(fst $ snd pair) (fst $ snd pair)
} }
where where
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
rpairs = zip (map snd opts) [1 :: Int ..] rpairs = zip (map snd opts) [1 :: Int ..]
render Nothing = ""
render (Just a) = maybe "" (pack . show) $ lookup a rpairs
selectParser [] = Right Nothing
selectParser (s:_) = case s of
"" -> Right Nothing
"none" -> Right Nothing
x -> case Data.Text.Read.decimal x of
Right (a, "") ->
case lookup a pairs of
Nothing -> Left $ MsgInvalidEntry x
Just y -> Right $ Just $ snd y
_ -> Left $ MsgInvalidNumber x

14
Yesod/Form/Functions.hs
View File

@ -40,7 +40,6 @@ import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod) import Network.Wai (requestMethod)
import Text.Hamlet.NonPoly (html) import Text.Hamlet.NonPoly (html)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Maybe (fromMaybe)
import Yesod.Message (RenderMessage (..)) import Yesod.Message (RenderMessage (..))
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -112,16 +111,15 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
let mr2 = renderMessage master langs let mr2 = renderMessage master langs
let (res, val) = let (res, val) =
case mp of case mp of
Nothing -> (FormMissing, maybe "" fieldRender mdef) Nothing -> (FormMissing, mdef)
Just p -> Just p ->
let mval = lookup name p let mvals = map snd $ filter (\(n,_) -> n == name) p
valB = fromMaybe "" mval in case fieldParse mvals of
in case fieldParse mval of Left e -> (FormFailure [renderMessage master langs e], Nothing) -- There is no way to retain the wrong value
Left e -> (FormFailure [renderMessage master langs e], valB)
Right mx -> Right mx ->
case mx of case mx of
Nothing -> (onMissing master langs, valB) Nothing -> (onMissing master langs, Nothing)
Just x -> (onFound x, valB) Just x -> (onFound x, Just x)
return (res, FieldView return (res, FieldView
{ fvLabel = toHtml $ mr2 fsLabel { fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip

12
Yesod/Form/Input.hs
View File

@ -33,14 +33,16 @@ instance Applicative (FormInput master) where
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
ireq field name = FormInput $ \m l env -> ireq field name = FormInput $ \m l env ->
case fieldParse field $ lookup name env of let filteredEnv = map snd $ filter (\y -> fst y == name) env
Left e -> Left $ (:) $ renderMessage m l e in case fieldParse field $ filteredEnv of
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Left e -> Left $ (:) $ renderMessage m l e
Right (Just a) -> Right a Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
Right (Just a) -> Right a
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a) iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
iopt field name = FormInput $ \m l env -> iopt field name = FormInput $ \m l env ->
case fieldParse field $ lookup name env of let filteredEnv = map snd $ filter (\y -> fst y == name) env
in case fieldParse field $ filteredEnv of
Left e -> Left $ (:) $ renderMessage m l e Left e -> Left $ (:) $ renderMessage m l e
Right x -> Right x Right x -> Right x

27
Yesod/Form/Jquery.hs
View File

@ -63,10 +63,15 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a) blankMulti :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
blank _ Nothing = Right Nothing blankMulti _ Nothing = Right Nothing
blank _ (Just "") = Right Nothing blankMulti _ (Just "") = Right Nothing
blank f (Just t) = either Left (Right . Just) $ f t blankMulti f (Just t) = either Left (Right . Just) $ f t
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
blank _ [] = Right Nothing
blank _ ("":_) = Right Nothing
blank f (x:_) = either Left (Right . Just) $ f x
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
jqueryDayField jds = Field jqueryDayField jds = Field
@ -75,10 +80,9 @@ jqueryDayField jds = Field
Right Right
. readMay . readMay
. unpack . unpack
, fieldRender = pack . show
, fieldView = \theId name val isReq -> do , fieldView = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs
@ -94,6 +98,7 @@ $(function(){$("##{theId}").datepicker({
|] |]
} }
where where
showVal = maybe "" (pack . show)
jsBool True = "true" :: Text jsBool True = "true" :: Text
jsBool False = "false" :: Text jsBool False = "false" :: Text
mos (Left i) = show i mos (Left i) = show i
@ -126,10 +131,9 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
jqueryDayTimeField = Field jqueryDayTimeField = Field
{ fieldParse = blank $ parseUTCTime . unpack { fieldParse = blank $ parseUTCTime . unpack
, fieldRender = pack . jqueryDayTimeUTCTime
, fieldView = \theId name val isReq -> do , fieldView = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs
@ -139,6 +143,8 @@ jqueryDayTimeField = Field
$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); $(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|] |]
} }
where
showVal = maybe "" (pack . jqueryDayTimeUTCTime)
parseUTCTime :: String -> Either FormMessage UTCTime parseUTCTime :: String -> Either FormMessage UTCTime
parseUTCTime s = parseUTCTime s =
@ -152,11 +158,10 @@ parseUTCTime s =
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
jqueryAutocompleteField src = Field jqueryAutocompleteField src = Field
{ fieldParse = Right { fieldParse = blank $ Right
, fieldRender = id
, fieldView = \theId name val isReq -> do , fieldView = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete> <input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{maybe "" id val}" .autocomplete>
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs

15
Yesod/Form/Nic.hs
View File

@ -26,15 +26,16 @@ class YesodNic a where
urlNicEdit :: a -> Either (Route a) Text urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a) blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
blank _ Nothing = Right Nothing blank _ [] = Right Nothing
blank _ (Just "") = Right Nothing blank _ ("":_) = Right Nothing
blank f (Just t) = either Left (Right . Just) $ f t blank f (x:_) = either Left (Right . Just) $ f x
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
nicHtmlField = Field nicHtmlField = Field
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fieldRender = pack . renderHtml
, fieldView = \theId name val _isReq -> do , fieldView = \theId name val _isReq -> do
addHtml addHtml
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -42,7 +43,7 @@ nicHtmlField = Field
#else #else
[$hamlet| [$hamlet|
#endif #endif
<textarea id="#{theId}" name="#{name}" .html>#{val} <textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|] |]
addScript' urlNicEdit addScript' urlNicEdit
addJulius addJulius
@ -54,6 +55,8 @@ nicHtmlField = Field
bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")}); bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});
|] |]
} }
where
showVal = maybe "" (pack . renderHtml)
addScript' :: (y -> Either (Route y) Text) -> GWidget sub y () addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addScript' f = do addScript' f = do

5
Yesod/Form/Types.hs
View File

@ -114,11 +114,10 @@ data FieldView xml = FieldView
} }
data Field xml msg a = Field data Field xml msg a = Field
{ fieldParse :: Maybe Text -> Either msg (Maybe a) { fieldParse :: [Text] -> Either msg (Maybe a)
, fieldRender :: a -> Text
, fieldView :: Text -- ^ ID , fieldView :: Text -- ^ ID
-> Text -- ^ name -> Text -- ^ name
-> Text -- ^ value -> Maybe a -- ^ value
-> Bool -- ^ required? -> Bool -- ^ required?
-> xml -> xml
} }