Merge remote-tracking branch 'origin/master'

yesod-form/Yesod/Form/Fields.hs

@@ -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 :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a)
-optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
+optionsPairs opts = do
-    { optionDisplay = display
+  mr <- getMessageRender
-    , optionInternalValue = internal
+  let mkOption external (display, internal) =
-    , optionExternalValue = pack $ show external
+          Option { optionDisplay       = mr display
-    }) [1 :: Int ..]
+                 , 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

yesod/Devel.hs

@@ -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 isCabalDev
-   pkg <- pkgConfigs isDevel
+   let start = concat ["runghc ", pkg, " devel.hs"]
-   ph <- runCommand $ concat ["runghc ", pkg, " devel.hs"]
+   putStrLn $ "Starting development server: " ++ start
+   ph <- runCommand start
    watchTid <- forkIO . try_ $ do
      watchForChanges list
      putStrLn "Stopping development server..."

yesod/scaffold/Application.hs.cg

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

yesod/scaffold/project.cabal.cg

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

yesod/scaffold/tiny/project.cabal.cg

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