{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
module Yesod.Form.Bulma
( module Yesod.Form.Bulma.Fields
, module Yesod.Form.Bulma.Class
, renderBulma
, bulmaSubmit
, BulmaSubmit(..)
, BulmaFormLayout(..)
, withPlaceholder
) where
import Data.Bifunctor
import Data.Text (Text)
import Text.Shakespeare.I18N
import Yesod.Core
import Yesod.Form.Bulma.Class
import Yesod.Form.Bulma.Fields
import Yesod.Form.Bulma.Utils
import Yesod.Form.Functions
import Yesod.Form.Types
data BulmaFormLayout = BulmaBasicForm
data BulmaSubmit msg =
BulmaSubmit
{ _bulmaValue :: msg
, _bulmaClasses :: Text
, _bulmaAttrs :: [(Text, Text)]
} deriving Show
renderBulma :: YesodBulma site => BulmaFormLayout -> FormRender (HandlerFor site) a
renderBulma formLayout aform fragment = do
(res, views') <- aFormToForm aform
let
views = views' []
widget = do
addStylesheet' urlBulmaCss
addScript' urlFontawesomeJs
_cancelId <- newIdent
[whamlet| $newline never
#{fragment}
$forall view <- views
$if fvId view == bulmaSubmitId
<div .field .is-grouped>
<div .control>
<button .button .is-link>Submit
$else
<div .field
:fvRequired view:.required
:not $ fvRequired view:.optional
:has $ fvErrors view:.is-danger>
$case formLayout
$of BulmaBasicForm
<label .label for=#{fvId view}>#{fvLabel view}
<div .control>
^{fvInput view}
^{helpWidget view}
|]
return (res, widget)
where
has (Just _) = True
has Nothing = False
bulmaSubmit :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) => BulmaSubmit msg -> AForm m ()
bulmaSubmit= formToAForm . fmap (second return) . mbulmaSubmit
mbulmaSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BulmaSubmit msg -> MForm m (FormResult (), FieldView site)
mbulmaSubmit (BulmaSubmit msg classes attrs) =
let res = FormSuccess ()
widget = [whamlet|$newline never
<button class="btn #{classes}" type=submit *{attrs}>_{msg}
|]
fv = FieldView { fvLabel = ""
, fvTooltip = Nothing
, fvId = bulmaSubmitId
, fvInput = widget
, fvErrors = Nothing
, fvRequired = False }
in return (res, fv)
helpWidget :: FieldView site -> WidgetFor site ()
helpWidget view = [whamlet|
$maybe tt <- fvTooltip view
<span .help-block>#{tt}
$maybe err <- fvErrors view
<span .help-block .error-block>#{err}
|]
bulmaSubmitId :: Text
bulmaSubmitId = "b:ulma___unique__:::::::::::::::::submit-id"
withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
where newAttrs = ("placeholder", placeholder) : fsAttrs fs