backport Yesod.Form.Bootstrap3 to Yesod 1.0.1

Assistant/WebApp/Bootstrap3.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 -- | Helper functions for creating forms when using Bootstrap v3.
+-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
+-- modified to be compatible with Yesod 1.0.1
 module Assistant.WebApp.Bootstrap3
   ( -- * Rendering forms
     renderBootstrap3
@@ -146,30 +149,36 @@ data BootstrapFormLayout =
 -- >    ^{bootstrapSubmit MsgSubmit}
 --
 -- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
 renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+#else
+renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
+#endif
 renderBootstrap3 formLayout aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
         has (Just _) = True
         has Nothing  = False
         widget = [whamlet|
+#if MIN_VERSION_yesod(1,2,0)
             $newline never
+#endif
             #{fragment}
             $forall view <- views
               <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
                 $case formLayout
                   $of BootstrapBasicForm
-                    $if fvId view /= bootstrapSubmitId
+                    $if nequals (fvId view) bootstrapSubmitId
                       <label for=#{fvId view}>#{fvLabel view}
                     ^{fvInput view}
                     ^{helpWidget view}
                   $of BootstrapInlineForm
-                    $if fvId view /= bootstrapSubmitId
+                    $if nequals (fvId view) bootstrapSubmitId
                       <label .sr-only for=#{fvId view}>#{fvLabel view}
                     ^{fvInput view}
                     ^{helpWidget view}
                   $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
-                    $if fvId view /= bootstrapSubmitId
+                    $if nequals (fvId view) bootstrapSubmitId
                       <label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
                       <div .#{toOffset inputOffset} .#{toColumn inputSize}>
                         ^{fvInput view}
@@ -180,10 +189,15 @@ renderBootstrap3 formLayout aform fragment = do
                         ^{helpWidget view}
                 |]
     return (res, widget)
-
+  where
+    nequals a b = a /= b -- work around older hamlet versions not liking /=
 
 -- | (Internal) Render a help widget for tooltips and errors.
+#if MIN_VERSION_yesod(1,2,0)
 helpWidget :: FieldView site -> WidgetT site IO ()
+#else
+helpWidget :: FieldView sub master -> GWidget sub master ()
+#endif
 helpWidget view = [whamlet|
     $maybe tt <- fvTooltip view
       <span .help-block>#{tt}
@@ -228,9 +242,13 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
 -- layout.
 --
 -- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
 bootstrapSubmit
     :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
     => BootstrapSubmit msg -> AForm m ()
+#else
+bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
+#endif
 bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 
 
@@ -239,9 +257,13 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 -- anyway.
 --
 -- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
 mbootstrapSubmit
     :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
     => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+#else
+mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
+#endif
 mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
     let res = FormSuccess ()
         widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]

Assistant/WebApp/Common.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.WebApp.Common (module X) where
 
 import Assistant.Common as X
@@ -13,6 +15,9 @@ import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X
 import Assistant.WebApp.Types as X
 import Assistant.WebApp.RepoId as X
+#if MIN_VERSION_yesod(1,2,0)
 import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
-
+#else
+import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
+#endif
 import Data.Text as X (Text)

Assistant/WebApp/Form.hs

@@ -15,12 +15,20 @@ module Assistant.WebApp.Form where
 import Assistant.WebApp.Types
 import Assistant.Gpg
 
+#if MIN_VERSION_yesod(1,2,0)
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
+#else
+import Yesod hiding (textField, passwordField, selectField, selectFieldList)
+import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
+#endif
 import Assistant.WebApp.Bootstrap3 hiding (bfs)
 import Data.String (IsString (..))
 import Data.Text (Text)
 
+import Control.Monad (unless)
+import Data.Maybe (listToMaybe)
+
 {- Yesod's textField sets the required attribute for required fields.
  - We don't want this, because many of the forms used in this webapp 
  - display a modal dialog when submitted, which interacts badly with
@@ -50,6 +58,54 @@ passwordField = F.passwordField
 |]
 	}
 
+{- In older Yesod versions attrs is written into the <option> tag instead of the
+ - surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
+ - it requires the "form-control" class on the <select> tag.
+ - We need to change that to behave the same way as in newer versions.
+ -}
+#if ! MIN_VERSION_yesod(1,2,0)
+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
+selectField = selectFieldHelper
+	(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
+	(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
+	(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside
+
+selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
+	=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
+	-> (Text -> Text -> Bool -> GWidget sub master ())
+	-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
+	-> GHandler sub master (OptionList a) -> Field sub master a
+selectFieldHelper outside onOpt inside opts' = Field
+	{ fieldParse = \x -> do
+		opts <- opts'
+		return $ selectParser opts x
+	, fieldView = \theId name attrs val isReq -> do
+		opts <- fmap olOptions $ lift opts'
+		outside theId name attrs $ do
+			unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
+			flip mapM_ opts $ \opt -> inside
+				theId
+				name
+				((if isReq then (("required", "required"):) else id) attrs)
+				(optionExternalValue opt)
+				((render opts val) == optionExternalValue opt)
+				(optionDisplay opt)
+	}
+  where
+	render _ (Left _) = ""
+	render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
+	selectParser _ [] = Right Nothing
+	selectParser opts (s:_) = case s of
+		"" -> Right Nothing
+		"none" -> Right Nothing
+		x -> case olReadExternal opts x of
+			Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
+			Just y -> Right $ Just y
+#endif
+
 {- Makes a note widget be displayed after a field. -}
 #if MIN_VERSION_yesod(1,2,0)
 withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v