Split jquery and nic code into separate modules

Yesod/Dispatch.hs

@@ -119,15 +119,6 @@ mkYesodData name res = do
 mkYesodDispatch :: String -> [Resource] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-typeHelper :: String -> Type
-typeHelper =
-    foldl1 AppT . map go . words
-  where
-    go s@(x:_)
-        | isLower x = VarT $ mkName s
-        | otherwise = ConT $ mkName s
-    go [] = error "typeHelper: empty string to go"
-
 mkYesodGeneral :: String -- ^ argument name
                -> [String] -- ^ parameters for site argument
                -> Cxt -- ^ classes
@@ -208,13 +199,6 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg])
 thResourceFromResource _ (Resource n _ _) =
     error $ "Invalid attributes for resource: " ++ n
 
-compact :: [(String, [a])] -> [(String, [a])]
-compact [] = []
-compact ((x, x'):rest) =
-    let ys = filter (\(y, _) -> y == x) rest
-        zs = filter (\(z, _) -> z /= x) rest
-     in (x, x' ++ concatMap snd ys) : compact zs
-
 sessionName :: String
 sessionName = "_SESSION"
 

Yesod/Form.hs

@@ -40,7 +40,6 @@ module Yesod.Form
     , stringFieldProfile
     , intFieldProfile
     , dayFieldProfile
-    , jqueryDayFieldProfile
     , timeFieldProfile
     , htmlFieldProfile
     , emailFieldProfile
@@ -55,21 +54,13 @@ module Yesod.Form
     , maybeDoubleField
     , dayField
     , maybeDayField
-    , jqueryDayField
-    , maybeJqueryDayField
-    , jqueryDayTimeField
-    , jqueryDayTimeFieldProfile
     , timeField
     , maybeTimeField
     , htmlField
     , maybeHtmlField
-    , nicHtmlField
-    , maybeNicHtmlField
     , selectField
     , maybeSelectField
     , boolField
-    , jqueryAutocompleteField
-    , maybeJqueryAutocompleteField
     , emailField
     , maybeEmailField
       -- * Pre-built inputs
@@ -82,14 +73,16 @@ module Yesod.Form
     , emailInput
       -- * Template Haskell
     , mkToForm
+      -- * Utilities
+    , parseDate
+    , parseTime
     ) where
 
 import Text.Hamlet
 import Yesod.Request
 import Yesod.Handler
 import Control.Applicative hiding (optional)
-import Data.Time (UTCTime(..), Day, TimeOfDay(..))
+import Data.Time (Day, TimeOfDay(..))
-import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay)
 import Data.Maybe (fromMaybe, mapMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<), liftM, join)
@@ -103,8 +96,6 @@ import qualified Data.ByteString.Lazy.UTF8 as U
 import Yesod.Widget
 import Control.Arrow ((&&&))
 import qualified Text.Email.Validate as Email
-import Data.Char (isSpace)
-import Yesod.Yesod (Yesod (..))
 import Data.List (group, sort)
 
 -- | A form can produce three different results: there was no data available,
@@ -389,88 +380,15 @@ instance ToFormField Day y where
 instance ToFormField (Maybe Day) y where
     toFormField = maybeDayField
 
-jqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y Day
+parseDate :: String -> Either String Day
-jqueryDayField = requiredFieldHelper jqueryDayFieldProfile
+parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
-
+              . readMay . replace '/' '-'
-maybeJqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe Day)
-maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile
-
-jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day
-jqueryDayFieldProfile = FieldProfile
-    { fpParse = maybe
-                  (Left "Invalid day, must be in YYYY-MM-DD format")
-                  Right
-              . readMay
-    , fpRender = show
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
-|]
-    , fpWidget = \name -> do
-        addScript' urlJqueryJs
-        addScript' urlJqueryUiJs
-        addStylesheet' urlJqueryUiCss
-        addJavaScript [$hamlet|
-$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});
-|]
-    }
 
 -- | Replaces all instances of a value in a list by another value.
 -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
 replace :: Eq a => a -> a -> [a] -> [a]
 replace x y = map (\z -> if z == x then y else z)
 
-ifRight :: Either a b -> (b -> c) -> Either a c
-ifRight e f = case e of
-            Left l  -> Left l
-            Right r -> Right $ f r
-
-showLeadingZero :: (Show a) => a -> String
-showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t
-
-parseUTCTime :: String -> Either String UTCTime
-parseUTCTime s =
-    let (dateS, timeS) = break isSpace (dropWhile isSpace s)
-    in let dateE = (parseDate dateS)
-       in case dateE of
-            Left l -> Left l
-            Right date -> ifRight (parseTime timeS)
-                                  (\time -> UTCTime date (timeOfDayToTime time))
-
-jqueryDayTimeField :: Yesod y => FormFieldSettings -> FormletField sub y UTCTime
-jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile
-
-parseDate :: String -> Either String Day
-parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
-              . readMay . replace '/' '-'
-
-
--- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)
-jqueryDayTimeUTCTime :: UTCTime -> String
-jqueryDayTimeUTCTime (UTCTime day utcTime) =
-  let timeOfDay = timeToTimeOfDay utcTime
-  in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay
-  where
-    showTimeOfDay (TimeOfDay hour minute _) =
-      let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
-      in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
-
-jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime
-jqueryDayTimeFieldProfile = FieldProfile
-    { fpParse  = parseUTCTime
-    , fpRender = jqueryDayTimeUTCTime
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
-|]
-    , fpWidget = \name -> do
-        addScript' urlJqueryJs
-        addScript' urlJqueryUiJs
-        addScript' urlJqueryUiDateTimePicker
-        addStylesheet' urlJqueryUiCss
-        addJavaScript [$hamlet|
-$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
-|]
-    }
-
 parseTime :: String -> Either String TimeOfDay
 parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
 parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
@@ -565,24 +483,6 @@ instance ToFormField (Maybe (Html ())) y where
 
 type Html' = Html ()
 
-nicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Html ())
-nicHtmlField = requiredFieldHelper nicHtmlFieldProfile
-
-maybeNicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe (Html ()))
-maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
-
-nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ())
-nicHtmlFieldProfile = FieldProfile
-    { fpParse = Right . preEscapedString
-    , fpRender = U.toString . renderHtml
-    , fpHamlet = \theId name val _isReq -> [$hamlet|
-%textarea.html#$theId$!name=$name$ $val$
-|]
-    , fpWidget = \name -> do
-        addScript' urlNicEdit
-        addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|]
-    }
-
 readMay :: Read a => String -> Maybe a
 readMay s = case reads s of
                 (x, _):_ -> Just x
@@ -836,31 +736,6 @@ toLabel (x:rest) = toUpper x : go rest
         | isUpper c = ' ' : c : go cs
         | otherwise = c : go cs
 
-jqueryAutocompleteField :: Yesod y =>
-    Route y -> FormFieldSettings -> FormletField sub y String
-jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
-
-maybeJqueryAutocompleteField :: Yesod y =>
-    Route y -> FormFieldSettings -> FormletField sub y (Maybe String)
-maybeJqueryAutocompleteField src =
-    optionalFieldHelper $ jqueryAutocompleteFieldProfile src
-
-jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String
-jqueryAutocompleteFieldProfile src = FieldProfile
-    { fpParse = Right
-    , fpRender = id
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$
-|]
-    , fpWidget = \name -> do
-        addScript' urlJqueryJs
-        addScript' urlJqueryUiJs
-        addStylesheet' urlJqueryUiCss
-        addJavaScript [$hamlet|
-$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});
-|]
-    }
-
 emailFieldProfile :: FieldProfile s y String
 emailFieldProfile = FieldProfile
     { fpParse = \s -> if Email.isValid s
@@ -887,15 +762,5 @@ emailInput n =
 nameSettings :: String -> FormFieldSettings
 nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
 
-addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
-addScript' f = do
-    y <- liftHandler getYesod
-    addScriptEither $ f y
-
-addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
-addStylesheet' f = do
-    y <- liftHandler getYesod
-    addStylesheetEither $ f y
-
 labelSettings :: String -> FormFieldSettings
 labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing

Yesod/Form/Jquery.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Form.Jquery
+    ( YesodJquery (..)
+    , jqueryDayField
+    , maybeJqueryDayField
+    , jqueryDayTimeField
+    , jqueryDayTimeFieldProfile
+    , jqueryAutocompleteField
+    , maybeJqueryAutocompleteField
+    , jqueryDayFieldProfile
+    ) where
+
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Widget
+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
+                  timeToTimeOfDay)
+import Yesod.Hamlet
+import Data.Char (isSpace)
+
+class YesodJquery a where
+    -- | The jQuery Javascript file.
+    urlJqueryJs :: a -> Either (Route a) String
+    urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
+
+    -- | The jQuery UI 1.8.1 Javascript file.
+    urlJqueryUiJs :: a -> Either (Route a) String
+    urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"
+
+    -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme.
+    urlJqueryUiCss :: a -> Either (Route a) String
+    urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
+
+    -- | jQuery UI time picker add-on.
+    urlJqueryUiDateTimePicker :: a -> Either (Route a) String
+    urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt"
+
+jqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y Day
+jqueryDayField = requiredFieldHelper jqueryDayFieldProfile
+
+maybeJqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y (Maybe Day)
+maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile
+
+jqueryDayFieldProfile :: YesodJquery y => FieldProfile sub y Day
+jqueryDayFieldProfile = FieldProfile
+    { fpParse = maybe
+                  (Left "Invalid day, must be in YYYY-MM-DD format")
+                  Right
+              . readMay
+    , fpRender = show
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
+|]
+    , fpWidget = \name -> do
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addStylesheet' urlJqueryUiCss
+        addJavaScript [$hamlet|
+$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});
+|]
+    }
+
+ifRight :: Either a b -> (b -> c) -> Either a c
+ifRight e f = case e of
+            Left l  -> Left l
+            Right r -> Right $ f r
+
+showLeadingZero :: (Show a) => a -> String
+showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t
+
+jqueryDayTimeField :: YesodJquery y => FormFieldSettings -> FormletField sub y UTCTime
+jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile
+
+-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)
+jqueryDayTimeUTCTime :: UTCTime -> String
+jqueryDayTimeUTCTime (UTCTime day utcTime) =
+  let timeOfDay = timeToTimeOfDay utcTime
+  in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay
+  where
+    showTimeOfDay (TimeOfDay hour minute _) =
+      let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
+      in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
+
+jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime
+jqueryDayTimeFieldProfile = FieldProfile
+    { fpParse  = parseUTCTime
+    , fpRender = jqueryDayTimeUTCTime
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
+|]
+    , fpWidget = \name -> do
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addScript' urlJqueryUiDateTimePicker
+        addStylesheet' urlJqueryUiCss
+        addJavaScript [$hamlet|
+$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
+|]
+    }
+
+parseUTCTime :: String -> Either String UTCTime
+parseUTCTime s =
+    let (dateS, timeS) = break isSpace (dropWhile isSpace s)
+        dateE = parseDate dateS
+     in case dateE of
+            Left l -> Left l
+            Right date ->
+                ifRight (parseTime timeS)
+                    (UTCTime date . timeOfDayToTime)
+
+jqueryAutocompleteField :: YesodJquery y =>
+    Route y -> FormFieldSettings -> FormletField sub y String
+jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
+
+maybeJqueryAutocompleteField :: YesodJquery y =>
+    Route y -> FormFieldSettings -> FormletField sub y (Maybe String)
+maybeJqueryAutocompleteField src =
+    optionalFieldHelper $ jqueryAutocompleteFieldProfile src
+
+jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String
+jqueryAutocompleteFieldProfile src = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$
+|]
+    , fpWidget = \name -> do
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addStylesheet' urlJqueryUiCss
+        addJavaScript [$hamlet|
+$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});
+|]
+    }
+
+addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
+addScript' f = do
+    y <- liftHandler getYesod
+    addScriptEither $ f y
+
+addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
+addStylesheet' f = do
+    y <- liftHandler getYesod
+    addStylesheetEither $ f y
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
+-- | Replaces all instances of a value in a list by another value.
+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y = map (\z -> if z == x then y else z)

Yesod/Form/Nic.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Form.Nic
+    ( YesodNic (..)
+    , nicHtmlField
+    , maybeNicHtmlField
+    ) where
+
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Hamlet
+import Yesod.Widget
+import qualified Data.ByteString.Lazy.UTF8 as U
+
+class YesodNic a where
+    -- | NIC Editor.
+    urlNicEdit :: a -> Either (Route a) String
+    urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
+
+nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Html ())
+nicHtmlField = requiredFieldHelper nicHtmlFieldProfile
+
+maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe (Html ()))
+maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
+
+nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y (Html ())
+nicHtmlFieldProfile = FieldProfile
+    { fpParse = Right . preEscapedString
+    , fpRender = U.toString . renderHtml
+    , fpHamlet = \theId name val _isReq -> [$hamlet|
+%textarea.html#$theId$!name=$name$ $val$
+|]
+    , fpWidget = \name -> do
+        addScript' urlNicEdit
+        addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|]
+    }
+
+addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
+addScript' f = do
+    y <- liftHandler getYesod
+    addScriptEither $ f y

Yesod/Yesod.hs

@@ -118,26 +118,6 @@ class Eq (Route a) => Yesod a where
     authRoute :: a -> Maybe (Route a)
     authRoute _ = Nothing
 
-    -- | The jQuery Javascript file.
-    urlJqueryJs :: a -> Either (Route a) String
-    urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
-
-    -- | The jQuery UI 1.8.1 Javascript file.
-    urlJqueryUiJs :: a -> Either (Route a) String
-    urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"
-
-    -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme.
-    urlJqueryUiCss :: a -> Either (Route a) String
-    urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
-
-    -- | jQuery UI time picker add-on.
-    urlJqueryUiDateTimePicker :: a -> Either (Route a) String
-    urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt"
-
-    -- | NIC Editor.
-    urlNicEdit :: a -> Either (Route a) String
-    urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
-
 data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
     deriving (Eq, Show, Read)
 

blog2.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 import Yesod
 import Yesod.Helpers.Crud
+import Yesod.Form.Jquery
+import Yesod.Form.Nic
 import Database.Persist.Sqlite
 import Database.Persist.TH
 import Data.Time (Day)
@@ -10,8 +12,8 @@ import Data.Time (Day)
 share2 mkToForm mkPersist [$persist|
 Entry
     title String id=thetitle
-    day Day Desc toFormField=Yesod.jqueryDayField name=day
+    day Day Desc toFormField=YesodJquery.jqueryDayField name=day
-    content Html' toFormField=nicHtmlField
+    content Html' toFormField=YesodNic.nicHtmlField
     deriving
 |]
 
@@ -30,6 +32,8 @@ mkYesod "Blog" [$parseRoutes|
 
 instance Yesod Blog where
     approot _ = "http://localhost:3000"
+instance YesodJquery Blog
+instance YesodNic Blog
 
 instance YesodPersist Blog where
     type YesodDB Blog = SqliteReader

yesod.cabal

@@ -49,6 +49,8 @@ library
                      Yesod.Content
                      Yesod.Dispatch
                      Yesod.Form
+                     Yesod.Form.Jquery
+                     Yesod.Form.Nic
                      Yesod.Hamlet
                      Yesod.Handler
                      Yesod.Internal