From 5354c03a2ce4423c0e3aef73b82dac63681e779c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 6 Jul 2010 22:36:20 +0300
Subject: [PATCH] Autocomplete form widget

---
 Yesod/Form.hs   | 19 +++++++++++++++++++
 Yesod/Widget.hs |  1 +
 hellowidget.hs  | 31 ++++++++++++++++++++++---------
 3 files changed, 42 insertions(+), 9 deletions(-)

diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index d0846611..89d1cf9f 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -38,6 +38,7 @@ module Yesod.Form
     , stringFieldProfile
     , intFieldProfile
     , dayFieldProfile
+    , jqueryDayFieldProfile
     , timeFieldProfile
     , htmlFieldProfile
       -- * Pre-built fields
@@ -56,6 +57,7 @@ module Yesod.Form
     , selectField
     , maybeSelectField
     , boolField
+    , jqueryAutocompleteField
       -- * Pre-built inputs
     , stringInput
     , maybeStringInput
@@ -675,3 +677,20 @@ toLabel (x:rest) = toUpper x : go rest
     go (c:cs)
         | isUpper c = ' ' : c : go cs
         | otherwise = c : go cs
+
+jqueryAutocompleteField src = requiredFieldHelper
+                            $ jqueryAutocompleteFieldProfile src
+
+jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String
+jqueryAutocompleteFieldProfile src = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \name val isReq -> [$hamlet|
+%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$
+|]
+    , fpWidget = \name -> do
+        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$").autocomplete({source:"@src@",minLength:2})});|]
+    }
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
index a287c9f5..e1cfea6d 100644
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -25,6 +25,7 @@ module Yesod.Widget
     , extractBody
     ) where
 
+-- FIXME add support for script contents
 import Data.List (nub)
 import Data.Monoid
 import Control.Monad.Trans.Writer
diff --git a/hellowidget.hs b/hellowidget.hs
index 682ae152..5ea9aa77 100644
--- a/hellowidget.hs
+++ b/hellowidget.hs
@@ -9,6 +9,7 @@ mkYesod "HW" [$parseRoutes|
 / RootR GET
 /form FormR
 /static StaticR Static hwStatic
+/autocomplete AutoCompleteR GET
 |]
 instance Yesod HW where approot _ = ""
 wrapper h = [$hamlet|
@@ -33,18 +34,21 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do
 |]
     addHead [$hamlet|%meta!keywords=haskell|]
 
+-- FIXME add coolness to day and html below
 handleFormR = do
-    (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
+    (res, form, enctype) <- runFormPost $ (,,,,,,,)
+        <$> stringField (string "My Field") (string "Some tooltip info") Nothing
+        <*> stringField (string "Another field") (string "") (Just "some default text")
+        <*> intField (string "A number field") (string "some nums") (Just 5)
+        <*> dayField (string "A day field") (string "") Nothing
+        <*> timeField (string "A time field") (string "") Nothing
         <*> boolField (string "A checkbox") (string "") (Just False)
-        <*> requiredField htmlField (string "HTML") (string "")
+        <*> jqueryAutocompleteField AutoCompleteR
+            (string "Autocomplete") (string "Try it!") Nothing
+        <*> 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}|]
@@ -56,8 +60,17 @@ handleFormR = do
             %td!colspan=2
                 %input!type=submit
     $maybe mhtml html
-        $<html>$
+        $html$
 |]
         setTitle $ string "Form"
 
 main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000
+
+getAutoCompleteR :: Handler HW RepJson
+getAutoCompleteR = do
+    term <- runFormGet' $ stringInput "term"
+    jsonToRepJson $ jsonList
+        [ jsonScalar $ string $ term ++ "foo"
+        , jsonScalar $ string $ term ++ "bar"
+        , jsonScalar $ string $ term ++ "baz"
+        ]