Created
October 10, 2012 16:24
-
-
Save ian-ross/3866692 to your computer and use it in GitHub Desktop.
jQuery slider widget for Yesod
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
$newline never | |
<h1>Jquery Sliders | |
<form method=post action=@{HomeR} enctype=#{formEnctype}> | |
^{formWidget} | |
<input type="submit" value="Submit"> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, TypeFamilies, | |
TemplateHaskell, QuasiQuotes, TupleSections #-} | |
import Yesod | |
import Yesod.Form | |
import Yesod.Static | |
import Yesod.Default.Util | |
import JqSlider | |
import Control.Applicative ((<$>), (<*>)) | |
import qualified Data.Text as T | |
import Text.Hamlet | |
data App = App { getStatic :: Static } | |
-- Just a home page with some sliders, plus a static subsite to serve | |
-- up the CSS, JavaScript and images used by the slider plugin. | |
mkYesod "App" [parseRoutes| | |
/ HomeR GET POST | |
/static StaticR Static getStatic | |
|] | |
-- Basic handler: display form. | |
getHomeR :: Handler RepHtml | |
getHomeR = do | |
(formWidget, formEnctype) <- generateFormPost sliderForm | |
defaultLayout $ do | |
setTitle "Sliders" | |
$(widgetFileReload def "jqslider-example") | |
-- Process form result: just display a message. | |
postHomeR :: Handler RepHtml | |
postHomeR = do | |
((result, formWidget), formEnctype) <- runFormPost sliderForm | |
case result of | |
FormSuccess (a, b, c) -> | |
setMessage [shamlet|<p>Values: s1=#{showVal a} s2=#{showVal b} s3=#{showVal c}|] | |
_ -> setMessage "Bad form response" | |
defaultLayout $ do | |
setTitle "Sliders" | |
$(widgetFileReload def "jqslider-example") | |
where showVal :: JqSliderVal -> T.Text | |
showVal = either (T.pack . show) (T.pack . show) | |
-- Build a form with three sliders, two with single values and one | |
-- range slider. | |
sliderForm :: Html -> MForm App App | |
(FormResult (JqSliderVal, JqSliderVal, JqSliderVal), GWidget App App ()) | |
sliderForm = renderDivs $ (,,) | |
<$> areq (jqSliderField ss1) "Slider 1" (Just $ Left 15) | |
<*> areq (jqSliderField ss2) "Slider 2" (Just $ Right (25,75)) | |
<*> areq (jqSliderField ss3) "Slider 3" (Just $ Left 50) | |
where ss1 = def { ssRange = (5, 50), ssStep = Just 2.5, ssRound = Just 1, | |
ssFormat = Just (JqSliderFormat "##.0" "de"), ssDimension = " $" } | |
ss2 = def { ssRange = (0, 500), ssStep = Just 1, ssLimits = False, | |
ssHeterogeneity = [(50,100), (75,250)], | |
ssScale = ["0", "|", "50", "|" , "100", "|", "250", "|", "500"], | |
ssDimension = " m<small>2</small>" } | |
ss3 = def { ssRange = (0, 100), ssSkin = Just "round" } | |
$(staticFiles "static") | |
-- Typeclass instances. | |
instance Yesod App | |
instance YesodJquery App | |
instance YesodJqSlider App where | |
jqSliderCss _ = Left (StaticR bin_jquery_slider_min_css) | |
jqSliderScript _ = Left (StaticR bin_jquery_slider_min_js) | |
instance RenderMessage App FormMessage where | |
renderMessage _ _ = defaultFormMessage | |
-- Off we go... | |
main :: IO () | |
main = do | |
s <- static "static" | |
warpDebug 3000 (App s) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE OverloadedStrings, TemplateHaskell, | |
QuasiQuotes, FlexibleContexts #-} | |
-- Yesod code to implement a form field based on the jQuery slider | |
-- widget defined at http://egorkhmelev.github.com/jslider | |
-- | |
-- File layout: we need access to the CSS and JavaScript files for the | |
-- slider plugin, along with the images used for theming the sliders. | |
-- If the CSS is in .../css/jquery.slider.min.css, then the image | |
-- files must be in .../img. A type class is provided to set up the | |
-- routes to the CSS and JavaScript, but the paths to the image files | |
-- are hard-coded in the CSS. | |
-- | Field definition for jQuery slider widget. | |
module JqSlider | |
( YesodJqSlider (..) | |
, YesodJquery (..) | |
, jqSliderField | |
, JqSliderSettings (..) | |
, JqSliderFormat (..) | |
, JqSliderVal | |
, Default (..) | |
) where | |
import Data.Char (toLower) | |
import Data.Text (Text) | |
import qualified Data.Text as T | |
import qualified Data.Text.Read as TR | |
import Data.Aeson | |
import Data.Aeson.TH | |
import qualified Data.HashMap.Strict as H | |
import qualified Data.Vector as V | |
import Data.Default | |
import Yesod | |
import Yesod.Form.Jquery (YesodJquery(..)) | |
type JqSliderVal = Either Double (Double,Double) | |
class YesodJqSlider master where | |
-- | Routes to the jQuery Slider CSS and JS files. | |
jqSliderCss :: master -> Either (Route master) Text | |
jqSliderScript :: master -> Either (Route master) Text | |
-- | Slider value display formatting. | |
data JqSliderFormat = JqSliderFormat | |
{ sfFormat :: Text | |
, sfLocale :: Text } deriving (Eq, Show) | |
$(deriveToJSON (map toLower . drop 2) ''JqSliderFormat) | |
-- | Slider settings. | |
data JqSliderSettings = JqSliderSettings | |
{ ssRange :: (Double, Double) | |
, ssStep :: Maybe Double | |
, ssRound :: Maybe Int | |
, ssFormat :: Maybe JqSliderFormat | |
, ssHeterogeneity :: [(Double, Double)] | |
, ssDimension :: Text | |
, ssLimits :: Bool | |
, ssScale :: [Text] | |
, ssSkin :: Maybe Text | |
} deriving (Eq, Show) | |
instance Default JqSliderSettings where | |
def = JqSliderSettings | |
{ ssRange = (1, 10) | |
, ssStep = Nothing | |
, ssRound = Nothing | |
, ssFormat = Nothing | |
, ssHeterogeneity = [] | |
, ssDimension = "" | |
, ssLimits = True | |
, ssScale = [] | |
, ssSkin = Nothing | |
} | |
instance ToJSON JqSliderSettings where | |
toJSON s = Object $ H.fromList $ concat | |
[fromto, step, round, format, heterogeneity, | |
dimension, limits, scale, skin] | |
where fromto = ["from" .= fst (ssRange s), "to" .= snd (ssRange s)] | |
step = msingle "step" ssStep id | |
round = msingle "round" ssRound id | |
format = msingle "format" ssFormat toJSON | |
heterogeneity = lsingle "heterogeneity" ssHeterogeneity | |
(\(p,v) -> concat [show p, "/", show v]) | |
dimension = case ssDimension s of | |
"" -> [] | |
d -> ["dimension" .= d] | |
limits = ["limits" .= ssLimits s] | |
scale = lsingle "scale" ssScale id | |
skin = maybe [] (single "skin") (ssSkin s) | |
single k v = [k .= v] | |
msingle k fld f = maybe [] (single k . f) (fld s) | |
lsingle k fld f = case fld s of | |
[] -> [] | |
vs -> [k .= (Array $ V.fromList $ map (toJSON . f) vs)] | |
-- A slider field. This is essentially a double field with a prettier UI. | |
jqSliderField :: (RenderMessage master FormMessage, | |
YesodJquery master, YesodJqSlider master) => | |
JqSliderSettings -> Field sub master (Either Double (Double,Double)) | |
jqSliderField s = Field | |
{ fieldParse = parseHelper $ \s -> | |
case TR.double s of | |
Right (a, "") -> Right (Left a) | |
Right (a, s') -> if (T.head s' == ';') then | |
case TR.double (T.tail s') of | |
Right (b, "") -> Right (Right (a,b)) | |
_ -> Left $ MsgInvalidNumber s | |
else Left $ MsgInvalidNumber s | |
_ -> Left $ MsgInvalidNumber s | |
, fieldView = \i n as v req -> do | |
master <- lift getYesod | |
addStylesheetEither $ jqSliderCss master | |
addScriptEither $ urlJqueryJs master | |
addScriptEither $ jqSliderScript master | |
toWidget [whamlet| | |
<input id="#{i}" name="#{n}" *{as} type="slider" :req:required="" value="#{showVal v}"> | |
|] | |
toWidget [julius| $(function() { $("##{i}").slider(#{toJSON s}); }); |] | |
} | |
where showVal :: Either Text (Either Double (Double,Double)) -> Text | |
showVal = either id (either (T.pack . show) (T.pack . (\(l,h) -> show l ++ ";" ++ show h))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
this is a lot of complexity for getting a slider up and running. is there a simplified example of jquery slider+yesod ?