summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorncaq <>2017-07-17 07:13:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-17 07:13:00 (GMT)
commit2801889bb530d524ebc92f04d34bdf2085693a7d (patch)
tree81985104fbaa016c71670f04febc66a6f4e281aa
version 0.1.0.00.1.0.0
-rw-r--r--src/Yesod/Form/Bootstrap4.hs188
-rw-r--r--yesod-form-bootstrap4.cabal31
2 files changed, 219 insertions, 0 deletions
diff --git a/src/Yesod/Form/Bootstrap4.hs b/src/Yesod/Form/Bootstrap4.hs
new file mode 100644
index 0000000..22844f1
--- /dev/null
+++ b/src/Yesod/Form/Bootstrap4.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | this program based on Yesod.Form.Bootstrap3 of yesod-form
+-- yesod-form under MIT license, author is Michael Snoyman <michael@snoyman.com>
+
+module Yesod.Form.Bootstrap4
+ ( renderBootstrap4
+ , BootstrapFormLayout(..)
+ , BootstrapGridOptions(..)
+ , bfs
+ , withPlaceholder
+ , withAutofocus
+ , withLargeInput
+ , withSmallInput
+ , bootstrapSubmit
+ , mbootstrapSubmit
+ , BootstrapSubmit(..)
+ ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Form
+
+bfs :: RenderMessage site msg => msg -> FieldSettings site
+bfs msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
+
+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.
+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.
+withLargeInput :: FieldSettings site -> FieldSettings site
+withLargeInput fs = fs { fsAttrs = newAttrs }
+ where newAttrs = addClass "form-control-lg" (fsAttrs fs)
+
+-- | Add the @input-sm@ CSS class to a field.
+withSmallInput :: FieldSettings site -> FieldSettings site
+withSmallInput fs = fs { fsAttrs = newAttrs }
+ where newAttrs = addClass "form-control-sm" (fsAttrs fs)
+
+addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addClass klass [] = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", concat [old, " ", klass]) : rest
+addClass klass (other :rest) = other : addClass klass rest
+
+data BootstrapGridOptions = ColXs !Int | ColSm !Int | ColMd !Int | ColLg !Int | ColXl !Int
+ deriving (Eq, Ord, Show, Read)
+
+toColumn :: BootstrapGridOptions -> String
+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
+toColumn (ColXl columns) = "col-xl-" ++ show columns
+
+toOffset :: BootstrapGridOptions -> String
+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
+toOffset (ColXl columns) = "col-Xl-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 _ _ = error "Yesod.Form.Bootstrap.addGO: never here"
+
+-- | The layout used for the bootstrap form.
+data BootstrapFormLayout = BootstrapBasicForm | BootstrapInlineForm |
+ BootstrapHorizontalForm
+ { bflLabelOffset :: !BootstrapGridOptions
+ , bflLabelSize :: !BootstrapGridOptions
+ , bflInputOffset :: !BootstrapGridOptions
+ , bflInputSize :: !BootstrapGridOptions
+ }
+ deriving (Eq, Ord, Show, Read)
+
+-- | Render the given form using Bootstrap v3 conventions.
+renderBootstrap4 :: Monad m => BootstrapFormLayout -> FormRender m a
+renderBootstrap4 formLayout aform fragment = do
+ (res, views') <- aFormToForm aform
+ let views = views' []
+ widget = [whamlet|
+ #{fragment}
+ $forall view <- views
+ <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :isJust $ fvErrors view:.has-danger>
+ $case formLayout
+ $of BootstrapBasicForm
+ $if fvId view /= bootstrapSubmitId
+ <label .form-control-label for=#{fvId view}>#{fvLabel view}
+ ^{fvInput view}
+ ^{helpWidget view}
+ $of BootstrapInlineForm
+ $if fvId view /= bootstrapSubmitId
+ <label .sr-only .form-control-label for=#{fvId view}>#{fvLabel view}
+ ^{fvInput view}
+ ^{helpWidget view}
+ $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
+ $if fvId view /= bootstrapSubmitId
+ <label .form-control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
+ <div .#{toOffset inputOffset} .#{toColumn inputSize}>
+ ^{fvInput view}
+ ^{helpWidget view}
+ $else
+ <div .#{toOffset (addGO inputOffset (addGO labelOffset labelSize))} .#{toColumn inputSize}>
+ ^{fvInput view}
+ ^{helpWidget view}
+ |]
+ return (res, widget)
+
+-- | (Internal) Render a help widget for tooltips and errors.
+helpWidget :: FieldView site -> WidgetT site IO ()
+helpWidget view = [whamlet|
+ $maybe tt <- fvTooltip view
+ <span .form-text>#{tt}
+ $maybe err <- fvErrors view
+ <span .form-text .has-danger>#{err}
+|]
+
+-- | How the 'bootstrapSubmit' button should be rendered.
+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 (Eq, Ord, Show, Read)
+
+instance IsString msg => IsString (BootstrapSubmit msg) where
+ fromString msg = BootstrapSubmit (fromString msg) "btn-primary" []
+
+-- | A Bootstrap v4 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" :: BootstrapSubmit Text)
+--
+-- (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.
+bootstrapSubmit :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
+ BootstrapSubmit msg -> AForm m ()
+bootstrapSubmit = formToAForm . fmap (second return) . mbootstrapSubmit
+
+-- | Same as 'bootstrapSubmit' but for monadic forms. This isn't
+-- as useful since you're not going to use 'renderBootstrap4'
+-- anyway.
+mbootstrapSubmit :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
+ BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+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 'renderBootstrap4'.
+bootstrapSubmitId :: Text
+bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"
diff --git a/yesod-form-bootstrap4.cabal b/yesod-form-bootstrap4.cabal
new file mode 100644
index 0000000..da008a3
--- /dev/null
+++ b/yesod-form-bootstrap4.cabal
@@ -0,0 +1,31 @@
+-- This file has been generated from package.yaml by hpack version 0.17.0.
+--
+-- see: https://github.com/sol/hpack
+
+name: yesod-form-bootstrap4
+version: 0.1.0.0
+synopsis: renderBootstrap4
+category: Web
+homepage: https://github.com/ncaq/yesod-form-bootstrap4.git#readme
+bug-reports: https://github.com/ncaq/yesod-form-bootstrap4.git/issues
+author: ncaq
+maintainer: ncaq@ncaq.net
+copyright: © ncaq
+license: MIT
+build-type: Simple
+cabal-version: >= 1.10
+
+source-repository head
+ type: git
+ location: https://github.com/ncaq/yesod-form-bootstrap4.git
+
+library
+ hs-source-dirs:
+ src
+ build-depends:
+ base >= 4.7 && < 5
+ , classy-prelude-yesod
+ , yesod-form
+ exposed-modules:
+ Yesod.Form.Bootstrap4
+ default-language: Haskell2010