diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 39ffcb85..e65c898a 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -10,6 +10,7 @@ module Yesod.Form , FormResult (..) , Enctype (..) , FormFieldSettings (..) + , Textarea (..) -- * Type synonyms , Form , Formlet @@ -35,6 +36,7 @@ module Yesod.Form import Yesod.Form.Core import Yesod.Form.Fields import Yesod.Form.Class +import Yesod.Form.Profiles (Textarea (..)) import Text.Hamlet import Yesod.Request diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 83f699c8..290b15d7 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -9,6 +9,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields import Yesod.Form.Core +import Yesod.Form.Profiles (Textarea) import Data.Int (Int64) import Data.Time (Day, TimeOfDay) @@ -53,3 +54,8 @@ instance ToFormField Html y where toFormField = htmlField instance ToFormField (Maybe Html) y where toFormField = maybeHtmlField + +instance ToFormField Textarea y where + toFormField = textareaField +instance ToFormField (Maybe Textarea) y where + toFormField = maybeTextareaField diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index bae68238..b1c3f229 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -255,10 +255,10 @@ emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing -textareaField :: FormFieldSettings -> FormletField sub y String +textareaField :: FormFieldSettings -> FormletField sub y Textarea textareaField = requiredFieldHelper textareaFieldProfile -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile hiddenField :: FormFieldSettings -> FormletField sub y String diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index ca0e873b..521a7cd1 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -1,4 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile @@ -13,6 +15,7 @@ module Yesod.Form.Profiles , fileFieldProfile , parseDate , parseTime + , Textarea (..) ) where import Yesod.Form.Core @@ -23,6 +26,10 @@ import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) +import Database.Persist (PersistField) + +import Text.Blaze.Builder.Utf8 (writeChar) +import Text.Blaze.Builder.Core (writeList, writeByteString) intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile @@ -77,10 +84,27 @@ htmlFieldProfile = FieldProfile |] } -textareaFieldProfile :: FieldProfile sub y String +-- | A newtype wrapper around a 'String' that converts newlines to HTML +-- br-tags. +newtype Textarea = Textarea { unTextarea :: String } + deriving (Show, Read, Eq, PersistField) +instance ToHtml Textarea where + toHtml = + Html . writeList writeHtmlEscapedChar . unTextarea + where + -- Taken from blaze-builder and modified with newline handling. + writeHtmlEscapedChar '<' = writeByteString "<" + writeHtmlEscapedChar '>' = writeByteString ">" + writeHtmlEscapedChar '&' = writeByteString "&" + writeHtmlEscapedChar '"' = writeByteString """ + writeHtmlEscapedChar '\'' = writeByteString "'" + writeHtmlEscapedChar '\n' = writeByteString "
" + writeHtmlEscapedChar c = writeChar c + +textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id + { fpParse = Right . Textarea + , fpRender = unTextarea , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea#$theId$!name=$name$ $val$ |] diff --git a/hellowidget.hs b/hellowidget.hs index 382420b2..8c346952 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -57,7 +57,7 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,) + (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -75,8 +75,12 @@ handleFormR = do <*> nicHtmlField ("HTML") (Just $ string "You can put rich text here") <*> maybeEmailField ("An e-mail addres") Nothing + <*> maybeTextareaField "A text area" Nothing let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, _, x, _) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, x, _, _) -> Just x + _ -> Nothing + let txt = case res of + FormSuccess (_, _, _, _, _, _, _, _, _, _, Just x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$cassius| @@ -98,6 +102,8 @@ textarea.html %input!type=submit $maybe mhtml html $html$ + $maybe txt t + $t$ |] setTitle $ string "Form" @@ -114,9 +120,9 @@ getAutoCompleteR = do data Person = Person String Int getCustomFormR = do - let customForm = GForm $ \e f -> do - (a1, [b1], c1) <- deform (stringInput "name") e f - (a2, [b2], c2) <- deform (intInput "age") e f + let customForm = GForm $ do + (a1, [b1], c1) <- deform $ stringInput "name" + (a2, [b2], c2) <- deform $ intInput "age" let b = do b1' <- extractBody b1 b2' <- extractBody b2