jQuery slider widget for Yesod

jqslider-example.hamlet

$newline never
<h1>Jquery Sliders

<form method=post action=@{HomeR} enctype=#{formEnctype}>
  ^{formWidget}
  <input type="submit" value="Submit">

jqslider-example.hs

{-# 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 = "&nbsp;$" }
        ss2 = def { ssRange = (0, 500), ssStep = Just 1, ssLimits = False,
                    ssHeterogeneity = [(50,100), (75,250)],
                    ssScale = ["0", "|", "50", "|" , "100", "|", "250", "|", "500"],
                    ssDimension = "&nbsp;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)

JqSlider.hs

{-# 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)))

this is a lot of complexity for getting a slider up and running. is there a simplified example of jquery slider+yesod ?