lucid-extras (empty) → 0.1.0.0
raw patch · 9 files changed
+471/−0 lines, 9 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, directory, lucid, lucid-extras, text
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- changelog.md +0/−0
- lib/Lucid/Bootstrap3.hs +72/−0
- lib/Lucid/PreEscaped.hs +26/−0
- lib/Lucid/Rdash.hs +280/−0
- lucid-extras.cabal +48/−0
- site-gen/DevelMain.hs +16/−0
- site-gen/Main.hs +6/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 diffusionkinetics++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
+ lib/Lucid/Bootstrap3.hs view
@@ -0,0 +1,72 @@+{-# 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://maxcdn.bootstrapcdn.com/font-awesome/4.7.0/css/font-awesome.min.css",+ rel_ "stylesheet",+ type_ "text/css"]++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
+ lib/Lucid/PreEscaped.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}++module Lucid.PreEscaped where++import Lucid+import Lucid.Base+import qualified Data.Text as T+import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze+import Data.Monoid ((<>))+import qualified Data.ByteString.Lazy as LBS+++preEscaped :: Monad m => T.Text -> HtmlT m ()+preEscaped name =+ HtmlT (return (\_ -> Blaze.fromText name, ()))++preEscapedByteString :: Monad m => LBS.ByteString -> HtmlT m ()+preEscapedByteString name =+ HtmlT (return (\_ -> Blaze.fromLazyByteString name, ()))++++scriptSrc :: Monad m => T.Text -> HtmlT m ()+scriptSrc url =+ HtmlT (return (\_ -> "<script src=\"" <> Blaze.fromHtmlEscapedText url<>"\"></script>", ()))
+ lib/Lucid/Rdash.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE OverloadedStrings #-}++module Lucid.Rdash (+ indexPage+ , mkAlert+ , mkAlerts+ , mkBody+ , mkHead+ , mkHeaderBar+ , mkIndexPage+ , mkMetaBox+ , mkMetaTitle+ , mkPageContent+ , mkPageWrapperOpen+ , mkSidebar+ , mkSidebarFooter+ , mkSidebarItem+ , mkSidebarWrapper+ , mkWidget+ , mkWidgets+ , mkWidgetContent+ , mkWidgetIcon+ , sidebarMain+ , sidebarTitle+ , widget_+ , widgetBody_+ , spacer_+ ) where++import qualified Data.Text as T+import Data.List++import Control.Monad++import Lucid.Bootstrap3++import Lucid hiding (toHtml)+import qualified Lucid (toHtml)++toHtml :: Monad m => T.Text -> HtmlT m ()+toHtml = Lucid.toHtml++rdashCSS, sidebarMain, sidebarTitle :: Monad m => HtmlT m ()++rdashCSS = link_ [rel_ "stylesheet",+ href_ "https://cdn.diffusionkinetics.com/rdash-ui/1.0.1/css/rdash.css"]++ariaHidden, tooltip_ :: Term arg result => arg -> result++ariaHidden = term "aria-hidden"+tooltip_ = term "tooltip"++fa_ :: Monad m => T.Text -> HtmlT m ()+fa_ x = i_ [class_ $ T.unwords ["fa", x]] (return ())++aHash_ :: Monad m => HtmlT m () -> HtmlT m ()+aHash_ = a_ [href_ "#"]++sidebarTitle = span_ "NAVIGATION"+sidebarMain = a_ [href_ "#"] $ do+ "Dashboard"+ span_ [class_ "menu-icon glyphicon glyphicon-transfer"] (return ())++mkPageWrapperOpen :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()+mkPageWrapperOpen sbw cw = div_ [id_ "page-wrapper", class_ "open"] $ sbw >> cw++mkSidebarWrapper :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()+mkSidebarWrapper sb sbf = div_ [id_ "sidebar-wrapper"] $ sb >> sbf++mkSidebar :: (Monad m) => HtmlT m () -> HtmlT m () -> [HtmlT m ()] -> HtmlT m ()+mkSidebar sbm sbt sbl = ul_ [class_ "sidebar"] $ do+ li_ [class_ "sidebar-main",+ id_ "toggle-sidebar",+ onclick_ "$('#page-wrapper').toggleClass('open');"] sbm+ li_ [class_ "sidebar-title"] sbt+ forM_ sbl $ \l -> do+ li_ [class_ "sidebar-list"] l++mkSidebarItem :: (Monad m) => HtmlT m () -> T.Text -> HtmlT m ()+mkSidebarItem s icon = a_ [href_ "#"] $ s >> do+ span_ [class_ $ T.append icon " menu-icon"] (return ())++mkSidebarFooter :: (Monad m) => HtmlT m () -> HtmlT m ()+mkSidebarFooter footerItems = div_ [class_ "sidebar-footer"] footerItems++mkHead :: (Monad m) => T.Text -> HtmlT m ()+mkHead title = head_ $ do+ meta_ [charset_ "UTF-8"]+ meta_ [name_ "viewport", content_ "width=device-width"] -- TODO: add attribute initial-scale=1+ title_ (toHtml title)+ cdnFontAwesome+ cdnCSS+ rdashCSS+ cdnJqueryJS+ cdnBootstrapJS++mkBody :: (Monad m) => HtmlT m () -> HtmlT m ()+mkBody pgw = body_ pgw++mkPageContent :: Monad m => HtmlT m () -> HtmlT m ()+mkPageContent = div_ [id_ "content-wrapper"] . div_ [class_ "page-content"]++mkHeaderBar :: Monad m => [HtmlT m ()] -> HtmlT m ()+mkHeaderBar cols = div_ [class_ "row header"] (rowEven XS cols)++mkUserBox :: Monad m => [HtmlT m ()] -> HtmlT m ()+mkUserBox xs = div_ [class_ "user pull-right"] $ sequence_ xs++mkItemDropdown :: Monad m => T.Text -> HtmlT m () -> HtmlT m ()+mkItemDropdown icon x = div_ [class_ "item dropdown"] $ do+ a_ [ class_ "dropdown-toggle"+ , term "data-toggle" $ "dropdown"+ , href_ "#"] (i_ [class_ icon, ariaHidden "true"] (return ()))+ x++mkDropdownMenu :: Monad m => HtmlT m () -> [[HtmlT m ()]] -> HtmlT m ()+mkDropdownMenu hdr xs = ul_ [class_ "dropdown-menu dropdown-menu-right"] $ sequence_ dividedItems+ where+ mkLi = li_ . (a_ [href_ "#"])+ items = map (map mkLi) xs+ dividedItems = (li_ [class_ "dropdown-header"] hdr) : li_ [class_ "divider"] (return ()) :+ (concat $ intersperse [li_ [class_ "divider"] (return ())] items)++mkIndexPage :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()+mkIndexPage hd body = html_ [lang_ "en"] $ hd >> body++mkMetaTitle :: Monad m => HtmlT m () -> HtmlT m ()+mkMetaTitle = div_ [class_ "page"]++mkMetaBreadcrumbLinks :: Monad m => HtmlT m () -> HtmlT m ()+mkMetaBreadcrumbLinks = div_ [class_ "breadcrumb-links"]++mkMetaBox :: Monad m => [HtmlT m ()] -> HtmlT m ()+mkMetaBox = div_ [class_ "meta pull-left"] . sequence_++mkAlerts :: Monad m => [HtmlT m ()] -> HtmlT m ()+mkAlerts l = mkCol [(XS, 12)] (sequence_ l)++mkAlert :: Monad m => T.Text -> HtmlT m () -> HtmlT m ()+mkAlert alertType = div_ [class_ $ T.unwords ["alert", alertType]]++mkWidgetIcon :: Monad m => T.Text -> T.Text -> HtmlT m ()+mkWidgetIcon color icon =+ div_ [class_$ T.unwords ["widget-icon pull-left", color]] $ i_ [class_ icon] (return ())++mkWidgetContent :: Monad m => HtmlT m () -> HtmlT m () -> HtmlT m ()+mkWidgetContent title comment =+ div_ [class_ "widget-content pull-left"] $ do+ div_ [class_ "title"] title+ div_ [class_ "comment"] comment++mkWidget :: Monad m => HtmlT m () -> HtmlT m () -> HtmlT m ()+mkWidget wIcon wContent =+ widget_ $+ widgetBody_ $+ wIcon >> wContent >> div_ [class_ "clearfix"] (return ())++mkWidgets :: Monad m => [[HtmlT m ()]] -> HtmlT m ()+mkWidgets widgets =+ div_ [class_ "row"] . sequence_ $ intersperse spacer_ (map go widgets)+ where+ go = mapM_ (mkCol [(XS, 12), (MD, 6), (LG, 3)])++spacer_ :: Monad m => HtmlT m ()+spacer_ = div_ [class_ "spacer visible-xs"] $ return ()++widget_ ::Monad m => HtmlT m () -> HtmlT m ()+widget_ = div_ [class_ "widget"]++widgetBody_ ::Monad m => HtmlT m () -> HtmlT m ()+widgetBody_ = div_ [class_ "widget-body"]+++mkTable :: Monad m => HtmlT m () -> [[HtmlT m ()]] -> HtmlT m ()+mkTable title content = mkCol [(LG, 6)] $ do+ div_ [class_ "widget"] $ do+ div_ [class_ "widget-header"] title+ div_ [class_ "widget-body medium no-padding"] $+ div_ [class_ "table-responsive"] $ table_ [class_ "table"] $ tbody_ (mapM_ (tr_ . (mapM_ td_)) content)++mkTables :: Monad m => [HtmlT m ()] -> HtmlT m ()+mkTables = div_ [class_ "row"] . sequence_++indexPage :: (Monad m) => HtmlT m ()+indexPage = do+ mkIndexPage hd body+ where++ -- SIDEBAR+ dashboardSI = mkSidebarItem (toHtml "Dashboard") "fa fa-tachometer"+ tablesSI = mkSidebarItem (toHtml "Tables") "fa fa-table"+ sb = mkSidebar sidebarMain sidebarTitle [dashboardSI, tablesSI]+ footerContent =+ rowEven XS+ [ a_ [href_ "https://github.com/rdash/rdash-barebones", target_ "blank_"] "Github"+ , a_ [href_ "#", target_ "blank_"] "About"+ , a_ [href_ "#"] "Support"]+ sbf = mkSidebarFooter footerContent+ sbw = mkSidebarWrapper sb sbf++ -- Header Bar+ userMenu = mkItemDropdown "fa fa-user-o" $ mkDropdownMenu "Joe Bloggs" [["Profile", "Menu Item"], ["Logout"]]+ bellMenu = mkItemDropdown "fa fa-bell-o" $ mkDropdownMenu "Notifications" [["Server Down!"]]+ userBox = mkUserBox [userMenu, bellMenu]+ metaBox = mkMetaBox [mkMetaTitle "Dashboard", mkMetaBreadcrumbLinks "Home / Dashboard"]+ hb = mkHeaderBar [metaBox, userBox]++ -- Main Content+ alerts = mkAlerts [ mkAlert "alert-success" "Thanks for visiting! Feel free to create pull requests to improve the dashboard!"+ , mkAlert "alert-danger" "Found a bug? Create an issue with as many details as you can."]+ widgets = mkWidgets $+ [[ mkWidget (mkWidgetIcon "green" "fa fa-users") (mkWidgetContent (toHtml "80") (toHtml "Users"))+ , mkWidget (mkWidgetIcon "red" "fa fa-tasks") (mkWidgetContent (toHtml "16") (toHtml "Servers"))+ , mkWidget (mkWidgetIcon "orange" "fa fa-sitemap") (mkWidgetContent (toHtml "225") (toHtml "Documents"))]+ , [mkWidget (mkWidgetIcon "blue" "fa fa-support") (mkWidgetContent (toHtml "62") (toHtml "Tickets"))]]++ tables = mkTables [serversTable, usersTable, extrasTable, loadingTable]++ pcw = mkPageContent (hb >> alerts >> widgets >> tables)++ pgw = mkPageWrapperOpen sbw pcw++ body = mkBody pgw+ hd = mkHead "Dashboard"+++serversTable :: Monad m => HtmlT m ()+serversTable = mkTable lhs d+ where+ checked = span_ [class_ "text-success"] $ i_ [class_ "fa fa-check"] $ return ()+ warn = span_ [class_ "text-danger", tooltip_ "Server Down!"] $ i_ [class_ "fa fa-warning"] $ return ()++ d = [ ["RDVMPC001", "10.0.0.1", checked]+ , ["RDVMPC002", "10.1.0.1", warn]+ , ["RDVMPC003", "10.0.1.1", checked]+ , ["RDVMPC004", "10.1.1.1", checked]+ , ["RDVMPC005", "10.1.1.0", warn]]+ lhs = do+ fa_ "fa-tasks"+ " Servers "+ div_ [class_ "pull-right"] $ aHash_ "Manage"+++usersTable :: Monad m => HtmlT m ()+usersTable = mkTable lhs d+ where+ d = [["1", "Joe Bloggs", "Super Admin", "AZ23045"]]+ lhs = do+ fa_ "fa-users"+ " Users "+ div_ [class_ "pull-right"] $+ input_ [type_ "text", placeholder_ "Search"]++extrasTable :: Monad m => HtmlT m ()+extrasTable = mkCol [(LG, 6)] $ do+ div_ [class_ "widget"] $ do+ div_ [class_ "widget-header"] lhs+ div_ [class_ "widget-body"] . div_ [class_ "widget-content"] . sequence_ $+ div_ [class_ "message"] <$> messages+ where+ lhs = do+ fa_ "fa-plus"+ " Extras "+ div_ [class_ "pull-right"] $ button_ "Button"+ messages =+ [ div_ [class_ "message"] $ span_ [class_ "error"] "Error message!"]++loadingTable :: Monad m => HtmlT m ()+loadingTable = mkCol [(LG, 6)] $ do+ div_ [class_ "widget"] $ do+ div_ [class_ "widget-header"] lhs+ div_ [class_ "widget-body"] loading+ where+ lhs = do+ fa_ "fa-cog fa-spin"+ " Loading Directive "+ div_ [class_ "pull-right"] $ a_ [href_ "#" ] "SpinKit"+ loading = div_ [class_ "loading"] $ do+ div_ [class_ "double-bounce1"] (return ())+ div_ [class_ "double-bounce2"] (return ())
+ lucid-extras.cabal view
@@ -0,0 +1,48 @@+Name: lucid-extras+Version: 0.1.0.0+Synopsis: Generate more HTML with Lucid+Description: Generate more HTML with Lucid - Bootstrap, Rdash and Email.+License: MIT+License-file: LICENSE+Author: Tom Nielsen <tanielsen@gmail.com>+Maintainer: Tom Nielsen <tanielsen@gmail.com>+build-type: Simple+Cabal-Version: >= 1.10+homepage: https://github.com/diffusionkinetics/open/lucid-extras+bug-reports: https://github.com/diffusionkinetics/open/issues+category: Web+Tested-With: GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1+extra-source-files:+ changelog.md++source-repository head+ type: git+ location: https://github.com/diffusionkinetics/open++Library+ ghc-options: -Wall+ hs-source-dirs: lib+ default-language: Haskell2010++ Exposed-modules:+ Lucid.Bootstrap3+ , Lucid.PreEscaped+ , Lucid.Rdash+ Build-depends:+ base >= 4.6 && < 5+ , lucid+ , text+ , blaze-builder+ , bytestring++Test-suite site-gen+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: site-gen+ main-is: Main.hs+ default-language: Haskell2010+ other-modules: DevelMain+ Build-Depends: base >= 4.6 && < 5+ , directory >= 1.2+ , lucid-extras+ , lucid
+ site-gen/DevelMain.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module DevelMain where++import System.Directory++import Lucid.Rdash+import Lucid++html :: Html ()+html = indexPage++update :: IO ()+update = do+ createDirectoryIfMissing True "sample-site"+ renderToFile "sample-site/index.html" html
+ site-gen/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import DevelMain++main :: IO ()+main = update