module Yesod.Bootstrap where
import Prelude hiding (div)
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(..))
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|<strong *{mkStrAttrs attrs}>^{inner}|]
em_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()
em_ attrs inner = [whamlet|<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}|]
input_ :: [(Text,Text)] -> WidgetT site IO ()
input_ attrs = [whamlet|<input *{mkStrAttrs attrs}>|]
hr_ :: [(Text,Text)] -> WidgetT site IO ()
hr_ attrs = [whamlet|<hr *{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}|]
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}|]
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|<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}|]
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")]
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
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
anchorButton :: Context -> Route site -> WidgetT site IO () -> WidgetT site IO ()
anchorButton ctx route inner = do
render <- getUrlRender
a_ [("href",render route),("class","btn btn-" <> contextName ctx)] 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")]
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
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
tw :: Text -> WidgetT site IO ()
tw = toWidget . toHtml
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
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
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