{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Some fields spiced up with jQuery UI.
module Yesod.Form.Jquery
    ( YesodJquery (..)
    , jqueryDayField
    , jqueryDatePickerDayField
    , jqueryAutocompleteField
    , jqueryAutocompleteField'
    , googleHostedJqueryUiCss
    , JqueryDaySettings (..)
    , Default (..)
    ) where

import Yesod.Core
import Yesod.Form
import Data.Time (Day)
import Data.Default
import Text.Julius (rawJS)
import Data.Text (Text, pack, unpack)
import Data.Monoid (mconcat)

-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.
googleHostedJqueryUiCss :: Text -> Text
googleHostedJqueryUiCss :: Text -> Text
googleHostedJqueryUiCss Text
theme = [Text] -> Text
forall a. Monoid a => [a] -> a
Data.Monoid.mconcat
    [ Text
"//ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"
    , Text
theme
    , Text
"/jquery-ui.css"
    ]

class YesodJquery a where
    -- | The jQuery Javascript file. Note that in upgrades to this library, the
    -- version of jQuery referenced, or where it is downloaded from, may be
    -- changed without warning. If you are relying on a specific version of
    -- jQuery, you should give an explicit URL instead of relying on the
    -- default value.
    --
    -- Currently, the default value is jQuery 1.7 from Google\'s CDN.
    urlJqueryJs :: a -> Either (Route a) Text
    urlJqueryJs a
_ = Text -> Either (Route a) Text
forall a b. b -> Either a b
Right Text
"//ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js"

    -- | The jQuery UI 1.8 Javascript file.
    urlJqueryUiJs :: a -> Either (Route a) Text
    urlJqueryUiJs a
_ = Text -> Either (Route a) Text
forall a b. b -> Either a b
Right Text
"//ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"

    -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.
    urlJqueryUiCss :: a -> Either (Route a) Text
    urlJqueryUiCss a
_ = Text -> Either (Route a) Text
forall a b. b -> Either a b
Right (Text -> Either (Route a) Text) -> Text -> Either (Route a) Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
googleHostedJqueryUiCss Text
"cupertino"

    -- | jQuery UI time picker add-on.
    urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
    urlJqueryUiDateTimePicker a
_ = Text -> Either (Route a) Text
forall a b. b -> Either a b
Right Text
"http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"

jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDayField :: JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDayField = (JqueryDaySettings -> Text -> Field (HandlerFor site) Day)
-> Text -> JqueryDaySettings -> Field (HandlerFor site) Day
forall a b c. (a -> b -> c) -> b -> a -> c
flip JqueryDaySettings -> Text -> Field (HandlerFor site) Day
forall site.
(RenderMessage site FormMessage, YesodJquery site) =>
JqueryDaySettings -> Text -> Field (HandlerFor site) Day
jqueryDayField' Text
"date"

-- | Use jQuery's datepicker as the underlying implementation.
--
-- Since 1.4.3
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDatePickerDayField :: JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDatePickerDayField = (JqueryDaySettings -> Text -> Field (HandlerFor site) Day)
-> Text -> JqueryDaySettings -> Field (HandlerFor site) Day
forall a b c. (a -> b -> c) -> b -> a -> c
flip JqueryDaySettings -> Text -> Field (HandlerFor site) Day
forall site.
(RenderMessage site FormMessage, YesodJquery site) =>
JqueryDaySettings -> Text -> Field (HandlerFor site) Day
jqueryDayField' Text
"text"

jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day
jqueryDayField' :: JqueryDaySettings -> Text -> Field (HandlerFor site) Day
jqueryDayField' JqueryDaySettings
jds Text
inputType = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> HandlerFor
     site
     (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe Day))
fieldParse = (Text -> Either FormMessage Day)
-> [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe Day))
forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper ((Text -> Either FormMessage Day)
 -> [Text]
 -> [FileInfo]
 -> HandlerFor site (Either (SomeMessage site) (Maybe Day)))
-> (Text -> Either FormMessage Day)
-> [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe Day))
forall a b. (a -> b) -> a -> b
$ Either FormMessage Day
-> (Day -> Either FormMessage Day)
-> Maybe Day
-> Either FormMessage Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  (FormMessage -> Either FormMessage Day
forall a b. a -> Either a b
Left FormMessage
MsgInvalidDay)
                  Day -> Either FormMessage Day
forall a b. b -> Either a b
Right
              (Maybe Day -> Either FormMessage Day)
-> (Text -> Maybe Day) -> Text -> Either FormMessage Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Day
forall a. Read a => String -> Maybe a
readMay
              (String -> Maybe Day) -> (Text -> String) -> Text -> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
    , fieldView :: FieldViewFunc (HandlerFor site) Day
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Day
val Bool
isReq -> do
        MarkupM () -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [shamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="#{inputType}" :isReq:required="" value="#{showVal val}">
|]
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(HandlerSite m ~ site, MonadWidget m) =>
(site -> Either (Route site) Text) -> m ()
addScript' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryJs
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(HandlerSite m ~ site, MonadWidget m) =>
(site -> Either (Route site) Text) -> m ()
addScript' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryUiJs
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(MonadWidget m, HandlerSite m ~ site) =>
(site -> Either (Route site) Text) -> m ()
addStylesheet' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryUiCss
        JavascriptUrl (Route site) -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|
$(function(){
    var i = document.getElementById("#{rawJS theId}");
    if (i.type != "date") {
        $(i).datepicker({
            dateFormat:'yy-mm-dd',
            changeMonth:#{jsBool $ jdsChangeMonth jds},
            changeYear:#{jsBool $ jdsChangeYear jds},
            numberOfMonths:#{rawJS $ mos $ jdsNumberOfMonths jds},
            yearRange:#{toJSON $ jdsYearRange jds}
        });
    }
});
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    showVal :: Either Text Day -> Text
showVal = (Text -> Text) -> (Day -> Text) -> Either Text Day -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (Day -> String) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> String
forall a. Show a => a -> String
show)
    jsBool :: Bool -> Value
jsBool Bool
True = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
True
    jsBool Bool
False = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
False
    mos :: Either a (a, a) -> String
mos (Left a
i) = a -> String
forall a. Show a => a -> String
show a
i
    mos (Right (a
x, a
y)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"["
        , a -> String
forall a. Show a => a -> String
show a
x
        , String
","
        , a -> String
forall a. Show a => a -> String
show a
y
        , String
"]"
        ]

jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
                        => Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField :: Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField = Int -> Route site -> Field (HandlerFor site) Text
forall site.
(RenderMessage site FormMessage, YesodJquery site) =>
Int -> Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField' Int
2

jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
                         => Int -- ^ autocomplete minimum length
                         -> Route site
                         -> Field (HandlerFor site) Text
jqueryAutocompleteField' :: Int -> Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField' Int
minLen Route site
src = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> HandlerFor
     site
     (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe Text))
forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper ((Text -> Either FormMessage Text)
 -> [Text]
 -> [FileInfo]
 -> HandlerFor site (Either (SomeMessage site) (Maybe Text)))
-> (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe Text))
forall a b. (a -> b) -> a -> b
$ Text -> Either FormMessage Text
forall a b. b -> Either a b
Right
    , fieldView :: FieldViewFunc (HandlerFor site) Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
isReq -> do
        MarkupM () -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [shamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|]
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(HandlerSite m ~ site, MonadWidget m) =>
(site -> Either (Route site) Text) -> m ()
addScript' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryJs
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(HandlerSite m ~ site, MonadWidget m) =>
(site -> Either (Route site) Text) -> m ()
addScript' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryUiJs
        (site -> Either (Route site) Text) -> WidgetFor site ()
forall (m :: * -> *) site.
(MonadWidget m, HandlerSite m ~ site) =>
(site -> Either (Route site) Text) -> m ()
addStylesheet' site -> Either (Route site) Text
forall a. YesodJquery a => a -> Either (Route a) Text
urlJqueryUiCss
        JavascriptUrl (Route site) -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|
$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:#{toJSON minLen}})});
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m ()
addScript' :: (site -> Either (Route site) Text) -> m ()
addScript' site -> Either (Route site) Text
f = do
    site
y <- m site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Either (Route (HandlerSite m)) Text -> m ()
forall (m :: * -> *).
MonadWidget m =>
Either (Route (HandlerSite m)) Text -> m ()
addScriptEither (Either (Route (HandlerSite m)) Text -> m ())
-> Either (Route (HandlerSite m)) Text -> m ()
forall a b. (a -> b) -> a -> b
$ site -> Either (Route site) Text
f site
y

addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)
               => (site -> Either (Route site) Text)
               -> m ()
addStylesheet' :: (site -> Either (Route site) Text) -> m ()
addStylesheet' site -> Either (Route site) Text
f = do
    site
y <- m site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Either (Route (HandlerSite m)) Text -> m ()
forall (m :: * -> *).
MonadWidget m =>
Either (Route (HandlerSite m)) Text -> m ()
addStylesheetEither (Either (Route (HandlerSite m)) Text -> m ())
-> Either (Route (HandlerSite m)) Text -> m ()
forall a b. (a -> b) -> a -> b
$ site -> Either (Route site) Text
f site
y

readMay :: Read a => String -> Maybe a
readMay :: String -> Maybe a
readMay String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
                (a
x, String
_):[(a, String)]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                [] -> Maybe a
forall a. Maybe a
Nothing

data JqueryDaySettings = JqueryDaySettings
    { JqueryDaySettings -> Bool
jdsChangeMonth :: Bool
    , JqueryDaySettings -> Bool
jdsChangeYear :: Bool
    , JqueryDaySettings -> String
jdsYearRange :: String
    , JqueryDaySettings -> Either Int (Int, Int)
jdsNumberOfMonths :: Either Int (Int, Int)
    }

instance Default JqueryDaySettings where
    def :: JqueryDaySettings
def = JqueryDaySettings :: Bool
-> Bool -> String -> Either Int (Int, Int) -> JqueryDaySettings
JqueryDaySettings
        { jdsChangeMonth :: Bool
jdsChangeMonth = Bool
False
        , jdsChangeYear :: Bool
jdsChangeYear = Bool
False
        , jdsYearRange :: String
jdsYearRange = String
"c-10:c+10"
        , jdsNumberOfMonths :: Either Int (Int, Int)
jdsNumberOfMonths = Int -> Either Int (Int, Int)
forall a b. a -> Either a b
Left Int
1
        }