diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index bc9b64d2..5e3e7318 100644 --- a/Yesod/Dispatch.hs +++ b/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" diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 73cdb02d..2052cad2 100644 --- a/Yesod/Form.hs +++ b/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.LocalTime (timeOfDayToTime, timeToTimeOfDay) +import Data.Time (Day, TimeOfDay(..)) 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,94 +380,21 @@ instance ToFormField Day y where instance ToFormField (Maybe Day) y where toFormField = maybeDayField -jqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y Day -jqueryDayField = requiredFieldHelper jqueryDayFieldProfile - -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'})}); -|] - } +parseDate :: String -> Either String Day +parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay . replace '/' '-' -- | 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') parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = +parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 in parseTimeHelper (h1', h2', m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = @@ -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 diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs new file mode 100644 index 00000000..d670fde1 --- /dev/null +++ b/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) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs new file mode 100644 index 00000000..1b381b60 --- /dev/null +++ b/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 diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3cba2a6f..9b800dfa 100644 --- a/Yesod/Yesod.hs +++ b/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) diff --git a/blog2.hs b/blog2.hs index 0e2034c0..3a58325f 100644 --- a/blog2.hs +++ b/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 - content Html' toFormField=nicHtmlField + day Day Desc toFormField=YesodJquery.jqueryDayField name=day + 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 diff --git a/yesod.cabal b/yesod.cabal index 6471a351..27c6cc5a 100644 --- a/yesod.cabal +++ b/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