haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split jquery and nic code into separate modules

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-26 15:55:35 +03:00
parent 9392665491
commit 46be96e6c2
7 changed files with 210 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
Yesod/Dispatch.hs
View File

@ -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"

151
Yesod/Form.hs
View File

@ -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

154
Yesod/Form/Jquery.hs Normal file
View File

@ -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)

40
Yesod/Form/Nic.hs Normal file
View File

@ -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

20
Yesod/Yesod.hs
View File

@ -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)

8
blog2.hs
View File

@ -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

2
yesod.cabal
View File

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