yesod-bootstrap 0.3 → 0.4
raw patch · 6 files changed
+191/−1275 lines, 6 filesdep +bootstrap-typesdep +yesod-elementsdep −MonadRandomdep −conduitdep −conduit-extra
Dependencies added: bootstrap-types, yesod-elements
Dependencies removed: MonadRandom, conduit, conduit-extra, containers, either, email-validate, lens-family-core, lens-family-th, mtl, persistent, time, yaml, yesod-form, yesod-markdown
Files
- src/Yesod/Bootstrap.hs +0/−596
- src/Yesod/Bootstrap/V3.hs +175/−0
- src/Yesod/Form/Generic.hs +0/−90
- src/Yesod/Form/Generic/Bootstrap.hs +0/−540
- src/Yesod/Form/Generic/Bootstrap/Internal.hs +0/−9
- yesod-bootstrap.cabal +16/−40
− src/Yesod/Bootstrap.hs
@@ -1,596 +0,0 @@-module Yesod.Bootstrap where--import Prelude hiding (div)-import Data.Foldable-import Yesod.Core-import Yesod.Core.Widget-import Yesod.Core.Handler-import Data.Text (Text)-import Data.List-import Data.Monoid-import Control.Monad-import Text.Blaze.Html (toHtml)-import qualified Data.Text as Text-import Control.Monad.Writer.Class-import Control.Monad.Writer.Strict-import qualified Data.List as List-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as HA-import Data.Function (on)-import Data.String (IsString(..))-import Data.Char (isDigit)-import Text.Julius (rawJS)--data Context = Success | Info | Warning | Danger | Default | Primary | Link | Error-data Size = ExtraSmall | Small | Medium | Large-data ColSize = ColSize Size Int-data Flow = Block | Inline-data Panel site = Panel - { panelTitle :: (WidgetT site IO ()) - , panelBody :: (WidgetT site IO ())- , panelContext :: Context- }--basicPanel :: Text -> WidgetT site IO () -> Panel site-basicPanel t c = Panel (tw t) c Default--div_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-div_ attrs inner = [whamlet|<div *{mkStrAttrs attrs}>^{inner}|]--span_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-span_ attrs inner = [whamlet|<span *{mkStrAttrs attrs}>^{inner}|]--strong_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-strong_ attrs inner = [whamlet|$newline never-<strong *{mkStrAttrs attrs}>^{inner}|]--em_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-em_ attrs inner = [whamlet|$newline never-<em *{mkStrAttrs attrs}>^{inner}|]--s_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-s_ attrs inner = [whamlet|<s *{mkStrAttrs attrs}>^{inner}|]--nav_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-nav_ attrs inner = [whamlet|<nav *{mkStrAttrs attrs}>^{inner}|]--form_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-form_ attrs inner = [whamlet|<form *{mkStrAttrs attrs}>^{inner}|]--script_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-script_ attrs inner = [whamlet|<script *{mkStrAttrs attrs}>^{inner}|]--label_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-label_ attrs inner = [whamlet|<label *{mkStrAttrs attrs}>^{inner}|]--pre_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-pre_ attrs inner = [whamlet|<pre *{mkStrAttrs attrs}>^{inner}|]--code_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-code_ attrs inner = [whamlet|<code *{mkStrAttrs attrs}>^{inner}|]--input_ :: [(Text,Text)] -> WidgetT site IO ()-input_ attrs = [whamlet|<input *{mkStrAttrs attrs}>|]--hr_ :: [(Text,Text)] -> WidgetT site IO ()-hr_ attrs = [whamlet|<hr *{mkStrAttrs attrs}>|]--br_ :: [(Text,Text)] -> WidgetT site IO ()-br_ attrs = [whamlet|<br *{mkStrAttrs attrs}>|]--img_ :: [(Text,Text)] -> WidgetT site IO ()-img_ attrs = [whamlet|<img *{mkStrAttrs attrs}>|]--textarea_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-textarea_ attrs inner = [whamlet|<textarea *{mkStrAttrs attrs}>^{inner}|]--td_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-td_ attrs inner = [whamlet|<td *{mkStrAttrs attrs}>^{inner}|]--th_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-th_ attrs inner = [whamlet|<th *{mkStrAttrs attrs}>^{inner}|]--table_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-table_ attrs inner = [whamlet|<table *{mkStrAttrs attrs}>^{inner}|]--tbody_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-tbody_ attrs inner = [whamlet|<tbody *{mkStrAttrs attrs}>^{inner}|]--thead_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-thead_ attrs inner = [whamlet|<thead *{mkStrAttrs attrs}>^{inner}|]--tr_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-tr_ attrs inner = [whamlet|<tr *{mkStrAttrs attrs}>^{inner}|]--h1_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h1_ attrs inner = [whamlet|<h1 *{mkStrAttrs attrs}>^{inner}|]--h2_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h2_ attrs inner = [whamlet|<h2 *{mkStrAttrs attrs}>^{inner}|]--h3_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h3_ attrs inner = [whamlet|<h3 *{mkStrAttrs attrs}>^{inner}|]--h4_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h4_ attrs inner = [whamlet|<h4 *{mkStrAttrs attrs}>^{inner}|]--h5_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h5_ attrs inner = [whamlet|<h5 *{mkStrAttrs attrs}>^{inner}|]--h6_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-h6_ attrs inner = [whamlet|<h6 *{mkStrAttrs attrs}>^{inner}|]--p_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-p_ attrs inner = [whamlet|<p *{mkStrAttrs attrs}>^{inner}|]--ul_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-ul_ attrs inner = [whamlet|<ul *{mkStrAttrs attrs}>^{inner}|]--ol_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-ol_ attrs inner = [whamlet|<ol *{mkStrAttrs attrs}>^{inner}|]--li_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-li_ attrs inner = [whamlet|<li *{mkStrAttrs attrs}>^{inner}|]--blockquote_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-blockquote_ attrs inner = [whamlet|<blockquote *{mkStrAttrs attrs}>^{inner}|]--small_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-small_ attrs inner = [whamlet|<small *{mkStrAttrs attrs}>^{inner}|]--i_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-i_ attrs inner = [whamlet|<i *{mkStrAttrs attrs}>^{inner}|]--a_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-a_ attrs inner = [whamlet|$newline never-<a *{mkStrAttrs attrs}>^{inner}|]--audio_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-audio_ attrs inner = [whamlet|<audio *{mkStrAttrs attrs}>^{inner}|]--source_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-source_ attrs inner = [whamlet|<source *{mkStrAttrs attrs}>^{inner}|]--anchor :: Route site -> WidgetT site IO () -> WidgetT site IO ()-anchor route inner = [whamlet|<a href="@{route}">^{inner}|]--anchorEmail :: Text -> WidgetT site IO () -> WidgetT site IO ()-anchorEmail email inner = [whamlet|<a href="mailto:#{email}">^{inner}|]--anchorPhone :: Text -> WidgetT site IO ()-anchorPhone phone = [whamlet|<a href="tel:#{cleanedPhone}">#{phone}|]- where - strippedPhone = Text.filter ((||) <$> isDigit <*> (== '+')) phone- cleanedPhone = case Text.uncons strippedPhone of- Nothing -> Text.empty- Just (c,cs) -> if c == '+' - then strippedPhone- else Text.append "+1" strippedPhone--button_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()-button_ attrs inner = [whamlet|<button *{mkStrAttrs attrs}>^{inner}|]--mkStrAttrs :: [(Text,Text)] -> [(String,String)]-mkStrAttrs = map $ \(a,b) -> (Text.unpack a, Text.unpack b)--row :: WidgetT site IO () -> WidgetT site IO ()-row = div_ [("class","row")]--container :: WidgetT site IO () -> WidgetT site IO ()-container = div_ [("class","container")]--well :: Size -> WidgetT site IO () -> WidgetT site IO ()-well size = div_ [("class","well well-" <> colSizeShortName size)]--col :: [ColSize] -> WidgetT site IO () -> WidgetT site IO ()-col cs = div_ [("class", Text.intercalate " " (map mkAttr cs))]- where mkAttr (ColSize s n) = Text.concat ["col-", colSizeShortName s, "-", Text.pack (show n)]--checkbox :: WidgetT site IO () -> WidgetT site IO ()-checkbox = div_ [("class","checkbox")]--alert :: Context -> WidgetT site IO () -> WidgetT site IO ()-alert ctx = div_ [("class","alert alert-" <> contextName ctx)]--alertHtml :: Context -> Html -> Html-alertHtml ctx inner = H.div H.! HA.class_ (fromString $ Text.unpack $ "alert alert-" <> contextName ctx) $ inner--alertHtmlDismiss :: Context -> Html -> Html-alertHtmlDismiss ctx inner = H.div H.! HA.class_ (fromString $ Text.unpack $ "alert alert-dismissable alert-" <> contextName ctx) $ do- H.button H.! HA.class_ "close" H.! HA.type_ "button" H.! H.dataAttribute "dismiss" "alert" $ H.preEscapedToHtml ("×" :: Text)- inner--caret :: WidgetT site IO ()-caret = span_ [("class","caret")] mempty--glyphicon :: Text -> WidgetT site IO ()-glyphicon s = span_ [("class","glyphicon glyphicon-" <> s)] mempty--glyphiconFeedback :: Text -> WidgetT site IO ()-glyphiconFeedback s = span_ [("class",Text.concat ["glyphicon glyphicon-", s, " form-control-feedback"])] mempty--formGroup :: WidgetT site IO () -> WidgetT site IO ()-formGroup = div_ [("class","form-group")]--formGroupFeedback :: Context -> WidgetT site IO () -> WidgetT site IO ()-formGroupFeedback ctx = div_ [("class",Text.concat ["form-group has-", contextName ctx, " has-feedback"])]--inputGroup :: WidgetT site IO () -> WidgetT site IO ()-inputGroup = div_ [("class","input-group")] --inputGroupAddon :: WidgetT site IO () -> WidgetT site IO ()-inputGroupAddon = span_ [("class","input-group-addon")] --controlLabel :: WidgetT site IO () -> WidgetT site IO ()-controlLabel = label_ [("class","control-label")]--helpBlock :: WidgetT site IO () -> WidgetT site IO ()-helpBlock = div_ [("class","help-block")]--button :: Context -> Size -> WidgetT site IO () -> WidgetT site IO ()-button ctx size inner = do- button_ [("class","btn btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--buttonRaised :: Context -> Size -> WidgetT site IO () -> WidgetT site IO ()-buttonRaised ctx size inner = do- button_ [("class","btn btn-raised btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--buttonRaisedBlock :: Context -> Size -> WidgetT site IO () -> WidgetT site IO ()-buttonRaisedBlock ctx size inner = do- button_ [("class","btn btn-raised btn-block btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--formButtonPost :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-formButtonPost ctx size route inner = do- render <- getUrlRender- form_ [("method","POST"),("action",render route)] $ do- button ctx size inner--formButtonRaisedPost :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-formButtonRaisedPost ctx size route inner = do- render <- getUrlRender- form_ [("method","POST"),("action",render route)] $ do- buttonRaised ctx size inner--formButtonRaisedPostBlock :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-formButtonRaisedPostBlock ctx size route inner = do- render <- getUrlRender- form_ [("method","POST"),("action",render route)] $ do- buttonRaisedBlock ctx size inner--anchorButton :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-anchorButton ctx size route inner = do- render <- getUrlRender- a_ [("href",render route),("class","btn btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--anchorButtonDropdown :: Context -> Size -> WidgetT site IO () -> [(Route site, WidgetT site IO ())] -> WidgetT site IO ()-anchorButtonDropdown ctx size inner xs = div_ [("class","btn-group")] $ do- button_ [ ("type","button")- , ("class","btn btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)- , ("data-toggle","dropdown")- , ("aria-haspopup","true")- , ("aria-expanded","false")- ] inner- ul_ [("class","dropdown-menu")] $ forM_ xs $ \(route,content) -> do- li_ [] $ anchor route content--anchorButtonRaised :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-anchorButtonRaised ctx size route inner = do- render <- getUrlRender- a_ [("href",render route),("class","btn btn-raised btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--anchorButtonBlock :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-anchorButtonBlock ctx size route inner = do- render <- getUrlRender- a_ [("href",render route),("class","btn btn-block btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--anchorButtonRaisedBlock :: Context -> Size -> Route site -> WidgetT site IO () -> WidgetT site IO ()-anchorButtonRaisedBlock ctx size route inner = do- render <- getUrlRender- a_ [("href",render route),("class","btn btn-raised btn-block btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner--label :: Context -> WidgetT site IO () -> WidgetT site IO ()-label ctx = span_ [("class","label label-" <> contextName ctx)]--badge :: WidgetT site IO () -> WidgetT site IO ()-badge = span_ [("class","badge")]--panel :: Panel site -> WidgetT site IO ()-panel (Panel title content ctx) = do- div_ [("class","panel panel-" <> contextName ctx)] $ do- div_ [("class", "panel-heading")] $ do- h4_ [("class","panel-title")] title- div_ [("class","panel-body")] $ do- content--panelAccordion :: [Panel site] -> WidgetT site IO ()-panelAccordion tcs = do - groupId <- newIdent - div_ [("class","panel-group"),("id",groupId),("role","tablist")] $ do- forM_ (zip [1..] tcs) $ \(i,Panel title content ctx) -> do- headingId <- newIdent- panelId <- newIdent- div_ [("class","panel panel-" <> contextName ctx)] $ do- div_ [("class", "panel-heading"),("role","tab"),("id",headingId)] $ do- h4_ [("class","panel-title")] $ do- a_ [("href","#" <> panelId),("role","button"),("data-toggle","collapse"),("data-parent","#" <> groupId)] $ do- title- div_ [("id",panelId),("class","panel-collapse collapse" <> (if i == 1 then " in" else "")),("role","tabpanel"),("aria-labelledby",headingId)] $ do- div_ [("class","panel-body")] $ do- content--textSubmitGroupGetForm :: Route site -> Context -> Size -> Text -> Text -> Text -> WidgetT site IO () -> Bool -> WidgetT site IO ()-textSubmitGroupGetForm route ctx size name placeholder value buttonContent buttonIsLeft = do- render <- getUrlRender- form_ [("method","GET"),("action",render route)] $ do- div_ [("class","form-group")] $ do- div_ [("class","input-group input-group-" <> colSizeShortName size)] - $ mconcat- $ (if buttonIsLeft then reverse else id)- [ input_ [("class","form-control"),("type","text"),("name",name),("placeholder",placeholder),("value",value)]- , span_ [("class","input-group-btn")] $ do- button_ [("class","btn btn-" <> contextName ctx)] buttonContent- ]- --colSizeShortName :: Size -> Text-colSizeShortName s = case s of- ExtraSmall -> "xs" - Small -> "sm" - Medium -> "md" - Large -> "lg" --contextName :: Context -> Text-contextName c = case c of - Success -> "success"- Info -> "info"- Warning -> "warning"- Default -> "default"- Primary -> "primary"- Link -> "link"- Error -> "error"- Danger -> "danger"--data NavbarTheme = NavbarDefault | NavbarInverse | NavbarOtherTheme Text-data NavbarPosition = NavbarStandard | NavbarStaticTop | NavbarFixedTop-data NavbarItem site - = NavbarLink (Route site) (WidgetT site IO ())- | NavbarDropdown (WidgetT site IO ()) [NavbarDropdownItem site]--data NavbarDropdownItem site - = NavbarDropdownLink (Route site) (WidgetT site IO ())- | NavbarDropdownHeader (WidgetT site IO ())- | NavbarDropdownSeparator--navbar :: - NavbarTheme- -> NavbarPosition - -> Route site - -> WidgetT site IO ()- -> [NavbarItem site]- -> [NavbarItem site]- -> WidgetT site IO ()-navbar theme pos headerRoute headerContent items rightItems = do- navbarId <- newIdent- render <- getUrlRender- nav_ [("class","navbar " <> themeClass <> " " <> posClass)] $ do- div_ [("class",containerClass)] $ do- div_ [("class", "navbar-header")] $ do- button_ [ ("class", "navbar-toggle collapsed"),("type","button")- , ("data-toggle", "collapse"), ("aria-expanded", "false")- , ("aria-controls", navbarId),("data-target", "#" <> navbarId)- ] $ do- span_ [("class","sr-only")] $ tw "Toggle Navigation"- replicateM_ 3 $ span_ [("class","icon-bar")] mempty- a_ [("href", render headerRoute),("class","navbar-brand")] headerContent- div_ [("class","navbar-collapse collapse"), ("id", navbarId)] $ do- ul_ [("class","nav navbar-nav")] $ mapM_ navbarItem items- ul_ [("class","nav navbar-nav navbar-right")] $ mapM_ navbarItem rightItems- where - themeClass = case theme of- NavbarDefault -> "navbar-default" - NavbarInverse -> "navbar-inverse" - NavbarOtherTheme t -> "navbar-" <> t- posClass = case pos of- NavbarStandard -> ""- NavbarStaticTop -> "navbar-static-top"- NavbarFixedTop -> "navbar-fixed-top"- containerClass = case pos of- NavbarStandard -> "container-fluid"- NavbarStaticTop -> "container"- NavbarFixedTop -> "container"- -navbarItem :: NavbarItem site -> WidgetT site IO ()-navbarItem item = do- render <- getUrlRender- li_ [] $ case item of- NavbarLink route name -> anchor route name- NavbarDropdown name children -> do- a_ [ ("class","dropdown-toggle"), ("href", "#")- , ("role", "button"), ("data-toggle", "dropdown")- ] name- ul_ [("class","dropdown-menu")] $ mapM_ navbarDropdownItem children--navbarDropdownItem :: NavbarDropdownItem site -> WidgetT site IO ()-navbarDropdownItem item = do- render <- getUrlRender- case item of- NavbarDropdownLink route name -> li_ [] $ anchor route name- NavbarDropdownHeader name -> li_ [("class","dropdown-header")] name- NavbarDropdownSeparator -> li_ [("class","separator"),("role","divider")] mempty---- Stands for text widget-tw :: Text -> WidgetT site IO ()-tw = toWidget . toHtml --preEscapedWidget :: Text -> WidgetT site IO ()-preEscapedWidget = toWidget . H.preEscapedToHtml--data CarouselItem site = CarouselItem- { ciImage :: Route site- , ciLink :: Maybe (Route site)- , ciCaption :: Maybe (WidgetT site IO ())- }--data CarouselIndicators = CarouselIndicatorsOn | CarouselIndicatorsOff- deriving (Eq)-data CarouselControls = CarouselControlsOn | CarouselControlsOff- deriving (Eq)---- Carousel Element -carousel :: CarouselIndicators -> CarouselControls -> [CarouselItem site] -> WidgetT site IO ()-carousel indicators controls items = if length items == 0 then mempty else do- render <- getUrlRender- carouselId <- newIdent- div_ [("class","carousel slide"),("data-ride","carousel"),("id",carouselId)] $ do- when (indicators == CarouselIndicatorsOn) $ do- ol_ [("class","carousel-indicators")] $ do- forM_ (zip [0,1..] itemsActive) $ \(i,(active,_)) -> do- li_ [ ("data-target", "#" <> carouselId)- , ("data-slide-to", Text.pack (show i))- , ("class", if active then "active" else "")- ] mempty- div_ [("class","carousel-inner"), ("role","listbox")] $ do- forM_ itemsActive $ \(active,item) -> do- div_ [("class","item " <> if active then "active" else "")] $ do- wrapWithLink (ciLink item) mempty- img_ [("src",render (ciImage item))]- for_ (ciCaption item) $ \caption -> do- div_ [("class","carousel-caption")] caption- when (controls == CarouselControlsOn) $ do- a_ [ ("class","left carousel-control")- , ("href","#" <> carouselId)- , ("role","button")- , ("data-slide","prev")- ] $ do- glyphicon "chevron-left"- span_ [("class","sr-only")] "Previous"- a_ [ ("class","right carousel-control")- , ("href","#" <> carouselId)- , ("role","button")- , ("data-slide","next")- ] $ do- glyphicon "chevron-right"- span_ [("class","sr-only")] "Next"- where - itemsActive = zip (True : repeat False) items- wrapWithLink :: Maybe (Route site) -> WidgetT site IO () -> WidgetT site IO ()- wrapWithLink mroute w = (\ww -> maybe w ww mroute) $ \route -> do- render <- getUrlRender- a_ [("href", render route),("style","position:absolute;left:0;right:0;width:100%;height:100%;")] w---- Togglable tabs-data ToggleTab site = ToggleSection Text (WidgetT site IO ()) | ToggleDropdown Text [(Text,WidgetT site IO ())]-data ToggleStyle = ToggleStyleTab | ToggleStylePill--togglableTabs :: ToggleStyle -> [ToggleTab site] -> WidgetT site IO ()-togglableTabs s tabs = do- (nav,bodies) <- execWriterT $ forM_ (zip [1..] tabs) $ \(i,tab) -> case tab of- ToggleSection title body -> do -- WriterT (Widget,Widget) over a WidgetT- theId <- lift newIdent- let tabAAttrs = [("role","tab"),("href","#" <> theId),("data-toggle","tab")]- tabLiAttrs = (if isFirst then addClass "active" else id) [("role","presentation")]- paneClasses = (if isFirst then addClass "active" else id)- [("class","tab-pane"),("role","tabpanel"),("id",theId)]- isFirst = (i == (1 :: Int))- tellFst $ li_ tabLiAttrs $ a_ tabAAttrs $ tw title- tellSnd $ div_ paneClasses body- _ -> error "figure this out"- div_ [] $ do- let styleText = case s of- ToggleStyleTab -> "nav-tabs"- ToggleStylePill -> "nav-pills"- ul_ [("class","nav " <> styleText),("role","tablist")] nav- div_ [("class","tab-content")] bodies- where - tellFst a = tell (a,mempty)- tellSnd b = tell (mempty,b)- addClass :: Text -> [(Text,Text)] -> [(Text,Text)]- addClass klass attrs = case List.lookup "class" attrs of- Nothing -> ("class",klass) : attrs- Just c -> ("class",c <> " " <> klass) : List.deleteBy ((==) `on` fst) ("class","") attrs--radioButtons :: Context -> Text -> [(Text, WidgetT site IO ())] -> WidgetT site IO ()-radioButtons ctx name xs = do- div_ [("class","btn-group"),("data-toggle","buttons")] $ do- forM_ (zip trueThenFalse xs) $ \(isFirst, (theValue,w)) -> do- label_ [("class", "btn btn-" <> contextName ctx <> if isFirst then " active" else "")] $ do- input_ $ (if isFirst then [("checked","checked")] else [])- ++ [("type","radio"),("name",name),("value",theValue),("autocomplete","off")] - " "- w--listGroupLinked :: [(Route site,WidgetT site IO ())] -> WidgetT site IO ()-listGroupLinked items = do- render <- getUrlRender- div_ [("class","list-group")] $ forM_ items $ \(route,name) -> do- a_ [("href",render route),("class","list-group-item")] name--breadcrumbsList :: [(Route site,WidgetT site IO ())] -> WidgetT site IO ()-breadcrumbsList allCrumbs = case reverse allCrumbs of- (_,lastCrumbWidget):crumbs -> ol_ [("class","breadcrumb")] $ do- forM_ (reverse crumbs) $ \(route,name) -> li_ [] $ anchor route name- li_ [("class","active")] lastCrumbWidget- [] -> mempty--popover :: WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ()-popover title popup inner = do- innerId <- newIdent- popupWrapId <- newIdent- titleWrapId <- newIdent- a_ [("href","javascript://"),("id",innerId)] inner- div_ [("id",popupWrapId),("style","display:none;")] $ do- popup- div_ [("id",titleWrapId),("style","display:none;")] $ do- title- toWidget [julius|-$().ready(function(){- $('##{rawJS innerId}').popover(- { html: true- , trigger: 'focus'- , content: function() { return $('##{rawJS popupWrapId}').html(); }- , title: function() { return $('##{rawJS titleWrapId}').html(); }- }- );-});-|]--popoverClickable :: WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ()-popoverClickable title popup inner = do- containerId <- newIdent- innerId <- newIdent- popupWrapId <- newIdent- titleWrapId <- newIdent- span_ [("id",containerId)] $ do- a_ [("href","javascript://"),("id",innerId)] inner- div_ [("id",popupWrapId),("style","display:none;")] $ do- popup- div_ [("id",titleWrapId),("style","display:none;")] $ do- title- toWidget [julius|-$().ready(function(){- $('##{rawJS innerId}').popover(- { html: true- , trigger: 'manual'- , content: function() { return $('##{rawJS popupWrapId}').html(); }- , title: function() { return $('##{rawJS titleWrapId}').html(); }- }- );- var hidePopover#{rawJS innerId} = function () {- $('##{rawJS innerId}').popover('hide');- $(document).off("click keypress", hidePopover#{rawJS innerId} );- };- $('##{rawJS innerId}').focusin(function() {- $('##{rawJS innerId}').popover('show');- });- $('##{rawJS innerId}').on("shown.bs.popover", function() {- $('##{rawJS containerId}').find(".popover").on("click keypress", function(e) {- e.stopPropagation();- });- $(document).on("click keypress", hidePopover#{rawJS innerId});- });-});-|]--trueThenFalse :: [Bool]-trueThenFalse = True : repeat False-
+ src/Yesod/Bootstrap/V3.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Yesod.Bootstrap.V3 where++import Yesod.Core+import Yesod.Elements+import Text.Blaze (toValue)+import Data.Text (Text)+import Data.Monoid+import Control.Monad+import Data.Foldable (Foldable(fold))+import Data.Functor.Identity (Identity(..))+import Text.Julius (rawJS)+import qualified Data.List as List+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as HA+import qualified Bootstrap.V3 as B+import qualified Data.Text as Text++container :: Monad m => WidgetT site m a -> WidgetT site m a+container = div_ [class_ "container"]++row :: Monad m => WidgetT site m a -> WidgetT site m a+row = div_ [class_ "row"]++column :: Monad m => B.Column -> WidgetT site m a -> WidgetT site m a+column c = div_ [class_ (toValue (B.columnClass c))]++button :: Monad m => B.Context -> B.Size -> WidgetT site m a -> WidgetT site m a+button ctx size = button_+ [ class_ $ toValue $ B.buttonClass ctx size ]++formButtonPost :: B.Context -> B.Size -> Route site -> WidgetT site IO a -> WidgetT site IO a+formButtonPost = formButton "POST"++formButtonGet :: B.Context -> B.Size -> Route site -> WidgetT site IO a -> WidgetT site IO a+formButtonGet = formButton "GET"++formButton :: H.AttributeValue -> B.Context -> B.Size -> Route site -> WidgetT site IO a -> WidgetT site IO a+formButton method ctx size route inner = do+ urlRender <- getUrlRender+ form_ [method_ method, action_ (toValue (urlRender route))] $ do+ button ctx size inner++glyphicon :: Monad m => Text -> WidgetT site m ()+glyphicon s = span_ [class_ $ toValue $ "glyphicon glyphicon-" <> s] mempty++label :: B.Context -> WidgetT site IO () -> WidgetT site IO ()+label ctx = span_ [class_ $ toValue $ "label label-" <> B.contextClass ctx]++alert :: B.Context -> WidgetT site IO () -> WidgetT site IO ()+alert ctx = div_ [class_ $ toValue $ "alert alert-" <> B.contextClass ctx]++alertHtml :: B.Context -> Html -> Html+alertHtml ctx inner =+ H.div H.! HA.class_ (toValue $ "alert alert-" <> B.contextClass ctx) $ inner++anchor :: Foldable t => t H.Attribute -> Route site -> WidgetT site IO a -> WidgetT site IO a+anchor attrs route inner = do+ urlRender <- getUrlRender+ a_ (Identity $ (href_ $ toValue $ urlRender route) <> fold attrs) inner++anchorButton :: Foldable t => B.Context -> B.Size -> t H.Attribute -> Route site -> WidgetT site IO () -> WidgetT site IO ()+anchorButton ctx size attrs = anchor+ (Identity $ (class_ $ toValue $ B.buttonClass ctx size) <> fold attrs)++navbar ::+ B.NavbarTheme+ -> B.NavbarPosition+ -> Route site+ -> WidgetT site IO ()+ -> [B.NavbarItem (Route site) (WidgetT site IO ())]+ -> [B.NavbarItem (Route site) (WidgetT site IO ())]+ -> WidgetT site IO ()+navbar theme pos headerRoute headerContent items rightItems = do+ navbarId <- newIdent+ render <- getUrlRender+ nav_ [class_ $ toValue $ Text.concat+ [ "navbar "+ , B.navbarThemeClass theme+ , " "+ , B.navbarPositionClass pos+ ]+ ] $ do+ div_ [class_ containerClass] $ do+ div_ [class_ "navbar-header"] $ do+ button_ [ class_ "navbar-toggle collapsed"+ , type_ "button"+ , H.dataAttribute "toggle" "collapse"+ , H.dataAttribute "target" (toValue $ "#" <> navbarId)+ , H.customAttribute "aria-expanded" "false"+ , H.customAttribute "aria-controls" (toValue navbarId)+ ] $ do+ span_ [class_ "sr-only"] "Toggle Navigation"+ replicateM_ 3 $ span_ [class_ "icon-bar"] mempty+ a_ [href_ $ toValue $ render headerRoute, class_ "navbar-brand"] headerContent+ div_ [class_ "navbar-collapse collapse", id_ $ toValue navbarId] $ do+ ul_ [class_ "nav navbar-nav"] $ mapM_ navbarItem items+ ul_ [class_ "nav navbar-nav navbar-right"] $ mapM_ navbarItem rightItems+ where+ containerClass = case pos of+ B.NavbarPositionStandard -> "container-fluid"+ B.NavbarPositionStatic -> "container"+ B.NavbarPositionFixed -> "container"++navbarItem :: B.NavbarItem (Route site) (WidgetT site IO ()) -> WidgetT site IO ()+navbarItem item = do+ render <- getUrlRender+ li_ [] $ case item of+ B.NavbarItemLink route name -> anchor [] route name+ B.NavbarItemDropdown name children -> do+ a_ [ class_ "dropdown-toggle"+ , href_ "#"+ , H.customAttribute "role" "button"+ , H.dataAttribute "toggle" "dropdown"+ ] name+ ul_ [class_ "dropdown-menu"] $ mapM_ navbarDropdownItem children++navbarDropdownItem :: B.NavbarDropdownItem (Route site) (WidgetT site IO ()) -> WidgetT site IO ()+navbarDropdownItem item = do+ render <- getUrlRender+ case item of+ B.NavbarDropdownItemLink route name -> li_ [] $ anchor [] route name+ B.NavbarDropdownItemHeader name -> li_ [class_ "dropdown-header"] name+ B.NavbarDropdownItemSeparator -> li_ [class_ "separator", H.customAttribute "role" "divider"] mempty++breadcrumbsList :: [(Route site,WidgetT site IO ())] -> WidgetT site IO ()+breadcrumbsList allCrumbs = case List.reverse allCrumbs of+ (_,lastCrumbWidget):crumbs -> ol_ [class_ "breadcrumb"] $ do+ forM_ (List.reverse crumbs) $ \(route,name) -> li_ [] $ anchor [] route name+ li_ [class_ "active"] lastCrumbWidget+ [] -> mempty++popoverClickable ::+ WidgetT site IO () -- ^ Title+ -> WidgetT site IO () -- ^ Popup+ -> WidgetT site IO () -- ^ Inner Content+ -> WidgetT site IO ()+popoverClickable title popup inner = do+ containerId <- newIdent+ innerId <- newIdent+ popupWrapId <- newIdent+ titleWrapId <- newIdent+ span_ [id_ $ toValue containerId] $ do+ a_ [href_ "javascript://", id_ $ toValue innerId] inner+ div_ [id_ $ toValue popupWrapId, style_' "display:none;"] $ do+ popup+ div_ [id_ $ toValue titleWrapId, style_' "display:none;"] $ do+ title+ toWidget [julius|+$().ready(function(){+ $('##{rawJS innerId}').popover(+ { html: true+ , trigger: 'manual'+ , content: function() { return $('##{rawJS popupWrapId}').html(); }+ , title: function() { return $('##{rawJS titleWrapId}').html(); }+ }+ );+ var hidePopover#{rawJS innerId} = function () {+ $('##{rawJS innerId}').popover('hide');+ $(document).off("click keypress", hidePopover#{rawJS innerId} );+ };+ $('##{rawJS innerId}').focusin(function() {+ $('##{rawJS innerId}').popover('show');+ });+ $('##{rawJS innerId}').on("shown.bs.popover", function() {+ $('##{rawJS containerId}').find(".popover").on("click keypress", function(e) {+ e.stopPropagation();+ });+ $(document).on("click keypress", hidePopover#{rawJS innerId});+ });+});+|]
− src/Yesod/Form/Generic.hs
@@ -1,90 +0,0 @@-module Yesod.Form.Generic where--import Yesod.Core-import Yesod.Form-import Data.Text (Text)-import Control.Monad-import Control.Applicative-import Data.Monoid-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)-import Data.Maybe-import qualified Data.Map as Map--newtype GForm w m a = GForm - { unGForm :: (HandlerSite m, [Text])- -> Maybe (Env, FileEnv)- -> Ints- -> m (FormResult a, w, Ints, Enctype)- }--instance Monad m => Functor (GForm w m) where- fmap f (GForm a) = GForm $ \x y z -> liftM go $ a x y z- where go (w, x, y, z) = (fmap f w, x, y, z)--instance (Monad m, Monoid w) => Applicative (GForm w m) where- pure x = GForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)- (GForm f) <*> (GForm g) = GForm $ \mr env ints -> do- (a, b, ints', c) <- f mr env ints- (x, y, ints'', z) <- g mr env ints'- return (a <*> x, b <> y, ints'', c <> z)--instance Monoid w => MonadTrans (GForm w) where- lift f = GForm $ \_ _ ints -> do- x <- f- return (FormSuccess x, mempty, ints, mempty)--mghelper :: MonadHandler m- => Enctype - -> ([Text] -> [FileInfo] -> m (FormResult a)) -- ^ parser- -> (Text -> [Text] -> FormResult a -> w) -- ^ function for building output, needs name and vals- -> MForm m (FormResult a, w)-mghelper enctype parse buildOutput = do- tell enctype- mp <- askParams- name <- newFormIdent - case mp of- Nothing -> return (FormMissing, buildOutput name [] FormMissing)- Just p -> do- mfs <- askFiles- let mvals = fromMaybe [] $ Map.lookup name p- files = fromMaybe [] $ mfs >>= Map.lookup name- res <- lift $ parse mvals files- return (res, buildOutput name mvals res)--ghelper :: MonadHandler m- => Enctype - -> ([Text] -> [FileInfo] -> m (FormResult a)) -- ^ parser- -> (Text -> [Text] -> FormResult a -> w) -- ^ function for building output, needs name- -> GForm w m a-ghelper a b c = formToGForm (mghelper a b c)--formToGForm :: (HandlerSite m ~ site, Monad m)- => MForm m (FormResult a, w)- -> GForm w m a-formToGForm form = GForm $ \(site, langs) env ints -> do- ((a, w), ints', enc) <- runRWST form (env, site, langs) ints- return (a, w, ints', enc)--gFormToForm :: (Monad m, HandlerSite m ~ site)- => GForm w m a- -> MForm m (FormResult a, w)-gFormToForm (GForm gform) = do- ints <- get- (env, site, langs) <- ask- (a, w, ints', enc) <- lift $ gform (site, langs) env ints- put ints'- tell enc- return (a, w)--gFormToFormCsrf :: (Monad m, HandlerSite m ~ site)- => GForm (WidgetT site IO ()) m a- -> Html- -> MForm m (FormResult a, (WidgetT site IO ()))-gFormToFormCsrf g h = do- (r,w) <- gFormToForm g- return (r,toWidget h <> w)--monoidToGForm :: Monad m => w -> GForm w m ()-monoidToGForm w = formToGForm $ return (FormSuccess (), w)--
− src/Yesod/Form/Generic/Bootstrap.hs
@@ -1,540 +0,0 @@-module Yesod.Form.Generic.Bootstrap where--import Yesod.Form-import Yesod.Form.Generic-import Yesod.Core-import Yesod.Core.Widget-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Text.Email.Validate as Email-import qualified Data.Yaml as Yaml-import Text.Shakespeare.I18N (RenderMessage)-import Yesod.Bootstrap-import Data.Maybe-import Text.Read (readMaybe)-import Control.Applicative-import Control.Monad-import Data.Time (Day)-import Data.Monoid-import Lens.Family-import Lens.Family2.TH-import Text.Julius (rawJS)-import Debug.Trace-import Data.Either.Combinators-import Data.String-import Control.Monad.Random-import Database.Persist (PersistField)-import Database.Persist.Sql (PersistFieldSql)-import Yesod.Markdown-import Data.Conduit-import Data.Conduit.Lazy (lazyConsume)-import qualified Data.Conduit.Text as Conduit-import Text.Blaze.Html (preEscapedToHtml)-import Yesod.Form.Generic.Bootstrap.Internal --class YesodMarkdownRender site where- markdownRenderSubsite :: Route MarkdownRender -> Route site--instance YesodSubDispatch MarkdownRender (HandlerT master IO) where- yesodSubDispatch = $(mkYesodSubDispatch resourcesMarkdownRender)--getMarkdownRender :: a -> MarkdownRender-getMarkdownRender = const MarkdownRender--postMarkdownRenderR :: HandlerT MarkdownRender (HandlerT site IO) Html-postMarkdownRenderR = do- ts <- lazyConsume $ rawRequestBody =$= Conduit.decode Conduit.utf8- let mkd = Markdown $ Text.concat ts- return $ markdownToHtmlCustom mkd--markdownToHtmlCustom :: Markdown -> Html-markdownToHtmlCustom m@(Markdown t)- | m == mempty = preEscapedToHtml ("<span class=\"text-muted\">Preview</span>" :: Text)- | otherwise = case markdownToHtml (Markdown (Text.filter (/= '\r') t)) of- Left _ -> preEscapedToHtml ("<span class=\"text-muted\">Could not render</span>" :: Text)- Right a -> a--data FieldConfig m a = FieldConfig- { _fcLabel :: Maybe (WidgetT (HandlerSite m) IO ())- , _fcPlaceholder :: Maybe (SomeMessage (HandlerSite m))- , _fcTooltip :: Maybe (SomeMessage (HandlerSite m))- , _fcId :: Maybe Text- , _fcName :: Maybe Text- , _fcValue :: Maybe a- , _fcReadonly :: Bool- , _fcValidate :: a -> m (Either (SomeMessage (HandlerSite m)) a)- }-makeLenses ''FieldConfig--instance Monad m => Monoid (FieldConfig m a) where- mempty = FieldConfig Nothing Nothing Nothing Nothing Nothing Nothing False (return . Right)- FieldConfig a1 b1 c1 d1 e1 f1 r1 v1 `mappend` FieldConfig a2 b2 c2 d2 e2 f2 r2 v2 = - FieldConfig (a2 <|> a1) (b2 <|> b1) (c2 <|> c1) (d2 <|> d1) (e2 <|> e1) (f2 <|> f1) (r1 || r2) - $ \a -> do- e <- v1 a- case e of - Left err -> return $ Left err- Right a' -> return $ Right a'--instance Monad m => IsString (FieldConfig m a) where- fromString s = mempty {_fcLabel = Just (toWidget (toHtml s))}--render :: Monad m => GForm (WidgetT site IO ()) m a -> Html -> MForm m (FormResult a, WidgetT site IO ())-render g h = gFormToForm (monoidToGForm (toWidget h) *> g)--greenOnSuccess :: Bool-greenOnSuccess = False--simple :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => Text -- ^ input type- -> ([Text] -> [FileInfo] -> m (FormResult a))- -> (a -> Text)- -> FieldConfig m a -> GForm (WidgetT site IO ()) m a-simple typ parser display config = ghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> - let baseInput = labelAndInput (fromMaybe mempty $ _fcLabel config) name typ (_fcReadonly config)- in case res of- FormMissing -> formGroup $ baseInput $ maybe "" display (_fcValue config)- FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- baseInput (display a)- FormFailure errs -> formGroupFeedback Error $ do- baseInput $ fromMaybe "" $ listToMaybe vals- glyphiconFeedback "remove"- helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs--class YesodTypeahead site where- routeTypeaheadJs :: site -> Route site- routeTypeaheadCss :: site -> Route site---- The result from the route is expected to be a JSON array. Also, the route--- is expected to respond to a POST request with the body as the text we are--- searching for.-typeahead :: (YesodTypeahead site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => Route site -> FieldConfig m Text -> GForm (WidgetT site IO ()) m Text-typeahead route config = ghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> do- inputId <- newIdent- let baseAttrs = [("id",inputId),("class","form-control"),("name",name),("type","text")]- addReadonly = if _fcReadonly config then (("readonly","readonly"):) else id- attrs = addReadonly baseAttrs- baseInput t = do- whenMaybe (_fcLabel config) controlLabel- input_ attrs- yesod <- getYesod- addStylesheet $ routeTypeaheadCss yesod- addScript $ routeTypeaheadJs yesod- typeaheadJs route inputId - case res of- FormMissing -> formGroup $ baseInput $ maybe "" display (_fcValue config)- FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- baseInput (display a)- FormFailure errs -> formGroupFeedback Error $ do- baseInput $ fromMaybe "" $ listToMaybe vals- glyphiconFeedback "remove"- helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs- where parser = (gparseHelper (return . Right) Nothing)- display = id--typeaheadJs :: Route site -> Text -> WidgetT site IO ()-typeaheadJs route inputId = toWidget [julius|-$().ready(function(){- var serNum = $('##{rawJS inputId}');- serNum.typeahead({- source: function (query, process) {- return $.post('@{route}', query, function(data){- return process(data);- });- },- items: 'all',- minLength: 2,- afterSelect: function(ser) { - // serNum.closest('form').submit();- }- }); -});-|]--simpleCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => Text -- ^ input type- -> ([Text] -> [FileInfo] -> m (FormResult (Maybe a)))- -> (Maybe a -> Text)- -> FieldConfig m (Maybe a) -> GForm (WidgetT site IO ()) m (Maybe a)-simpleCheck typ parser display config = formToGForm $ do- (checkId, inputId) <- (,) <$> newIdent <*> newIdent- (checkRes, checkWidget) <- mghelper UrlEncoded (fullValidate (gparseHelper (return . checkBoxParser) (Just False)) (return . Right)) $ \name _vals res -> do- val <- decipherCheckRes res- input_ $ boolAttrs [("checked",val)] ++ [("id",checkId),("name",name),("value","yes"),("type","checkbox")]- (inputRes, inputWidget) <- mghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> do- isChecked <- decipherCheckRes checkRes- let baseInputGroup val = inputGroup $ do- inputGroupAddon checkWidget- input_ $ boolAttrs [("readonly", not isChecked)] ++ - [("id",inputId),("class","form-control"),("type",typ),("name",name),("value",val)]- case (isChecked,res) of- (_, FormMissing) -> formGroup $ do- maybe mempty controlLabel (_fcLabel config)- baseInputGroup $ maybe "" display (_fcValue config)- (_, FormSuccess a) -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- maybe mempty controlLabel (_fcLabel config)- baseInputGroup (display a)- (False,FormFailure errs) -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- maybe mempty controlLabel (_fcLabel config)- baseInputGroup ""- (True,FormFailure errs) -> formGroupFeedback Error $ do- maybe mempty controlLabel (_fcLabel config)- baseInputGroup $ fromMaybe "" $ listToMaybe vals- glyphiconFeedback "remove"- helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs- return ( checkRes `bindFormResult` \b -> if traceShowId b then inputRes else pure Nothing- , inputWidget <> simpleCheckJs checkId inputId )- where decipherCheckRes r = case r of- FormSuccess b -> return b- FormFailure _ -> permissionDenied "Bootstrap checkbox field somehow failed" - FormMissing -> return $ isJust $ join (_fcValue config)--select :: (RenderMessage site FormMessage, Eq a)- => HandlerT site IO (OptionList a) - -> FieldConfig (HandlerT site IO) a - -> GForm (WidgetT site IO ()) (HandlerT site IO) a-select opts c = ghelper UrlEncoded - (fieldParseToGParse parse) $ \name vals res -> do- theId <- newIdent - let r = case res of- FormSuccess a -> Right a- FormMissing -> case _fcValue c of- Nothing -> Left ""- Just a -> Right a- FormFailure _ -> Left ""- formGroup $ do- whenMaybe (_fcLabel c) controlLabel- view theId name [("class","form-control")] r True- where Field parse view enctype = selectField opts--newtype UploadFilename = UploadFilename { getUploadFilename :: Text }- deriving (PersistField, PersistFieldSql, Show, Read)--class YesodUpload site where- uploadDirectory :: site -> String- uploadRoute :: UploadFilename -> Route site--yaml :: (FromJSON a, ToJSON a, HandlerSite m ~ site, MonadHandler m, RenderMessage site FormMessage) - => a -> FieldConfig m a -> GForm (WidgetT site IO ()) m a-yaml example c = ghelper UrlEncoded (fullValidate (gparseHelper (return . mapLeft (SomeMessage . Text.pack) . Yaml.decodeEither . Text.encodeUtf8) Nothing) (_fcValidate c))- $ \name vals res -> do- preId <- newIdent- buttonId <- newIdent- yamlJs preId buttonId- let thePre = pre_ [("id",preId),("style","display:none")] $ tw $ yamlEncodeText example- baseAttrs = [("class","form-control"),("name",name),("rows","5")]- addReadonly = if (_fcReadonly c) then (("readonly","readonly"):) else id- attrs = addReadonly baseAttrs- baseInput t = do- whenMaybe (_fcLabel c) controlLabel- textarea_ attrs (tw t)- case res of- FormMissing -> formGroup $ do- baseInput $ maybe "" yamlEncodeText (_fcValue c)- button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"- thePre- FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- baseInput (yamlEncodeText a)- button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"- thePre- FormFailure errs -> formGroupFeedback Error $ do- baseInput $ fromMaybe "" $ listToMaybe vals- glyphiconFeedback "remove"- helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs- button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"- thePre- where yamlEncodeText = Text.decodeUtf8 . Yaml.encode- -yamlJs :: Text -> Text -> WidgetT site IO ()-yamlJs preId buttonId = toWidget [julius|-$().ready(function(){- var showing = false;- var button = $('##{rawJS buttonId}');- var pre = $('##{rawJS preId}');- button.click(function(){- showing = !showing;- pre.slideToggle();- if(showing)- button.text("Hide Example");- else- button.text("Show Example");- });-});-|]--markdown :: (YesodMarkdownRender site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m Markdown -> GForm (WidgetT site IO ()) m Markdown-markdown c = ghelper UrlEncoded (fullValidate (gparseHelper (return . Right . Markdown . Text.filter (/= '\r')) Nothing) (_fcValidate c)) - $ \name vals res -> do- wellId <- newIdent- inputId <- newIdent- render <- getUrlRender- markdownJs wellId inputId (render $ markdownRenderSubsite MarkdownRenderR)- let theWell = helpBlock . div_ [("class","well well-sm"),("id",wellId)] . toWidget- baseAttrs = [("class","form-control"),("name",name),("rows","5"),("id",inputId)]- addReadonly = if (_fcReadonly c) then (("readonly","readonly"):) else id- attrs = addReadonly baseAttrs- baseInput t = do- whenMaybe (_fcLabel c) controlLabel- textarea_ attrs (tw t)- case res of- FormMissing -> formGroup $ do- baseInput $ maybe "" unMarkdown (_fcValue c)- theWell $ markdownToHtmlCustom $ fromMaybe mempty (_fcValue c)- FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do- baseInput (unMarkdown a)- theWell $ markdownToHtmlCustom a- FormFailure errs -> formGroupFeedback Error $ do- baseInput $ fromMaybe "" $ listToMaybe vals- glyphiconFeedback "remove"- theWell $ markdownToHtmlCustom mempty- helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs--markdownJs :: Text -> Text -> Text -> WidgetT site IO ()-markdownJs wellId inputId url = toWidget [julius|-$().ready(function(){- var hasChanged = false;- var input = $('##{rawJS inputId}');- var well = $('##{rawJS wellId}');- var runUpdate = function(){- if(!hasChanged) return;- $.ajax({ type: "POST"- , url: "#{rawJS url}"- , data: input.val()- , dataType: 'html'- , success: function(data) {- well.html(data);- hasChanged = false;- } - });- };- setInterval(runUpdate, 1000);- input.on('input',function(){- hasChanged = true;- });-});-|]--file :: (YesodUpload site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m UploadFilename -> GForm (WidgetT site IO ()) m UploadFilename-file c = ghelper Multipart- (fullValidate (fileParseHelper (_fcValue c)) (_fcValidate c)) $ \name _vals res -> do- formGroup $ do- whenMaybe (_fcLabel c) controlLabel- input_ [("type","file"),("name",name)] - case res of- FormFailure errs -> helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs- _ -> mempty- whenMaybe (_fcValue c) $ \filename -> do- render <- getUrlRender- helpBlock $ img_ [("width","140"),("src",render $ uploadRoute filename),("class","img-thumbnail")]- - -fileParseHelper :: (YesodUpload site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => (Maybe UploadFilename) -- ^ If this is Just, then the field is not required.- -> [Text] -> [FileInfo] -> m (FormResult UploadFilename)-fileParseHelper mdef _ [] = return $ case mdef of- Nothing -> FormMissing- Just a -> FormSuccess a-fileParseHelper _ _ (x:_) = do- app <- getYesod- name <- liftIO $ moveIt (uploadDirectory app) x- return (FormSuccess name)--moveIt :: String -> FileInfo -> IO UploadFilename-moveIt dir fi = do- baseFilename <- randomUpperConsonantText 24- let ext = snd $ Text.breakOn "." (fileName fi)- fullFileName = baseFilename <> ext- fileMove fi $ Text.unpack $ mempty - <> Text.pack dir - <> "/" - <> fullFileName- return $ UploadFilename fullFileName--randomUpperConsonantText :: Int -> IO Text-randomUpperConsonantText n = id- $ fmap Text.pack - $ evalRandIO - $ replicateM n- $ uniform allConsonants- where allConsonants = filter (not . isVowel) ['A'..'Z']--isVowel :: Char -> Bool-isVowel c = case c of- 'a' -> True- 'e' -> True- 'i' -> True- 'o' -> True- 'u' -> True- 'A' -> True- 'E' -> True- 'I' -> True- 'O' -> True- 'U' -> True- _ -> False--simpleCheckJs :: Text -> Text -> WidgetT site IO ()-simpleCheckJs checkId inputId = toWidget [julius|-$().ready(function(){- $('##{rawJS checkId}').change(function(){- var enabled = this.checked;- var input = $('##{rawJS inputId}');- if (!enabled) input.val("");- input.prop('readonly',!enabled);- });-});-|]--bindFormResult :: FormResult a -> (a -> FormResult b) -> FormResult b-bindFormResult ra f = case ra of- FormFailure errs -> FormFailure errs- FormMissing -> FormMissing- FormSuccess a -> f a--ifA :: Applicative f => f Bool -> f a -> f a -> f a-ifA t c a = g <$> t <*> c <*> a where g b x y = if b then x else y--boolAttrs :: [(Text,Bool)] -> [(Text,Text)]-boolAttrs = map (\t -> (fst t, fst t)) . filter snd--labelAndInput :: WidgetT site IO () -> Text -> Text -> Bool -> Text -> WidgetT site IO ()-labelAndInput labelWidget name typ readonly val = do- let baseAttrs = [("class","form-control"),("type",typ),("name",name),("value",val)]- addReadonly = if readonly then (("readonly","readonly"):) else id- controlLabel labelWidget- input_ (addReadonly $ baseAttrs)--fieldParseToGParse :: (MonadHandler m)- => ([Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))- -> [Text] -> [FileInfo] -> m (FormResult a)-fieldParseToGParse parse ts fs = do- e <- parse ts fs - case e of- Left msg -> do - langs <- languages- site <- getYesod- return $ FormFailure [renderMessage site langs msg]- Right Nothing -> return FormMissing- Right (Just a) -> return (FormSuccess a)--fullValidate :: MonadHandler m - => ([Text] -> [FileInfo] -> m (FormResult a)) - -> (a -> m (Either (SomeMessage (HandlerSite m)) a))- -> [Text] -> [FileInfo] -> m (FormResult a)-fullValidate parser validate ts fs = do- res <- parser ts fs - case res of- FormSuccess a -> do- e <- validate a- case e of- Left msg -> do- langs <- languages- site <- getYesod- return $ FormFailure [renderMessage site langs msg]- Right b -> return $ FormSuccess b- _ -> return res--text :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m Text -> GForm (WidgetT site IO ()) m Text-text = simple "text" - (gparseHelper (return . Right) Nothing) id--textOpt :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m (Maybe Text) -> GForm (WidgetT site IO ()) m (Maybe Text)-textOpt = simple "text" (gparseHelper (return . Right . Just) (Just Nothing)) (fromMaybe "")--textCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m (Maybe Text) -> GForm (WidgetT site IO ()) m (Maybe Text)-textCheck = simpleCheck "text" - (gparseHelper (return . Right . Just) Nothing) - (fromMaybe "")--int :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m Int -> GForm (WidgetT site IO ()) m Int-int = simple "number" (gparseHelper (return . parseInt) Nothing) (Text.pack . show)--intCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m (Maybe Int) -> GForm (WidgetT site IO ()) m (Maybe Int)-intCheck = simpleCheck "number" - (gparseHelper (return . fmap Just . parseInt) Nothing) - (maybe "" (Text.pack . show))--day :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m Day -> GForm (WidgetT site IO ()) m Day-day = simple "date" - (gparseHelper (return . mapLeft SomeMessage . parseDate . Text.unpack) Nothing) - (Text.pack . show)--dayCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m (Maybe Day) -> GForm (WidgetT site IO ()) m (Maybe Day)-dayCheck = simpleCheck "date" - (gparseHelper (return . fmap Just . mapLeft SomeMessage . parseDate . Text.unpack) Nothing)- (maybe "" (Text.pack . show))--- --- email :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)--- => WidgetT site IO () -> Maybe Text -> GForm (WidgetT site IO ()) m Text--- email = simple "email" (gparseHelper textEmailValidate Nothing) id--- -bool :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => FieldConfig m Bool -> GForm (WidgetT site IO ()) m Bool-bool config = ghelper UrlEncoded (fullValidate (gparseHelper (return . checkBoxParser) (Just False)) (_fcValidate config)) $ \name _vals res -> do- val <- case res of- FormSuccess b -> return b- FormFailure _ -> permissionDenied "Bootstrap checkbox field somehow failed" -- should be impossible- FormMissing -> return $ fromMaybe False (_fcValue config)- let applyVal = if val then (("checked","checked"):) else id- checkbox $ label_ [] $ do - input_ $ applyVal [("name",name),("value","yes"),("type","checkbox")]- fromMaybe mempty $ _fcLabel config--checkBoxParser :: Text -> Either (SomeMessage site) Bool-checkBoxParser x = case x of- "yes" -> Right True - "on" -> Right True- _ -> Right False--textEmailValidate :: Text -> Either FormMessage Text-textEmailValidate t = if Email.isValid (Text.encodeUtf8 t)- then Right t- else Left (MsgInvalidEmail t)--submit :: Monad m => Context -> Text -> GForm (WidgetT site IO ()) m ()-submit ctx t = monoidToGForm $ button_ [("type","submit"),("class","btn btn-" <> contextName ctx)] $ tw t--parseInt :: RenderMessage site FormMessage => Text -> Either (SomeMessage site) Int-parseInt t = case readMaybe (Text.unpack t) of- Nothing -> Left (SomeMessage (MsgInvalidInteger t))- Just n -> Right n- --- specialRight :: a -> Either Text a --- specialRight = Right--gparseHelper :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)- => (Text -> m (Either (SomeMessage site) a))- -> (Maybe a) -- ^ If this is Just, then the field is not required.- -> [Text] -> [FileInfo] -> m (FormResult a)-gparseHelper _ mdef [] _ = return $ case mdef of- Nothing -> FormMissing- Just a -> FormSuccess a-gparseHelper _ mdef ("":_) _ = case mdef of- Nothing -> do- langs <- languages- site <- getYesod- return $ FormFailure [renderMessage site langs MsgValueRequired]- Just a -> return (FormSuccess a)-gparseHelper f _ (x:_) _ = do- e <- f x- case e of- Left msg -> do- langs <- languages- site <- getYesod- return $ FormFailure [renderMessage site langs msg]- Right a -> return (FormSuccess a)--whenMaybe :: Applicative m => Maybe a -> (a -> m ()) -> m ()-whenMaybe Nothing _ = pure ()-whenMaybe (Just a) f = f a-
− src/Yesod/Form/Generic/Bootstrap/Internal.hs
@@ -1,9 +0,0 @@-module Yesod.Form.Generic.Bootstrap.Internal where--import Yesod.Core--data MarkdownRender = MarkdownRender-mkYesodSubData "MarkdownRender" [parseRoutes|-/markdown/render MarkdownRenderR POST-|]-
yesod-bootstrap.cabal view
@@ -1,53 +1,29 @@--- Initial yesod-bootstrap.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: yesod-bootstrap-version: 0.3+version: 0.4 synopsis: Bootstrap widgets for yesod--- description: +description: Lots of bootstrap widgets for yesod license: MIT license-file: LICENSE+homepage: https://github.com/andrewthad/haskell-bootstrap author: Andrew Martin maintainer: andrew.thaddeus@gmail.com--- copyright: +copyright: Andrew Martin 2016 category: Web build-type: Simple--- extra-source-files: cabal-version: >=1.10 library- exposed-modules: Yesod.Bootstrap- , Yesod.Form.Generic- , Yesod.Form.Generic.Bootstrap- , Yesod.Form.Generic.Bootstrap.Internal- default-extensions: QuasiQuotes- , GeneralizedNewtypeDeriving- , TypeFamilies- , MultiParamTypeClasses- , FlexibleContexts- , FlexibleInstances- , OverloadedStrings- , TemplateHaskell- build-depends: base >=4.7 && <5.0- , yesod-core- , yesod-form- , containers- , transformers- , shakespeare- , text- , blaze-html- , time- , email-validate- , lens-family-th- , lens-family-core- , mtl- , either- , MonadRandom- , persistent- , yesod-markdown >= 0.10.0- , conduit- , conduit-extra- , blaze-markup- , yaml+ exposed-modules:+ Yesod.Bootstrap.V3+ build-depends:+ base >=4.7 && <5.0+ , yesod-core+ , yesod-elements+ , bootstrap-types+ , transformers+ , shakespeare+ , text+ , blaze-html+ , blaze-markup hs-source-dirs: src default-language: Haskell2010