From c71821a5c9c464113084b97ed4124d8264a5654c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 4 Jul 2010 08:21:41 +0300
Subject: [PATCH] Added time field

---
 Yesod/Form.hs  | 42 +++++++++++++++++++++++++++++++++++++++++-
 hellowidget.hs | 17 +++++++++--------
 2 files changed, 50 insertions(+), 9 deletions(-)

diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index c9fa6859..66345121 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -34,6 +34,7 @@ module Yesod.Form
     , stringField
     , intField
     , dayField
+    , timeField
     , boolField
     , htmlField
     , selectField
@@ -51,7 +52,7 @@ import Text.Hamlet
 import Yesod.Request
 import Yesod.Handler
 import Control.Applicative hiding (optional)
-import Data.Time (Day)
+import Data.Time (Day, TimeOfDay (TimeOfDay))
 import Data.Maybe (fromMaybe, isJust)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<), liftM, join)
@@ -278,6 +279,45 @@ instance IsFormField Day where
 instance IsFormField (Maybe Day) where
     toFormField = optionalField dayField
 
+parseTime :: String -> Either String TimeOfDay
+parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0']
+parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper [h1, h2, m1, m2, '0', '0']
+parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
+    parseTimeHelper [h1, h2, m1, m2, s1, s2]
+parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
+
+parseTimeHelper :: String -> Either String TimeOfDay
+parseTimeHelper (h1:h2:m1:m2:s1:s2:[])
+    | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
+    | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
+    | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
+    | otherwise = Right $ TimeOfDay h m s
+  where
+    h = read [h1, h2]
+    m = read [m1, m2]
+    s = fromInteger $ read [s1, s2]
+
+timeField :: FieldProfile sub y TimeOfDay
+timeField = FieldProfile
+    { fpParse = parseTime
+    , fpRender = show
+    , fpHamlet = \name val isReq -> [$hamlet|
+%input#$<name>$!name=$<name>$!:isReq:required!value=$<val>$
+|]
+    , fpWidget = \name -> do
+        return ()
+    {-
+        addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
+        addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"
+        addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
+        addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|]
+    -}
+    }
+instance IsFormField TimeOfDay where
+    toFormField = requiredField timeField
+instance IsFormField (Maybe TimeOfDay) where
+    toFormField = optionalField timeField
+
 boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
 boolField label tooltip orig = GForm $ \env _ -> do
     name <- newFormIdent
diff --git a/hellowidget.hs b/hellowidget.hs
index c06264f4..682ae152 100644
--- a/hellowidget.hs
+++ b/hellowidget.hs
@@ -15,16 +15,16 @@ wrapper h = [$hamlet|
 #wrapper ^h^
 %footer Brought to you by Yesod Widgets&trade;
 |]
-getRootR = applyLayoutW $ wrapWidget wrapper $ do
+getRootR = applyLayoutW $ flip wrapWidget wrapper $ do
     i <- newIdent
     setTitle $ string "Hello Widgets"
-    addStyle [$hamlet|\#$string.i${color:red}|]
+    addStyle [$hamlet|\#$i${color:red}|]
     addStylesheet $ StaticR $ StaticRoute ["style.css"]
     addStylesheetRemote "http://localhost:3000/static/style2.css"
     addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
     addScript $ StaticR $ StaticRoute ["script.js"]
     addBody [$hamlet|
-%h1#$string.i$ Welcome to my first widget!!!
+%h1#$i$ Welcome to my first widget!!!
 %p
     %a!href=@RootR@ Recursive link.
 %p
@@ -34,28 +34,29 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do
     addHead [$hamlet|%meta!keywords=haskell|]
 
 handleFormR = do
-    (res, form, enctype) <- runFormPost $ (,,,,,)
+    (res, form, enctype) <- runFormPost $ (,,,,,,)
         <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing
         <*> requiredField stringField (string "Another field") (string "") (Just "some default text")
         <*> requiredField intField (string "A number field") (string "some nums") (Just 5)
         <*> requiredField dayField (string "A day field") (string "") Nothing
+        <*> requiredField timeField (string "A time field") (string "") Nothing
         <*> boolField (string "A checkbox") (string "") (Just False)
         <*> requiredField htmlField (string "HTML") (string "")
                 (Just $ string "You can put rich text here")
     let mhtml = case res of
-                    FormSuccess (_, _, _, _, _, x) -> Just x
+                    FormSuccess (_, _, _, _, _, _, x) -> Just x
                     _ -> Nothing
     applyLayoutW $ do
         addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|]
-        flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet|
-%form!method=post!enctype=$string.show.enctype$
+        wrapWidget (fieldsToTable form) $ \h -> [$hamlet|
+%form!method=post!enctype=$show.enctype$
     %table
         ^h^
         %tr
             %td!colspan=2
                 %input!type=submit
     $maybe mhtml html
-        $html$
+        $<html>$
 |]
         setTitle $ string "Form"