haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Autocomplete form widget

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-06 22:36:20 +03:00
parent 5d8ee5e7fb
commit 5354c03a2c
3 changed files with 42 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
Yesod/Form.hs
View File

@ -38,6 +38,7 @@ module Yesod.Form
, stringFieldProfile , stringFieldProfile
, intFieldProfile , intFieldProfile
, dayFieldProfile , dayFieldProfile
, jqueryDayFieldProfile
, timeFieldProfile , timeFieldProfile
, htmlFieldProfile , htmlFieldProfile
-- * Pre-built fields -- * Pre-built fields
@ -56,6 +57,7 @@ module Yesod.Form
, selectField , selectField
, maybeSelectField , maybeSelectField
, boolField , boolField
, jqueryAutocompleteField
-- * Pre-built inputs -- * Pre-built inputs
, stringInput , stringInput
, maybeStringInput , maybeStringInput
@ -675,3 +677,20 @@ toLabel (x:rest) = toUpper x : go rest
go (c:cs) go (c:cs)
| isUpper c = ' ' : c : go cs | isUpper c = ' ' : c : go cs
| otherwise = 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})});|]
}

1
Yesod/Widget.hs
View File

@ -25,6 +25,7 @@ module Yesod.Widget
, extractBody , extractBody
) where ) where
-- FIXME add support for script contents
import Data.List (nub) import Data.List (nub)
import Data.Monoid import Data.Monoid
import Control.Monad.Trans.Writer import Control.Monad.Trans.Writer

31
hellowidget.hs
View File

@ -9,6 +9,7 @@ mkYesod "HW" [$parseRoutes|
/ RootR GET / RootR GET
/form FormR /form FormR
/static StaticR Static hwStatic /static StaticR Static hwStatic
/autocomplete AutoCompleteR GET
|] |]
instance Yesod HW where approot _ = "" instance Yesod HW where approot _ = ""
wrapper h = [$hamlet| wrapper h = [$hamlet|
@ -33,18 +34,21 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do
|] |]
addHead [$hamlet|%meta!keywords=haskell|] addHead [$hamlet|%meta!keywords=haskell|]
-- FIXME add coolness to day and html below
handleFormR = do handleFormR = do
(res, form, enctype) <- runFormPost $ (,,,,,,) (res, form, enctype) <- runFormPost $ (,,,,,,,)
<$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing <$> stringField (string "My Field") (string "Some tooltip info") Nothing
<*> requiredField stringField (string "Another field") (string "") (Just "some default text") <*> stringField (string "Another field") (string "") (Just "some default text")
<*> requiredField intField (string "A number field") (string "some nums") (Just 5) <*> intField (string "A number field") (string "some nums") (Just 5)
<*> requiredField dayField (string "A day field") (string "") Nothing <*> dayField (string "A day field") (string "") Nothing
<*> requiredField timeField (string "A time field") (string "") Nothing <*> timeField (string "A time field") (string "") Nothing
<*> boolField (string "A checkbox") (string "") (Just False) <*> 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") (Just $ string "You can put rich text here")
let mhtml = case res of let mhtml = case res of
FormSuccess (_, _, _, _, _, _, x) -> Just x FormSuccess (_, _, _, _, _, _, _, x) -> Just x
_ -> Nothing _ -> Nothing
applyLayoutW $ do applyLayoutW $ do
addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|]
@ -56,8 +60,17 @@ handleFormR = do
%td!colspan=2 %td!colspan=2
%input!type=submit %input!type=submit
$maybe mhtml html $maybe mhtml html
$<html>$ $html$
|] |]
setTitle $ string "Form" setTitle $ string "Form"
main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000 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"
]