Bootstrap3.hs

{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-}
module Lucid.Bootstrap3 where

import Lucid
import Lucid.PreEscaped (scriptSrc)
import Data.Char (toLower)
import qualified Data.Text as T
infixr 0 $:

($:) :: (Monad m, ToHtml a) => (HtmlT m () -> HtmlT m ()) -> a -> HtmlT m ()
f $: x = f (toHtml x)

data Breakpoint = XS | SM | MD | LG deriving Show

mkColClass :: [(Breakpoint, Int)] -> T.Text
mkColClass = T.unwords . map go
  where
    go (bp, spans) = T.concat [ "col-", T.pack $ map toLower (show bp)
                              , "-", T.pack $ show spans]

mkCol :: Monad m => [(Breakpoint, Int)] -> HtmlT m () -> HtmlT m ()
mkCol bps = div_ [class_ (mkColClass bps)]

rowEven :: Monad m => Breakpoint -> [HtmlT m ()] -> HtmlT m ()
rowEven bp cols = mapM_ (div_ [class_ (mkColClass [(bp, spans)])]) cols
  where ncols = length cols
        spans = 12 `div` ncols

cdnCSS, cdnThemeCSS, cdnJqueryJS, cdnBootstrapJS, cdnFontAwesome ::  Monad m => HtmlT m ()
cdnCSS
  = link_ [rel_ "stylesheet",
           href_ "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"]

cdnThemeCSS
  = link_ [rel_ "stylesheet",
           href_ "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap-theme.min.css"]

cdnJqueryJS
  =  scriptSrc "https://ajax.googleapis.com/ajax/libs/jquery/1.12.4/jquery.min.js"

cdnBootstrapJS
  =  scriptSrc "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js"

cdnFontAwesome
  =  link_ [href_ "https://use.fontawesome.com/releases/v5.0.13/css/all.css",
            rel_ "stylesheet",
            type_ "text/css", crossorigin_ "anonymous"]

data NavAttribute = Inverse | Transparent | FixedTop | NavBarClass T.Text deriving Eq

navAttributeToClass :: NavAttribute -> T.Text
navAttributeToClass Inverse = "navbar-inverse"
navAttributeToClass Transparent = "navbar-transparent"
navAttributeToClass FixedTop = "navbar-fixed-top"
navAttributeToClass (NavBarClass c)= c

navBar :: Monad m => [NavAttribute] -> HtmlT m () -> [HtmlT m ()] -> HtmlT m ()
navBar attrs brand items = do
  let cls = T.unwords $ "navbar" : map navAttributeToClass attrs
  nav_ [class_ cls, role_ "navigation"] $ div_ [class_ "container"] $ do
    div_ [class_ "navbar-header"] $ do
      button_ [id_ "menu-toggle",
               type_ "button",
               class_ "navbar-toggle"] $ do
        span_ [class_ "sr-only"] "Toggle navigation"
        span_ [class_ "icon-bar bar1"] ""
        span_ [class_ "icon-bar bar2"] ""
        span_ [class_ "icon-bar bar3"] ""
      with brand [class_ "navbar-brand"]
    div_ [class_ "collapse navbar-collapse"] $ do
      ul_ [class_ "nav navbar-nav navbar-right"] $ do
        mapM_ li_ items

loginForm :: Monad m => T.Text -> Maybe (HtmlT m ()) -> HtmlT m ()
loginForm url mwarn = form_ [class_ "form-signin", method_ "post", action_ url] $ do
  h2_ [class_ "form-signin-heading"] $ "Please sign in"
  case mwarn of
    Nothing -> return ()
    Just warn -> warn
  label_ [for_ "inputEmail", class_ "sr-only"] "Email address"
  input_ [type_ "email", id_ "inputEmail", name_ "inputEmail", class_ "form-control", placeholder_ "Email address", required_ "", autofocus_]
  label_ [for_ "inputPassword", class_ "sr-only"] "Password"
  input_ [type_ "password", id_ "inputPassword", name_ "inputPassword", class_ "form-control", placeholder_ "Password", required_ ""]
  div_ [class_ "checkbox"] $
    label_ $ do
      input_ [type_ "checkbox", value_ "remember-me"]
      "Remember me"
  button_ [class_ "btn btn-lg btn-primary btn-block", type_ "submit"] "Sign in"