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

Merge remote-tracking branch 'origin/master'

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-29 07:46:16 +02:00
commit cd2ee40856
5 changed files with 54 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
yesod-form/Yesod/Form/Fields.hs
View File

@ -25,6 +25,7 @@ module Yesod.Form.Fields
, parseTime
, Textarea (..)
, boolField
, checkBoxField
-- * File 'AForm's
, fileAFormReq
, fileAFormOpt
@ -45,6 +46,7 @@ module Yesod.Form.Fields
import Yesod.Form.Types
import Yesod.Form.I18n.English
import Yesod.Handler (getMessageRender)
import Yesod.Widget
import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))
import Text.Hamlet
@ -303,7 +305,7 @@ urlField = Field
|]
}
selectFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
selectFieldList = selectField . optionsPairs
selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
@ -312,7 +314,7 @@ selectField = selectFieldHelper
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside
multiSelectFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]
multiSelectFieldList = multiSelectField . optionsPairs
multiSelectField :: (Eq a, RenderMessage master FormMessage)
@ -340,7 +342,7 @@ multiSelectField ioptlist =
optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
radioFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
radioFieldList = radioField . optionsPairs
radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
@ -383,6 +385,29 @@ boolField = Field
t -> Left $ SomeMessage $ MsgInvalidBool t
showVal = either (\_ -> False)
-- | While the default @'boolField'@ implements a radio button so you
-- can differentiate between an empty response (Nothing) and a no
-- response (Just False), this simpler checkbox field returns an empty
-- response as Just False.
--
-- Note that this makes the field always optional.
--
checkBoxField :: RenderMessage m FormMessage => Field s m Bool
checkBoxField = Field
{ fieldParse = return . checkBoxParser
, fieldView = \theId name theClass val _ -> [whamlet|
<input id=#{theId} :not (null theClass):class="#{T.intercalate " " theClass}" type=checkbox name=#{name} value=yes :showVal id val:checked>
|]
}
where
checkBoxParser [] = Right $ Just False
checkBoxParser (x:_) = case x of
"yes" -> Right $ Just True
_ -> Right $ Just False
showVal = either (\_ -> False)
data OptionList a = OptionList
{ olOptions :: [Option a]
, olReadExternal :: Text -> Maybe a
@ -400,12 +425,15 @@ data Option a = Option
, optionExternalValue :: Text
}
optionsPairs :: [(Text, a)] -> GHandler sub master (OptionList a)
optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
{ optionDisplay = display
, optionInternalValue = internal
, optionExternalValue = pack $ show external
}) [1 :: Int ..]
optionsPairs :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a)
optionsPairs opts = do
mr <- getMessageRender
let mkOption external (display, internal) =
Option { optionDisplay = mr display
, optionInternalValue = internal
, optionExternalValue = pack $ show external
}
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
optionsEnum :: (Show a, Enum a, Bounded a) => GHandler sub master (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
@ -413,12 +441,14 @@ optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist master, PersistEntity a
, PersistQuery (YesodPersistBackend master) (GHandler sub master)
, PathPiece (Key (YesodPersistBackend master) a)
, RenderMessage master msg
)
=> [Filter a] -> [SelectOpt a] -> (a -> Text) -> GHandler sub master (OptionList (Entity (YesodPersistBackend master) a))
=> [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler sub master (OptionList (Entity (YesodPersistBackend master) a))
optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender
pairs <- runDB $ selectList filts ords
return $ map (\(Entity key value) -> Option
{ optionDisplay = toDisplay value
{ optionDisplay = mr (toDisplay value)
, optionInternalValue = Entity key value
, optionExternalValue = toPathPiece key
}) pairs

17
yesod/Devel.hs
View File

@ -49,7 +49,7 @@ removeLock :: IO ()
removeLock = try_ (removeFile lockFile)
devel :: Bool -> IO ()
devel isDevel = do
devel isCabalDev = do
writeLock
putStrLn "Yesod devel server. Press ENTER to quit"
@ -59,7 +59,7 @@ devel isDevel = do
checkCabalFile gpd
_ <- if isDevel
_ <- if isCabalDev
then rawSystem "cabal-dev"
[ "configure"
, "--cabal-install-arg=-fdevel" -- legacy
@ -73,7 +73,7 @@ devel isDevel = do
, "--disable-library-profiling"
]
mainLoop isDevel
mainLoop isCabalDev
_ <- getLine
writeLock
@ -82,20 +82,21 @@ devel isDevel = do
mainLoop :: Bool -> IO ()
mainLoop isDevel = forever $ do
mainLoop isCabalDev = forever $ do
putStrLn "Rebuilding application..."
recompDeps
list <- getFileList
_ <- if isDevel
_ <- if isCabalDev
then rawSystem "cabal-dev" ["build"]
else rawSystem "cabal" ["build"]
removeLock
putStrLn "Starting development server..."
pkg <- pkgConfigs isDevel
ph <- runCommand $ concat ["runghc ", pkg, " devel.hs"]
pkg <- pkgConfigs isCabalDev
let start = concat ["runghc ", pkg, " devel.hs"]
putStrLn $ "Starting development server: " ++ start
ph <- runCommand start
watchTid <- forkIO . try_ $ do
watchForChanges list
putStrLn "Stopping development server..."

4
yesod/scaffold/Application.hs.cg
View File

@ -13,7 +13,7 @@ import Yesod.Default.Main
import Yesod.Default.Handlers
#if DEVELOPMENT
import Yesod.Logger (Logger, logBS)
import Network.Wai.Middleware.RequestLogger (logHandleDev)
import Network.Wai.Middleware.RequestLogger (logCallbackDev)
#else
import Yesod.Logger (Logger, logBS, toProduction)
import Network.Wai.Middleware.RequestLogger (logHandle)
@ -46,7 +46,7 @@ getApplication conf logger = do
return $ logWare app
where
#ifdef DEVELOPMENT
logWare = logHandleDev (logBS setLogger)
logWare = logCallbackDev (logBS setLogger)
setLogger = logger
#else
setLogger = toProduction logger -- by default the logger is set for development

2
yesod/scaffold/project.cabal.cg
View File

@ -93,7 +93,7 @@ executable ~project~
, shakespeare-text >= 0.10 && < 0.11
, hjsmin >= 0.0.14 && < 0.1
, monad-control >= 0.3 && < 0.4
, wai-extra >= 1.0 && < 1.1
, wai-extra >= 1.0 && < 1.2
, yaml >= 0.5 && < 0.6
, http-conduit >= 1.2 && < 1.3

2
yesod/scaffold/tiny/project.cabal.cg
View File

@ -76,7 +76,7 @@ executable ~project~
, hamlet >= 0.10 && < 0.11
, shakespeare-text >= 0.10 && < 0.11
, wai >= 1.0 && < 1.1
, wai-extra >= 1.0 && < 1.1
, wai-extra >= 1.0 && < 1.2
, transformers >= 0.2 && < 0.3
, monad-control >= 0.3 && < 0.4
, yaml >= 0.5 && < 0.6