Specify label and tooltip in field attributes

Yesod/Form.hs

@@ -64,6 +64,7 @@ import Data.Char (toUpper, isUpper)
 import Data.Int (Int64)
 import qualified Data.ByteString.Lazy.UTF8 as U
 import Yesod.Widget
+import Control.Arrow ((&&&))
 
 data FormResult a = FormMissing
                   | FormFailure [String]
@@ -513,10 +514,18 @@ share2 f g a = do
 mkIsForm :: [EntityDef] -> Q [Dec]
 mkIsForm = mapM derive
   where
+    getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
+    getLabel' [] = Nothing
+    getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x
+    getLabel' (_:x) = getLabel' x
+    getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z
+    getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x
+    getTooltip' (_:x) = getTooltip' x
+    getTooltip' [] = Nothing
     derive :: EntityDef -> Q Dec
     derive t = do
         let fst3 (x, _, _) = x
-        let cols = map (toLabel . fst3) $ entityColumns t
+        let cols = map (getLabel &&& getTooltip) $ entityColumns t
         ap <- [|(<*>)|]
         just <- [|pure|]
         nothing <- [|Nothing|]
@@ -542,10 +551,11 @@ mkIsForm = mapM derive
     go ap just' string' mem mfx ftt a =
         let x = foldl (ap' ap) just' $ map (go' string' mem) a
          in mfx `AppE` ftt `AppE` x
-    go' string' mempty' (label, ex) =
+    go' string' mempty' ((label, tooltip), ex) =
         let label' = string' `AppE` LitE (StringL label)
+            tooltip' = string' `AppE` LitE (StringL tooltip)
          in VarE (mkName "toFormField") `AppE` label'
-                `AppE` mempty' `AppE` ex
+                `AppE` tooltip' `AppE` ex
     ap' ap x y = InfixE (Just x) ap (Just y)
 
 toLabel :: String -> String

Yesod/Helpers/Auth.hs

@@ -335,7 +335,7 @@ getEmailVerifyR lid key = do
             redirect RedirectTemporary $ toMaster EmailPasswordR
         _ -> applyLayout "Invalid verification key" mempty [$hamlet|
 %p I'm sorry, but that was an invalid verification key.
-        |]
+|]
 
 getEmailLoginR :: Yesod master => GHandler Auth master RepHtml
 getEmailLoginR = do

blog.hs

@@ -8,7 +8,7 @@ import Data.Time (Day)
 type Html' = Html ()
 share2 mkPersist mkIsForm [$persist|
 Entry
-    title String
+    title String "label=Entry title" "tooltip=Make it something cool"
     posted Day Desc
     content Html'
     deriving
@@ -44,8 +44,9 @@ instance Yesod Blog where
 !!!
 %html
     %head
-        %title $pageTitle.p$
+        %title $<pageTitle.p>$
         ^pageHead.p^
+        %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666}
     %body
         %p
             %a!href=@RootR@ Homepage
@@ -56,9 +57,9 @@ instance Yesod Blog where
             $maybe mcreds c
                 Welcome $
                 $maybe credsDisplayName.c dn
-                    $string.dn$
+                    $dn$
                 $nothing
-                    $string.credsIdent.c$
+                    $credsIdent.c$
                 \ $
                 %a!href=@AuthR.Logout@ Logout
             $nothing
@@ -90,7 +91,7 @@ getRootR = do
 %ul
     $forall entries entry
         %li
-            %a!href=@EntryR.fst.entry@ $string.entryTitle.snd.entry$
+            %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
 |]
 
 getEntryR :: EntryId -> Handler Blog RepHtml
@@ -99,9 +100,9 @@ getEntryR eid = do
     applyLayoutW $ do
         setTitle $ string $ entryTitle entry
         addBody [$hamlet|
-%h1 $string.entryTitle.entry$
+%h1 $entryTitle.entry$
-%h2 $string.show.entryPosted.entry$
+%h2 $show.entryPosted.entry$
-#content $entryContent.entry$
+#content $<entryContent.entry>$
 |]
 main = withSqlite "blog.db3" $ \conn -> do
     flip runSqlite conn $ initialize (undefined :: Entry)