Separate template into skeleton and pass in current route

src/HL/C/Community.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- | Community page controller.
 
 module HL.C.Community where

src/HL/V/Template.hs

@@ -11,6 +11,7 @@ import HL.V hiding (item)
 import Data.Maybe
 import Data.Monoid
 import Data.Text (pack)
+import Yesod.Static (Static)
 
 -- | Render a template.
 template
@@ -18,49 +19,73 @@ template
   -> Text
   -> ((Route App -> AttributeValue) -> Html)
   -> FromSenza App
-template crumbs ptitle inner url =
+template crumbs ptitle inner =
+  skeleton
+    ptitle
+    (\cur url ->
+       do navigation True cur url
+          container (bread url crumbs)
+          inner url)
+
+-- | Render the basic site skeleton.
+skeleton
+  :: Text
+  -> FromSenza App
+  -> FromSenza App
+skeleton ptitle inner mroute url =
   docTypeHtml
-    (do head []
+    (do head [] headinner
-             (do headtitle (toHtml ptitle)
+        body (maybe []
-                 meta [charset "utf-8"]
+                    (\route -> [class_ (toValue ("page-" <> routeToSlug route))])
-                 meta [httpEquiv "X-UA-Compatible",content "IE edge"]
+                    mroute)
-                 meta [name "viewport",content "width=device-width, initial-scale=1"]
+             bodyinner)
-                 link [rel "stylesheet"
-                      ,type_ "text/css"
-                      ,href "http://fonts.googleapis.com/css?family=Open+Sans"]
-                 styles [StaticR css_bootstrap_min_css
-                        ,StaticR css_haskell_font_css
-                        ,StaticR css_hscolour_css
-                        ,StaticR css_hl_css])
-        body []
-             (do div [class_ "wrap"]
-                     (do navigation (listToMaybe crumbs) url
-                         container (bread url crumbs)
-                         inner url)
-                 div [class_ "footer"]
-                     (div [class_ "container"]
-                          (p [] (do "Copyright © 2014 haskell-lang.org")))
-                 scripts [js_jquery_js
-                         ,js_jquery_cookie_js
-                         ,js_bootstrap_min_js
-                         ,js_warp_reload_js]))
   where
-    scripts =
+    headinner =
-      mapM_ (\route ->
+      do headtitle (toHtml ptitle)
-               script [src (url (StaticR route))]
+         meta [charset "utf-8"]
-                      (return ()))
+         meta [httpEquiv "X-UA-Compatible",content "IE edge"]
-    styles =
+         meta [name "viewport",content "width=device-width, initial-scale=1"]
-      mapM_ (\route ->
+         link [rel "stylesheet"
-               link [rel "stylesheet"
+              ,type_ "text/css"
-                    ,type_ "text/css"
+              ,href "http://fonts.googleapis.com/css?family=Open+Sans"]
-                    ,href (url route)])
+         styles url
+                [StaticR css_bootstrap_min_css
+                ,StaticR css_haskell_font_css
+                ,StaticR css_hscolour_css
+                ,StaticR css_hl_css]
+    bodyinner =
+      do div [class_ "wrap"]
+             (inner mroute url)
+         div [class_ "footer"]
+             (div [class_ "container"]
+                  (p [] (do "Copyright © 2014 haskell-lang.org")))
+         scripts url
+                 [js_jquery_js
+                 ,js_jquery_cookie_js
+                 ,js_bootstrap_min_js
+                 ,js_warp_reload_js]
+
+-- | Make a list of scripts.
+scripts :: (Route App -> AttributeValue) -> [Route Static] -> Senza
+scripts url =
+  mapM_ (\route ->
+           script [src (url (StaticR route))]
+                  (return ()))
+
+-- | Make a list of style links.
+styles :: (a -> AttributeValue) -> [a] -> Senza
+styles url =
+  mapM_ (\route ->
+           link [rel "stylesheet"
+                ,type_ "text/css"
+                ,href (url route)])
 
 -- | Main navigation.
-navigation :: Maybe (Route App) -> FromSenza App
+navigation :: Bool -> FromSenza App
-navigation cur url =
+navigation showBrand mroute url =
   nav [class_ "navbar navbar-default"]
       (div [class_ "container"]
-           (do brand
+           (do when showBrand brand
                items))
   where
     items =
@@ -74,18 +99,23 @@ navigation cur url =
       where item route =
               li theclass
                  (a [href (url route)]
-                    (toHtml (fromRoute route)))
+                    (toHtml (routeToHuman route)))
               where theclass
-                      | Just route == cur = [class_ "active"]
+                      | Just route == mroute = [class_ "active"]
                       | otherwise = []
     brand =
       div [class_ "navbar-header"]
           (do a [class_ "navbar-brand"
                 ,href (url HomeR)]
-                (do span [class_ "logo"]
+                (do logo
-                         "\xe000"
                     "Haskell"))
 
+-- | The logo character in the right font. Style it with an additional
+-- class or wrapper as you wish.
+logo =
+  span [class_ "logo"]
+       "\xe000"
+
 -- | Breadcrumb.
 bread :: (Route App -> AttributeValue) -> [Route App] -> Html
 bread url crumbs =
@@ -94,11 +124,11 @@ bread url crumbs =
             (\route ->
                li []
                   (a [href (url route)]
-                     (toHtml (fromRoute route)))))
+                     (toHtml (routeToHuman route)))))
 
 -- | Generate a human-readable string from a route.
-fromRoute :: Route App -> Text
+routeToHuman :: Route App -> Text
-fromRoute r =
+routeToHuman r =
   case r of
     CommunityR     -> "Community"
     IrcR           -> "IRC"
@@ -113,3 +143,21 @@ fromRoute r =
     ReportR i _    -> "Report " <> pack (show i)
     ReportHomeR i  -> "Report " <> pack (show i)
     WikiHomeR{}    -> "Wiki"
+
+-- | Generate a slug string from a route.
+routeToSlug :: Route App -> Text
+routeToSlug r =
+  case r of
+    CommunityR     -> "community"
+    IrcR           -> "irc"
+    DocumentationR -> "documentation"
+    HomeR          -> "home"
+    ReloadR        -> "reload"
+    MailingListsR  -> "mailing-lists"
+    NewsR          -> "news"
+    StaticR{}      -> "static"
+    DownloadsR     -> "downloads"
+    WikiR t        -> "wiki"
+    ReportR i _    -> "report"
+    ReportHomeR i  -> "report"
+    WikiHomeR{}    -> "wiki"

src/Yesod/Senza.hs

@@ -10,6 +10,7 @@ import Yesod
 
 -- | A senza generator.
 type FromSenza a =
+  Maybe (Route a) ->
   (Route a -> AttributeValue) ->
   Senza
 
@@ -17,5 +18,6 @@ type FromSenza a =
 senza :: MonadHandler m => FromSenza (HandlerSite m) -> m Html
 senza cont =
   do render <- getUrlRender
+     route <- getCurrentRoute
      return
-       (cont (toValue . render))
+       (cont route (toValue . render))

static/css/hl.css

@@ -59,6 +59,9 @@ h2 {
 .navbar-header .navbar-brand .logo {
   margin-right:.5em;
   color:#fff;
+}
+
+.logo {
   font-family:haskell;
   font-weight:400;
 }
@@ -107,6 +110,19 @@ pre {
   font-size:14px;
 }
 
-.span6 {
+.page-news .span6 {
   padding-left:0;
 }
+
+.landing-header {
+  height: 30em;
+  color: #fff;
+  background: #19111f; /* Old browsers */
+  background: -moz-linear-gradient(left, #19111f 0%, #2c1e37 100%); /* FF3.6+ */
+  background: -webkit-gradient(linear, left top, right top, color-stop(0%,#19111f), color-stop(100%,#2c1e37)); /* Chrome,Safari4+ */
+  background: -webkit-linear-gradient(left, #19111f 0%,#2c1e37 100%); /* Chrome10+,Safari5.1+ */
+  background: -o-linear-gradient(left, #19111f 0%,#2c1e37 100%); /* Opera 11.10+ */
+  background: -ms-linear-gradient(left, #19111f 0%,#2c1e37 100%); /* IE10+ */
+  background: linear-gradient(to right, #19111f 0%,#2c1e37 100%); /* W3C */
+  filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#19111f', endColorstr='#2c1e37',GradientType=1 ); /* IE6-9 */
+}