dd667844b6
Only use that when building with ancient yesod, which does not include it. This also let me remove ifdefs in the file to support building with the new version of yesod.
260 lines
9 KiB
Haskell
260 lines
9 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | 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
|
|
, BootstrapFormLayout(..)
|
|
, BootstrapGridOptions(..)
|
|
-- * Field settings
|
|
, bfs
|
|
, withPlaceholder
|
|
, withAutofocus
|
|
, withLargeInput
|
|
, withSmallInput
|
|
-- * Submit button
|
|
, bootstrapSubmit
|
|
, mbootstrapSubmit
|
|
, BootstrapSubmit(..)
|
|
) where
|
|
|
|
import Control.Arrow (second)
|
|
import Control.Monad (liftM)
|
|
import Data.Text (Text)
|
|
import Data.String (IsString(..))
|
|
import Yesod.Core
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import Yesod.Form.Types
|
|
import Yesod.Form.Functions
|
|
|
|
-- | Create a new 'FieldSettings' with the classes that are
|
|
-- required by Bootstrap v3.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
bfs :: RenderMessage site msg => msg -> FieldSettings site
|
|
bfs msg =
|
|
FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
|
|
|
|
|
|
-- | Add a placeholder attribute to a field. If you need i18n
|
|
-- for the placeholder, currently you\'ll need to do a hack and
|
|
-- use 'getMessageRender' manually.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
|
|
withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
|
|
where newAttrs = ("placeholder", placeholder) : fsAttrs fs
|
|
|
|
|
|
-- | Add an autofocus attribute to a field.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
withAutofocus :: FieldSettings site -> FieldSettings site
|
|
withAutofocus fs = fs { fsAttrs = newAttrs }
|
|
where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
|
|
|
|
|
|
-- | Add the @input-lg@ CSS class to a field.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
withLargeInput :: FieldSettings site -> FieldSettings site
|
|
withLargeInput fs = fs { fsAttrs = newAttrs }
|
|
where newAttrs = addClass "input-lg" (fsAttrs fs)
|
|
|
|
|
|
-- | Add the @input-sm@ CSS class to a field.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
withSmallInput :: FieldSettings site -> FieldSettings site
|
|
withSmallInput fs = fs { fsAttrs = newAttrs }
|
|
where newAttrs = addClass "input-sm" (fsAttrs fs)
|
|
|
|
|
|
addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
|
|
addClass klass [] = [("class", klass)]
|
|
addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
|
|
addClass klass (other :rest) = other : addClass klass rest
|
|
|
|
|
|
-- | How many bootstrap grid columns should be taken (see
|
|
-- 'BootstrapFormLayout').
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
data BootstrapGridOptions =
|
|
ColXs !Int
|
|
| ColSm !Int
|
|
| ColMd !Int
|
|
| ColLg !Int
|
|
deriving (Eq, Ord, Show)
|
|
|
|
toColumn :: BootstrapGridOptions -> String
|
|
toColumn (ColXs 0) = ""
|
|
toColumn (ColSm 0) = ""
|
|
toColumn (ColMd 0) = ""
|
|
toColumn (ColLg 0) = ""
|
|
toColumn (ColXs columns) = "col-xs-" ++ show columns
|
|
toColumn (ColSm columns) = "col-sm-" ++ show columns
|
|
toColumn (ColMd columns) = "col-md-" ++ show columns
|
|
toColumn (ColLg columns) = "col-lg-" ++ show columns
|
|
|
|
toOffset :: BootstrapGridOptions -> String
|
|
toOffset (ColXs 0) = ""
|
|
toOffset (ColSm 0) = ""
|
|
toOffset (ColMd 0) = ""
|
|
toOffset (ColLg 0) = ""
|
|
toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
|
|
toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
|
|
toOffset (ColMd columns) = "col-md-offset-" ++ show columns
|
|
toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
|
|
|
|
addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
|
|
addGO (ColXs a) (ColXs b) = ColXs (a+b)
|
|
addGO (ColSm a) (ColSm b) = ColSm (a+b)
|
|
addGO (ColMd a) (ColMd b) = ColMd (a+b)
|
|
addGO (ColLg a) (ColLg b) = ColLg (a+b)
|
|
addGO a b | a > b = addGO b a
|
|
addGO (ColXs a) other = addGO (ColSm a) other
|
|
addGO (ColSm a) other = addGO (ColMd a) other
|
|
addGO (ColMd a) other = addGO (ColLg a) other
|
|
addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here"
|
|
|
|
|
|
-- | The layout used for the bootstrap form.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
data BootstrapFormLayout =
|
|
BootstrapBasicForm
|
|
| BootstrapInlineForm
|
|
| BootstrapHorizontalForm
|
|
{ bflLabelOffset :: !BootstrapGridOptions
|
|
, bflLabelSize :: !BootstrapGridOptions
|
|
, bflInputOffset :: !BootstrapGridOptions
|
|
, bflInputSize :: !BootstrapGridOptions
|
|
}
|
|
deriving (Show)
|
|
|
|
|
|
-- | Render the given form using Bootstrap v3 conventions.
|
|
--
|
|
-- Sample Hamlet for 'BootstrapHorizontalForm':
|
|
--
|
|
-- > <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
|
|
-- > ^{formWidget}
|
|
-- > ^{bootstrapSubmit MsgSubmit}
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
|
|
renderBootstrap3 formLayout aform fragment = do
|
|
(res, views') <- aFormToForm aform
|
|
let views = views' []
|
|
has (Just _) = True
|
|
has Nothing = False
|
|
widget = [whamlet|
|
|
#{fragment}
|
|
$forall view <- views
|
|
<div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
|
|
$case formLayout
|
|
$of BootstrapBasicForm
|
|
$if nequals (fvId view) bootstrapSubmitId
|
|
<label for=#{fvId view}>#{fvLabel view}
|
|
^{fvInput view}
|
|
^{helpWidget view}
|
|
$of BootstrapInlineForm
|
|
$if nequals (fvId view) bootstrapSubmitId
|
|
<label .sr-only for=#{fvId view}>#{fvLabel view}
|
|
^{fvInput view}
|
|
^{helpWidget view}
|
|
$of BootstrapHorizontalForm _a _b _c _d
|
|
$if nequals (fvId view) bootstrapSubmitId
|
|
<label .control-label .#{toOffset (bflLabelOffset formLayout)} .#{toColumn (bflLabelSize formLayout)} for=#{fvId view}>#{fvLabel view}
|
|
<div .#{toOffset (bflInputOffset formLayout)} .#{toColumn (bflInputSize formLayout)}>
|
|
^{fvInput view}
|
|
^{helpWidget view}
|
|
$else
|
|
<div .#{toOffset (addGO (bflInputOffset formLayout) (addGO (bflLabelOffset formLayout) (bflLabelSize formLayout)))} .#{toColumn (bflInputSize formLayout)}>
|
|
^{fvInput view}
|
|
^{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.
|
|
helpWidget :: FieldView sub master -> GWidget sub master ()
|
|
helpWidget view = [whamlet|
|
|
$maybe tt <- fvTooltip view
|
|
<span .help-block>#{tt}
|
|
$maybe err <- fvErrors view
|
|
<span .help-block>#{err}
|
|
|]
|
|
|
|
|
|
-- | How the 'bootstrapSubmit' button should be rendered.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
data BootstrapSubmit msg =
|
|
BootstrapSubmit
|
|
{ bsValue :: msg
|
|
-- ^ The text of the submit button.
|
|
, bsClasses :: Text
|
|
-- ^ Classes added to the @<button>@.
|
|
, bsAttrs :: [(Text, Text)]
|
|
-- ^ Attributes added to the @<button>@.
|
|
} deriving (Show)
|
|
|
|
instance IsString msg => IsString (BootstrapSubmit msg) where
|
|
fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
|
|
|
|
|
|
-- | A Bootstrap v3 submit button disguised as a field for
|
|
-- convenience. For example, if your form currently is:
|
|
--
|
|
-- > Person <$> areq textField "Name" Nothing
|
|
-- > <*> areq textField "Surname" Nothing
|
|
--
|
|
-- Then just change it to:
|
|
--
|
|
-- > Person <$> areq textField "Name" Nothing
|
|
-- > <*> areq textField "Surname" Nothing
|
|
-- > <* bootstrapSubmit "Register"
|
|
--
|
|
-- (Note that @<*@ is not a typo.)
|
|
--
|
|
-- Alternatively, you may also just create the submit button
|
|
-- manually as well in order to have more control over its
|
|
-- layout.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
|
|
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
|
|
|
|
|
|
-- | Same as 'bootstrapSubmit' but for monadic forms. This isn't
|
|
-- as useful since you're not going to use 'renderBootstrap3'
|
|
-- anyway.
|
|
--
|
|
-- Since: yesod-form 1.3.8
|
|
mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
|
|
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
|
|
let res = FormSuccess ()
|
|
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
|
|
fv = FieldView { fvLabel = ""
|
|
, fvTooltip = Nothing
|
|
, fvId = bootstrapSubmitId
|
|
, fvInput = widget
|
|
, fvErrors = Nothing
|
|
, fvRequired = False }
|
|
in return (res, fv)
|
|
|
|
|
|
-- | A royal hack. Magic id used to identify whether a field
|
|
-- should have no label. A valid HTML4 id which is probably not
|
|
-- going to clash with any other id should someone use
|
|
-- 'bootstrapSubmit' outside 'renderBootstrap3'.
|
|
bootstrapSubmitId :: Text
|
|
bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"
|