yesod-form-bulma (empty) → 0.1.0.0
raw patch · 12 files changed
+854/−0 lines, 12 filesdep +basedep +email-validatedep +shakespearesetup-changed
Dependencies added: base, email-validate, shakespeare, text, yesod, yesod-core, yesod-form, yesod-form-bulma
Files
- ChangeLog.md +19/−0
- LICENSE +30/−0
- README.md +64/−0
- Setup.hs +2/−0
- app/Example/Main.hs +81/−0
- app/Showcase/Main.hs +93/−0
- src/Yesod/Form/Bulma.hs +101/−0
- src/Yesod/Form/Bulma/Class.hs +20/−0
- src/Yesod/Form/Bulma/Fields.hs +316/−0
- src/Yesod/Form/Bulma/Utils.hs +25/−0
- test/Spec.hs +2/−0
- yesod-form-bulma.cabal +101/−0
+ ChangeLog.md view
@@ -0,0 +1,19 @@+# Changelog for yesod-form-bulma++## Unreleased changes++- Upgrade to yesod-core 1.6+- Add bulmaTextField+- Add bulmaTextareaField+- Add bulmaEmailField+- Add bulmaCheckBoxField+- Add bulmaSelectField+- Add bulmaSelectFieldList+- Add bulmaRadioField+- Add bulmaRadioFieldList+- Add bulmaIntField+- Add bulmaCheckboxesFieldList+- Add bulmaCheckboxesField+- Add bulmaMultiSelectFieldList+- Add bulmaMultiSelectField+- Add Showcases
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Shinya Yamaguchi (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Shinya Yamaguchi nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,64 @@+[](https://circleci.com/gh/waddlaw/yesod-form-bulma/tree/master)++# yesod-form-bulma++- [Bulma](https://bulma.io/documentation/form/)+- [Bulma-Extensions](https://wikiki.github.io/form/checkradio/)+++## Screenshot++++## Run++simple example.++```sh+$ stack build+$ stack exec example+```++full components showcase.++```sh+$ stack build+$ stack exec showcase+```++Access to [localhost:3100](http://localhost:3100)++## Implemented status++### Yesod.Form.Fields++#### Fields++- [x] bulmaTextField+- [ ] bulmaPasswordField+- [x] bulmaTextareaField+- [ ] bulmaHiddenField+- [x] bulmaIntField+- [ ] bulmaDayField+- [ ] bulmaTimeFieldTypeTime+- [ ] bulmaTimeFieldTypeText+- [ ] bulmaHtmlField+- [x] bulmaEmailField+- [ ] bulmaMultiEmailField+- [ ] bulmaSearchField+- [ ] bulmaUrlField+- [ ] bulmaDoubleField+- [ ] bulmaBoolField+- [x] bulmaCheckBoxField+- [ ] bulmaFileField++#### Options++- [x] bulmaSelectField+- [x] bulmaSelectFieldList+- [x] bulmaRadioField+- [x] bulmaRadioFieldList+- [x] bulmaCheckboxesField+- [x] bulmaCheckboxesFieldList+- [x] bulmaMultiSelectField+- [x] bulmaMultiSelectFieldList
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Example/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+module Main (main) where++import Data.Text (Text)+import Yesod+import Yesod.Form.Bulma++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET POST+|]++instance Yesod App+instance YesodBulma App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++data Basic = Basic+ { name :: Text+ , username :: Text+ , email :: Text+ , subject :: Text+ , message :: Textarea+ , agree :: Bool+ , question :: Text+ }++basicForm :: Html -> MForm Handler (FormResult Basic, Widget)+basicForm = renderBulma BulmaBasicForm $ Basic+ <$> areq bulmaTextField ("Text input" `withPlaceholder` "Name") Nothing+ <*> areq bulmaTextField ("bulma" `withPlaceholder` "Username") Nothing+ <*> areq bulmaEmailField ("Email input" `withPlaceholder` "Email") Nothing+ <*> areq (bulmaSelectFieldList [("Select dropdown" :: Text, "v1"), ("With options", "v2")] ) "Subject" Nothing+ <*> areq bulmaTextareaField ("Textarea" `withPlaceholder` "Message") Nothing+ <*> areq (bulmaCheckBoxField "I agree to the terms and conditions") "" Nothing+ <*> areq (bulmaRadioFieldList [("yes" :: Text, "y"), ("no", "n")]) "" Nothing+ <* bulmaSubmit (BulmaSubmit ("Submit" :: Text) "btn-default" [("attribute-name", "attribute-value")])++getHomeR :: Handler Html+getHomeR = do+ ((result, form1), enctype) <- runFormPost basicForm++ defaultLayout $+ case result of+ FormSuccess res ->+ [whamlet|+ <section .section .columns>+ <div .container .column .is-4>+ <form method=post action=@{HomeR} enctype=#{enctype}>+ ^{form1}++ <div .container .column .is-4>+ <table .table>+ <tr><th>Name</th><td>#{name res}</td></tr>+ <tr><th>Username</th><td>#{username res}</td></tr>+ <tr><th>Email</th><td>#{email res}</td></tr>+ <tr><th>Subject</th><td>#{subject res}</td></tr>+ <tr><th>Message</th><td>#{message res}</td></tr>+ <tr><th>Agree</th><td>#{agree res}</td></tr>+ <tr><th>Question</th><td>#{question res}</td></tr>+ |]+ _ ->+ [whamlet|+ <section .section>+ <div .container>+ <form method=post action=@{HomeR} enctype=#{enctype}>+ ^{form1}+ |]++postHomeR :: Handler Html+postHomeR = getHomeR++main :: IO ()+main = warp 3100 App
+ app/Showcase/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+module Main (main) where++import Control.Arrow ((&&&))+import Data.Text (Text, pack)+import Yesod+import Yesod.Form.Bulma++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET POST+|]++instance Yesod App+instance YesodBulma App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++data Basic = Basic+ { getTextField :: Text+ -- , getPasswordField :: Text+ , getTextareaField :: Textarea+ -- , getHiddenField :: Text+ , getIntField :: Int+ -- , getDayField :: Day+ -- , getTimeFieldTypeTime :: Text+ -- , getTimeFieldTypeText+ -- , getHtmlField+ , getEmailField :: Text+ -- , getMultiEmailField+ -- , getSearchField+ -- , getUrlField+ -- , getDoubleField+ -- , getBoolField+ , getCheckBoxField :: Bool+ -- , getFileField+ , getSelectField :: Color+ , getSelectFieldList :: Color+ , getRadioField :: Color+ , getRadioFieldList :: Color+ , getCheckboxesField :: [Color]+ , getCheckboxesFieldList :: [Color]+ , getMultiSelectField :: [Color]+ , getMultiSelectFieldList :: [Color]+ }++data Color = Red | Blue | Gray | Black+ deriving (Show, Eq, Enum, Bounded)++colors :: [(Text, Color)]+colors = map (pack . show &&& id) [minBound .. maxBound]++basicForm :: Html -> MForm Handler (FormResult Basic, Widget)+basicForm = renderBulma BulmaBasicForm $ Basic+ <$> areq bulmaTextField "bulmaTextField" Nothing+ <*> areq bulmaTextareaField "bulmaTextareaField" Nothing+ <*> areq bulmaIntField "bulmaIntField" Nothing+ <*> areq bulmaEmailField "bulmaEmailField" Nothing+ <*> areq (bulmaCheckBoxField "bulmaCheckBoxField") "" Nothing+ <*> areq (bulmaSelectField optionsEnum) "bulmaSelectField" Nothing+ <*> areq (bulmaSelectFieldList colors) "bulmaSelectFieldList" Nothing+ <*> areq (bulmaRadioFieldList colors) "bulmaRadioList" Nothing+ <*> areq (bulmaRadioFieldList colors) "bulmaRadioFieldList" Nothing+ <*> areq (bulmaCheckboxesField optionsEnum) "bulmaCheckboxesField" Nothing+ <*> areq (bulmaCheckboxesFieldList colors) "bulmaCheckboxesFieldList" Nothing+ <*> areq (bulmaMultiSelectField optionsEnum) "bulmaMultiSelectField" Nothing+ <*> areq (bulmaMultiSelectFieldList colors) "bulmaMultiSelectFieldList" Nothing+ <* bulmaSubmit (BulmaSubmit ("Submit" :: Text) "btn-default" [("attribute-name", "attribute-value")])++getHomeR :: Handler Html+getHomeR = do+ ((_result, form1), enctype) <- runFormPost basicForm++ defaultLayout+ [whamlet| $newline never+ <section .section>+ <div .container>+ <form method=post action=@{HomeR} enctype=#{enctype}>+ ^{form1}+ |]++postHomeR :: Handler Html+postHomeR = getHomeR++main :: IO ()+main = warp 3100 App
+ src/Yesod/Form/Bulma.hs view
@@ -0,0 +1,101 @@+{-# 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 -- ^ The text of the submit button.+ , _bulmaClasses :: Text -- ^ Classes added to the @\<button>@.+ , _bulmaAttrs :: [(Text, Text)] -- ^ Attributes added to the @\<button>@.+ } 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)++-- | (Internal) Render a help widget for tooltips and errors.+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
+ src/Yesod/Form/Bulma/Class.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Form.Bulma.Class+ ( YesodBulma+ , urlBulmaCss+ , urlBulmaExCheckRadio+ , urlFontawesomeJs+ ) where++import Data.Text (Text)+import Yesod.Core++class YesodBulma a where+ urlBulmaCss :: a -> Either (Route a) Text+ urlBulmaCss _ = Right "//cdnjs.cloudflare.com/ajax/libs/bulma/0.7.1/css/bulma.min.css"++ urlBulmaExCheckRadio :: a -> Either (Route a) Text+ urlBulmaExCheckRadio _ = Right "//cdn.jsdelivr.net/npm/bulma-extensions@1.0.30/bulma-checkradio/dist/bulma-checkradio.min.css"++ urlFontawesomeJs :: a -> Either (Route a) Text+ urlFontawesomeJs _ = Right "//use.fontawesome.com/releases/v5.0.13/js/all.js"
+ src/Yesod/Form/Bulma/Fields.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Form.Bulma.Fields+ ( bulmaIntField+ , bulmaTextField+ , bulmaEmailField+ , bulmaTextareaField+ , bulmaCheckBoxField+ , bulmaRadioFieldList+ , bulmaRadioField+ , bulmaSelectFieldList+ , bulmaSelectField+ , bulmaCheckboxesFieldList+ , bulmaCheckboxesField+ , bulmaMultiSelectFieldList+ , bulmaMultiSelectField+ ) where++import Control.Arrow ((&&&))+import Control.Monad (forM_, unless)+import Data.Maybe (listToMaybe)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Read (decimal, signed)+import qualified Text.Email.Validate as Email+import Text.Shakespeare.I18N (RenderMessage, SomeMessage (..))+import Yesod.Core (HandlerSite)+import Yesod.Core.Types (HandlerFor, WidgetFor)+import Yesod.Core.Widget (handlerToWidget, whamlet)+import Yesod.Form.Bulma.Class+import Yesod.Form.Bulma.Utils (addStylesheet')+import Yesod.Form.Fields (FormMessage (..), Option (..),+ OptionList (..), Textarea (..),+ optionsPairs)+import Yesod.Form.Functions (parseHelper)+import Yesod.Form.Types (Enctype (..), Field (..))++-- | Creates an input with @type="checkbox"@ for selecting multiple options.+bulmaCheckboxesFieldList+ :: ( YesodBulma site+ , Eq a+ , RenderMessage site msg+ )+ => [(msg, a)] -> Field (HandlerFor site) [a]+bulmaCheckboxesFieldList = bulmaCheckboxesField . optionsPairs++-- | Creates an input with @type="checkbox"@ for selecting multiple options.+bulmaCheckboxesField+ :: ( YesodBulma site+ , Eq a+ )+ => HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]+bulmaCheckboxesField ioptlist = (bulmaMultiSelectField ioptlist)+ { fieldView = \theId name attrs val _isReq -> do+ opts <- olOptions <$> handlerToWidget ioptlist+ let+ optselected (Left _) _ = False+ optselected (Right vals) opt = optionInternalValue opt `elem` vals+ addStylesheet' urlBulmaExCheckRadio+ [whamlet| $newline never+ <div ##{theId}>+ $forall opt <- opts+ <input .is-checkradio type=checkbox id=#{name}-#{optionExternalValue opt} name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>+ <label for=#{name}-#{optionExternalValue opt}>#{optionDisplay opt}+ |]+ }++-- | Creates a @\<select>@ tag for selecting multiple options.+bulmaMultiSelectFieldList+ :: ( Eq a+ , RenderMessage site msg+ )+ => [(msg, a)] -> Field (HandlerFor site) [a]+bulmaMultiSelectFieldList = bulmaMultiSelectField . optionsPairs++-- | Creates a @\<select>@ tag for selecting multiple options.+bulmaMultiSelectField+ :: Eq a+ => HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]+bulmaMultiSelectField ioptlist = Field parse view UrlEncoded+ where+ parse [] _ = return $ Right Nothing+ parse optlist _ = do+ mapopt <- olReadExternal <$> ioptlist+ case mapM mapopt optlist of+ Nothing -> return $ Left "Error parsing values"+ Just res -> return $ Right $ Just res++ view theId name attrs val isReq = do+ opts <- olOptions <$> handlerToWidget ioptlist+ let selOpts = map (id &&& optselected val) opts+ [whamlet| $newline never+ <div .select .is-multiple>+ <select ##{theId} name=#{name} :isReq:required multiple size=#{min 5 (length selOpts)} *{attrs}>+ $forall (opt, optsel) <- selOpts+ <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}+ |]+ where+ optselected (Left _) _ = False+ optselected (Right vals) opt = optionInternalValue opt `elem` vals++-- | Creates a input with @type="number"@ and @step=1@.+bulmaIntField+ :: ( Monad m+ , Integral i+ , RenderMessage (HandlerSite m) FormMessage+ )+ => Field m i+bulmaIntField = Field+ { fieldParse = parseHelper $ \s ->+ case signed decimal s of+ Right (a, "") -> Right a+ _ -> Left $ MsgInvalidInteger s+ , fieldView = \theId name attrs val isReq ->+ [whamlet| $newline never+ <input id="#{theId}" .input name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">+ |]+ , fieldEnctype = UrlEncoded+ }+ where+ showVal = either id (pack . showI)+ showI x = show (fromIntegral x :: Integer)++-- | Creates a input with @type="text"@.+bulmaTextField+ :: ( Monad m+ , RenderMessage (HandlerSite m) FormMessage+ )+ => Field m Text+bulmaTextField = Field+ { fieldParse = parseHelper Right+ , fieldView = \theId name attrs val isReq ->+ [whamlet| $newline never+ <input id="#{theId}" .input name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">+ |]+ , fieldEnctype = UrlEncoded+ }++-- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").+bulmaEmailField+ :: ( Monad m+ , RenderMessage (HandlerSite m) FormMessage+ )+ => Field m Text+bulmaEmailField = Field+ { fieldParse = parseHelper $+ \s ->+ case Email.canonicalizeEmail $ encodeUtf8 s of+ Just e -> Right $ decodeUtf8With lenientDecode e+ Nothing -> Left $ MsgInvalidEmail s+ , fieldView = \theId name attrs val isReq ->+ [whamlet| $newline never+ <input id="#{theId}" .input name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">+ |]+ , fieldEnctype = UrlEncoded+ }++-- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.+bulmaTextareaField+ :: ( Monad m+ , RenderMessage (HandlerSite m) FormMessage+ )+ => Field m Textarea+bulmaTextareaField = Field+ { fieldParse = parseHelper $ Right . Textarea+ , fieldView = \theId name attrs val isReq ->+ [whamlet| $newline never+ <textarea id="#{theId}" .textarea name="#{name}" :isReq:required="" *{attrs}>#{either id unTextarea val}+ |]+ , fieldEnctype = UrlEncoded+ }++-- | Creates an input with @type="checkbox"@.+-- 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.+--+bulmaCheckBoxField+ :: YesodBulma site+ => Text -> Field (HandlerFor site) Bool+bulmaCheckBoxField msg = Field+ { fieldParse = \e _ -> return $ checkBoxParser e+ , fieldView = \theId name attrs val _ -> do+ addStylesheet' urlBulmaExCheckRadio+ [whamlet| $newline never+ <input .is-checkradio id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>+ <label for=#{theId}>#{msg}+ |]+ , fieldEnctype = UrlEncoded+ }+ where+ checkBoxParser [] = Right $ Just False+ checkBoxParser (x:_) = case x of+ "yes" -> Right $ Just True+ "on" -> Right $ Just True+ _ -> Right $ Just False+ showVal = either (const False)++-- | Creates an input with @type="radio"@ for selecting one option.+bulmaRadioFieldList+ :: ( YesodBulma site+ , Eq a+ , RenderMessage site FormMessage+ , RenderMessage site msg+ )+ => [(msg, a)] -> Field (HandlerFor site) a+bulmaRadioFieldList = bulmaRadioField . optionsPairs++-- | Creates an input with @type="radio"@ for selecting one option.+bulmaRadioField+ :: ( YesodBulma site+ , Eq a+ , RenderMessage site FormMessage+ )+ => HandlerFor site (OptionList a) -> Field (HandlerFor site) a+bulmaRadioField = selectFieldHelper+ (\theId _name _attrs inside -> do+ addStylesheet' urlBulmaExCheckRadio+ [whamlet| $newline never+ <div ##{theId}>^{inside}+ |])+ (\theId name isSel -> do+ addStylesheet' urlBulmaExCheckRadio+ [whamlet| $newline never+ <input .is-checkradio id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>+ <labelfor=#{theId}-none>_{MsgSelectNone}+ |])+ (\theId name attrs value isSel text -> do+ addStylesheet' urlBulmaExCheckRadio+ [whamlet| $newline never+ <input .is-checkradio id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>+ <label for=#{theId}-#{value}>#{text}+ |])++-- | Creates a @\<select>@ tag for selecting one option. Example usage:+--+-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing+bulmaSelectFieldList+ :: ( Eq a+ , RenderMessage site FormMessage+ , RenderMessage site msg+ )+ => [(msg, a)] -> Field (HandlerFor site) a+bulmaSelectFieldList = bulmaSelectField . optionsPairs++-- | Creates a @\<select>@ tag for selecting one option. Example usage:+--+-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing+bulmaSelectField+ :: (Eq a, RenderMessage site FormMessage)+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+bulmaSelectField = selectFieldHelper+ (\theId name attrs inside ->+ [whamlet| $newline never+ <div .select>+ <select ##{theId} name=#{name} *{attrs}>+ ^{inside}+ |]) -- outside+ (\_theId _name isSel ->+ [whamlet| $newline never+ <option value=none :isSel:selected>_{MsgSelectNone}+ |]) -- onOpt+ (\_theId _name _attrs value isSel text ->+ [whamlet| $newline never+ <option value=#{value} :isSel:selected>#{text}+ |]) -- inside++-- port from Yesod.Form.Fields+selectFieldHelper+ :: ( Eq a+ , RenderMessage site FormMessage+ )+ => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())+ -> (Text -> Text -> Bool -> WidgetFor site ())+ -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())+ -> HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+selectFieldHelper outside onOpt inside opts' = Field+ { fieldParse = \x _ -> do+ opts <- opts'+ return $ selectParser opts x+ , fieldView = \theId name attrs val isReq -> do+ opts <- olOptions <$> handlerToWidget opts'+ outside theId name attrs $ do+ unless isReq $ onOpt theId name $ notElem (render opts val) $ map+ optionExternalValue+ opts+ forM_ opts $ \opt -> inside+ theId+ name+ ((if isReq then (("required", "required") :) else id) attrs)+ (optionExternalValue opt)+ (render opts val == optionExternalValue opt)+ (optionDisplay opt)+ , fieldEnctype = UrlEncoded+ }+ 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
+ src/Yesod/Form/Bulma/Utils.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}+module Yesod.Form.Bulma.Utils+ ( addStylesheet'+ , addScript'+ )+where++import Data.Text (Text)+import Yesod.Core++addStylesheet'+ :: (MonadWidget m, HandlerSite m ~ site)+ => (site -> Either (Route site) Text)+ -> m ()+addStylesheet' f = do+ y <- getYesod+ addStylesheetEither $ f y++addScript'+ :: (HandlerSite m ~ site, MonadWidget m)+ => (site -> Either (Route site) Text)+ -> m ()+addScript' f = do+ y <- getYesod+ addScriptEither $ f y
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ yesod-form-bulma.cabal view
@@ -0,0 +1,101 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d93f511a61b406fbcb3446ab5cb6827e3f31b12825441e6ffd166219d9c555c4++name: yesod-form-bulma+version: 0.1.0.0+synopsis: support Bulma form for Yesod+description: Please see the README on Github at <https://github.com/waddlaw/yesod-form-bulma#readme>+category: Web, Yesod+homepage: https://github.com/waddlaw/yesod-form-bulma#readme+bug-reports: https://github.com/waddlaw/yesod-form-bulma/issues+author: Shinya Yamaguchi+maintainer: ingroze@gmail.com+copyright: Copyright (c) 2018 Shinya Yamaguchi+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/waddlaw/yesod-form-bulma++library+ exposed-modules:+ Yesod.Form.Bulma+ Yesod.Form.Bulma.Class+ Yesod.Form.Bulma.Fields+ Yesod.Form.Bulma.Utils+ other-modules:+ Paths_yesod_form_bulma+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints -Wtabs+ build-depends:+ base >=4.7 && <5+ , email-validate+ , shakespeare+ , text+ , yesod-core+ , yesod-form+ default-language: Haskell2010++executable example+ main-is: Main.hs+ other-modules:+ Paths_yesod_form_bulma+ hs-source-dirs:+ app/Example+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints -Wtabs+ build-depends:+ base >=4.7 && <5+ , email-validate+ , shakespeare+ , text+ , yesod+ , yesod-core+ , yesod-form+ , yesod-form-bulma+ default-language: Haskell2010++executable showcase+ main-is: Main.hs+ other-modules:+ Paths_yesod_form_bulma+ hs-source-dirs:+ app/Showcase+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints -Wtabs+ build-depends:+ base >=4.7 && <5+ , email-validate+ , shakespeare+ , text+ , yesod+ , yesod-core+ , yesod-form+ , yesod-form-bulma+ default-language: Haskell2010++test-suite yesod-form-bulma-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_yesod_form_bulma+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints -Wtabs -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , email-validate+ , shakespeare+ , text+ , yesod-core+ , yesod-form+ , yesod-form-bulma+ default-language: Haskell2010