Textarea

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

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

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

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 "&lt;"
+        writeHtmlEscapedChar '>'  = writeByteString "&gt;"
+        writeHtmlEscapedChar '&'  = writeByteString "&amp;"
+        writeHtmlEscapedChar '"'  = writeByteString "&quot;"
+        writeHtmlEscapedChar '\'' = writeByteString "&apos;"
+        writeHtmlEscapedChar '\n' = writeByteString "<br>"
+        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$
 |]

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