Auto-reload support

config/routes

@@ -1,2 +1,8 @@
 /static StaticR Static appStatic
+/theme ThemeR GET
 / HomeR GET
+/reload ReloadR GET
+/downloads DownloadsR GET
+/community CommunityR GET
+/documentation DocumentationR GET
+/news NewsR GET

hl.cabal

@@ -15,7 +15,8 @@ executable hl
   hs-source-dirs:    src/
   ghc-options:       -Wall -O2
   main-is:           Main.hs
-  build-depends:     warp >= 2.0.3.2,
+  build-depends:     conduit >= 1.0.15,
+                     warp >= 2.0.3.2,
                      wai-logger == 2.1.1,
                      fast-logger == 2.1.5,
                      yesod-core == 1.2.6.4,
@@ -25,4 +26,5 @@ executable hl
                      yesod-static == 1.2.2.1,
                      base >= 4 && < 5,
                      foreign-store == 0.0,
-                     blaze == 0.0.2
+                     blaze == 0.0.2,
+                     css == 0.1

src/Blaze/Prelude.hs

@@ -1,9 +1,13 @@
 -- | A prelude for when using blaze-html.
 
 module Blaze.Prelude
-  (module Blaze
-  ,module Prelude)
+  (module Blaze.Attributes
+  ,module Blaze.Senza
+  ,module Prelude
+  ,docTypeHtml)
   where
 
+import Blaze.Attributes hiding (style,span)
+import Blaze.Senza
 import Blaze
-import Prelude hiding (head,div,max,span,id)
+import Prelude hiding (head,div,max,span,id,min)

src/Blaze/Senza.hs

@@ -0,0 +1,67 @@
+-- | Blaze without attribute operators
+
+module Blaze.Senza where
+
+import           Blaze (with,Html)
+import qualified Blaze.Elements as E
+import           Prelude ()
+
+meta :: [E.Attribute] -> Html
+meta = with E.meta
+
+headtitle :: Html -> Html
+headtitle = E.title
+
+style :: [E.Attribute] -> Html
+style = with E.link
+
+script :: [E.Attribute] -> Html -> Html
+script = with E.script
+
+div :: [E.Attribute] -> Html -> Html
+div = with E.div
+
+span :: [E.Attribute] -> Html -> Html
+span = with E.span
+
+link :: [E.Attribute] -> Html
+link = with E.link
+
+a :: [E.Attribute] -> Html -> Html
+a = with E.a
+
+h1 :: [E.Attribute] -> Html -> Html
+h1 = with E.h1
+
+h2 :: [E.Attribute] -> Html -> Html
+h2 = with E.h2
+
+h3 :: [E.Attribute] -> Html -> Html
+h3 = with E.h3
+
+h4 :: [E.Attribute] -> Html -> Html
+h4 = with E.h4
+
+h5 :: [E.Attribute] -> Html -> Html
+h5 = with E.h5
+
+head :: [E.Attribute] -> Html -> Html
+head = with E.head
+
+body :: [E.Attribute] -> Html -> Html
+body = with E.body
+
+nav :: [E.Attribute] -> Html -> Html
+nav = with E.nav
+
+ul :: [E.Attribute] -> Html -> Html
+ul = with E.ul
+
+ol :: [E.Attribute] -> Html -> Html
+ol = with E.ol
+
+li :: [E.Attribute] -> Html -> Html
+li = with E.li
+
+p :: [E.Attribute] -> Html -> Html
+p = with E.p

src/DevelMain.hs

@@ -15,15 +15,19 @@ import Yesod.Static
 main :: IO (Store (IORef Application))
 main =
   do s <- static "static"
-     app <- toWaiApp (App s)
+     c <- newChan
+     app <- toWaiApp (App s c)
      ref <- newIORef app
      tid <- forkIO
               (runSettings
                  (defaultSettings { settingsPort = 1990 })
-                 (\req -> do handler <- readIORef ref
+                 (\req ->
+                    do handler <- readIORef ref
                        handler req))
      _ <- newStore tid
-     newStore ref
+     ref <- newStore ref
+     newStore c
+     return ref
 
 -- | Update the server, start it if not running.
 update :: IO (Store (IORef Application))
@@ -33,7 +37,9 @@ update =
        Nothing -> main
        Just store ->
          do ref <- readStore store
+            c <- readStore (Store 2)
+            writeChan c ()
             s <- static "static"
-            app <- toWaiApp (App s)
+            app <- toWaiApp (App s c)
             writeIORef ref app
             return store

src/HL/Controller/Community.hs

@@ -0,0 +1,10 @@
+-- | Community page controller.
+
+module HL.Controller.Community where
+
+import HL.Foundation
+import HL.View.Community
+
+-- | Community controller.
+getCommunityR :: Handler Html
+getCommunityR = blaze communityV

src/HL/Controller/Documentation.hs

@@ -0,0 +1,10 @@
+-- | Documentation page controller.
+
+module HL.Controller.Documentation where
+
+import HL.Foundation
+import HL.View.Documentation
+
+-- | Documentation controller.
+getDocumentationR :: Handler Html
+getDocumentationR = blaze documentationV

src/HL/Controller/Downloads.hs

@@ -0,0 +1,10 @@
+-- | Downloads page controller.
+
+module HL.Controller.Downloads where
+
+import HL.Foundation
+import HL.View.Downloads
+
+-- | Downloads controller.
+getDownloadsR :: Handler Html
+getDownloadsR = blaze downloadsV

src/HL/Controller/News.hs

@@ -0,0 +1,10 @@
+-- | News page controller.
+
+module HL.Controller.News where
+
+import HL.Foundation
+import HL.View.News
+
+-- | News controller.
+getNewsR :: Handler Html
+getNewsR = blaze newsV

src/HL/Controller/Reload.hs

@@ -1,10 +1,14 @@
 -- | Reload poller.
 
-module HL.C.Reload where
+module HL.Controller.Reload where
 
 import HL.Foundation
-import HL.V.Home
+import HL.View.Home
 
--- | Home controller.
-getHomeR :: Handler Html
-getHomeR =
+import Control.Concurrent.Chan.Lifted
+
+-- | Reload controller.
+getReloadR :: Handler ()
+getReloadR =
+  do reload <- fmap appReload getYesod
+     dupChan reload >>= readChan

src/HL/Controller/Theme.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | CSS theme.
+
+module HL.Controller.Theme where
+
+import HL.Foundation
+import HL.View.Theme
+
+import Data.Conduit
+import Data.Conduit.List as CL
+import Data.Text.Lazy (Text)
+import Language.CSS
+
+-- | Generate CSS from Clay theme.
+getThemeR :: Handler TypedContent
+getThemeR =
+  respondSource "text/css"
+                (sendChunk (renderCSS (runCSS theme)))

src/HL/Dispatch.hs

@@ -6,6 +6,12 @@
 module HL.Dispatch () where
 
 import HL.Controller.Home
+import HL.Controller.Reload
+import HL.Controller.Theme
+import HL.Controller.Downloads
+import HL.Controller.Community
+import HL.Controller.Documentation
+import HL.Controller.News
 import HL.Foundation
 
 mkYesodDispatch "App" resourcesApp

src/HL/Foundation.hs

@@ -16,6 +16,7 @@ module HL.Foundation
 
 import HL.Static
 
+import Control.Concurrent.Chan
 import Network.Wai.Logger
 import System.Log.FastLogger
 import Yesod
@@ -26,6 +27,7 @@ import Yesod.Static
 -- | Application state.
 data App = App
   { appStatic :: Static
+  , appReload :: Chan ()
   }
 
 -- | Generate boilerplate.

src/HL/View/Community.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Community page view.
+
+module HL.View.Community where
+
+import HL.Foundation
+import HL.View.Template
+
+import Blaze.Prelude
+import Blaze.Bootstrap
+
+-- | Community view.
+communityV :: Blaze App
+communityV =
+  template
+    [(CommunityR,"Community")]
+    (\_ ->
+       container
+         (row
+            (span12
+               (do h1 [] "Community"
+                   p []
+                     "The Haskell community is spread out online across several mediums \
+                     \and around the world!"
+                   ul []
+                      (do li [] "The Haskell-Cafe mailing list"
+                          li [] "StackOverflow"
+                          li [] "G+"
+                          li [] "Reddit"
+                          li [] "The Wiki")))))

src/HL/View/Documentation.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Documentation page view.
+
+module HL.View.Documentation where
+
+import HL.Foundation
+import HL.View.Template
+
+import Blaze.Prelude
+import Blaze.Bootstrap
+
+-- | Documentation view.
+documentationV :: Blaze App
+documentationV =
+  template
+    [(DocumentationR,"Documentation")]
+    (\_ ->
+       container
+         (row
+            (span12
+               (do h1 [] "Documentation"
+                   h2 [] "Online Resources"
+                   p [] "Some stuff here."))))

src/HL/View/Downloads.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Downloads page view.
+
+module HL.View.Downloads where
+
+import HL.Foundation
+import HL.View.Template
+
+import Blaze.Prelude
+import Blaze.Bootstrap
+
+-- | Downloads view.
+downloadsV :: Blaze App
+downloadsV =
+  template
+    [(DownloadsR,"Downloads")]
+    (\_ ->
+       container
+         (row
+            (span12
+               (do h1 [] "Downloads"
+                   p []
+                     "The Haskell Platform was a comprehensive, robust development \
+                     \environment for programming in Haskell. For new users the \
+                     \platform makes it trivial to get up and running with a full \
+                     \Haskell development environment. For experienced developers, \
+                     \the platform provides a comprehensive, standard base for \
+                     \commercial and open source Haskell development that maximises \
+                     \interoperability and stability of your code."))))

src/HL/View/Home.hs

@@ -8,17 +8,31 @@ module HL.View.Home where
 import HL.Foundation
 import HL.View.Template
 
--- import Blaze.Elements as E
--- import Blaze.Prelude
+import Blaze.Prelude
 import Blaze.Bootstrap
 
 -- | Home view.
 homeV :: Blaze App
 homeV =
   template
+    [(HomeR,"Home")]
     (\_ ->
        container
          (row
             (span12
-               (do h1 "hi"
-                   with a [class_ "btn btn-primary"] "Hello?"))))
+               (do h1 [] "Haskell"
+                   p []
+                     "The Haskell Platform was a comprehensive, robust development \
+                     \environment for programming in Haskell. For new users the \
+                     \platform makes it trivial to get up and running with a full \
+                     \Haskell development environment. For experienced developers, \
+                     \the platform provides a comprehensive, standard base for \
+                     \commercial and open source Haskell development that maximises \
+                     \interoperability and stability of your code."
+                   p []
+                     "Lorem ipsum dolor sit amet, consectetur adipiscing elit. \
+                     \Suspendisse vitae aliquet lorem. Praesent sed egestas risus. \
+                     \Cras a neque eget dui pharetra feugiat sed vel erat. Vivamus \
+                     \magna sapien, congue quis tellus eu, imperdiet sagittis dolor. \
+                     \Praesent dolor magna, suscipit in posuere nec, faucibus eu \
+                     \velit."))))

src/HL/View/News.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | News page view.
+
+module HL.View.News where
+
+import HL.Foundation
+import HL.View.Template
+
+import Blaze.Prelude
+import Blaze.Bootstrap
+
+-- | News view.
+newsV :: Blaze App
+newsV =
+  template
+    [(NewsR,"News")]
+    (\_ ->
+       container
+         (row
+            (span12
+               (do h1 [] "News"
+                   p []
+                     "Insert news here."))))

src/HL/View/Template.hs

@@ -7,47 +7,87 @@ module HL.View.Template where
 
 import           HL.Foundation
 
-import Blaze.Elements as E
-import Blaze.Attributes as A
-import Blaze.Prelude
+import           Blaze (AttributeValue)
+import qualified Blaze.Attributes as A
 import           Blaze.Bootstrap
+import qualified Blaze.Elements as E
+import           Blaze.Prelude
+import           Blaze.Senza
+import           Control.Monad
+import           Data.Text (Text)
 
 -- | Render a template.
-template :: Blaze App -- ^ Content.
+template
+  :: [(Route App,Text)]
+  -> ((Route App -> AttributeValue) -> Html)
   -> Blaze App
-template inner url =
+template crumbs inner cur url =
   docTypeHtml
-    (do head
-          (do E.title "Haskell"
-              with meta [charset "utf-8"]
-              with meta [httpEquiv "X-UA-Compatible",A.content "IE edge"]
-              with meta [name "viewport",A.content "width=device-width, initial-scale=1"]
-              styles [css_bootstrap_min_css
-                     ,css_bootstrap_theme_min_css])
-        body
-          (do with div
-                   [class_ "wrap"]
-                   (do inner url
-                       with div
-                            [class_ "footer"]
-                            (container
-                               (row
-                                  (span12
-                                     (with div
-                                           [class_ "muted credit"]
-                                           "Footer")))))
+    (do head []
+             (do headtitle "Haskell"
+                 meta [charset "utf-8"]
+                 meta [httpEquiv "X-UA-Compatible",content "IE edge"]
+                 meta [name "viewport",content "width=device-width, initial-scale=1"]
+                 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
+                        ,ThemeR])
+        body []
+             (do div [class_ "wrap"]
+                     (do navigation cur 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_bootstrap_min_js
+                         ,js_warp_reload_js]))
   where
     scripts =
       mapM_ (\route ->
-               with script
-                    [src (url (StaticR route))]
+               script [src (url (StaticR route))]
                       (return ()))
     styles =
       mapM_ (\route ->
-               with link
-                    [rel "stylesheet"
+               link [rel "stylesheet"
                     ,type_ "text/css"
-                    ,href (url (StaticR route))])
+                    ,href (url route)])
+
+-- | Main navigation.
+navigation :: Blaze App
+navigation cur url =
+  nav [class_ "navbar navbar-default"]
+      (div [class_ "container"]
+           (do brand
+               items))
+  where items =
+          div [class_ "collapse navbar-collapse"]
+              (ul [class_ "nav navbar-nav"]
+                  (mapM_ (uncurry item)
+                         [(DownloadsR,"Downloads")
+                         ,(CommunityR,"Community")
+                         ,(DocumentationR,"Documentation")
+                         ,(NewsR,"News")]))
+          where item route title = li theclass (a [href (url route)] title)
+                  where theclass
+                          | Just route == cur = [class_ "active"]
+                          | otherwise = []
+        brand =
+          div [class_ "navbar-header"]
+               (do a [class_ "navbar-brand"
+                     ,href (url HomeR)]
+                     (do span [class_ "logo"]
+                              "\xe000"
+                         "Haskell"))
+
+-- | Breadcrumb.
+bread :: (t -> E.AttributeValue) -> [(t,Text)] -> Html
+bread url crumbs =
+  ol [class_ "breadcrumb"]
+     (forM_ crumbs
+            (\(route,title) -> li [] (a [href (url route)]
+                                        (toHtml title))))

src/HL/View/Theme.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | CSS theme.
+
+module HL.View.Theme
+  (theme)
+  where
+
+import Language.CSS
+
+theme =
+  do main
+     containers
+     breadcrumb
+     navbar
+     footer
+
+main =
+  do rule "html"
+          (do position "relative"
+              minHeight "100%")
+     rule "body"
+           (do background "#ffffff"
+               padding "0"
+               margin "0 0 4em 0"
+               fontFamily "Open Sans"
+               fontSize "13px")
+     rule ".wrap"
+          (do background "#ffffff"
+              paddingBottom "2em")
+     rule "p"
+          (do fontSize "15px")
+     rule "h1"
+          (do marginTop "0.1em"
+              marginLeft "0"
+              textIndent "-0.05em")
+     rule "h2"
+          (do color "#6e618d")
+
+containers =
+  rule ".container > .row"
+       (do marginLeft "0"
+           marginRight "0"
+           maxWidth "60em")
+
+navbar =
+  do rule ".navbar"
+          (do backgroundColor "#352f44"
+              borderRadius "0"
+              border "0"
+              marginBottom "0.5em")
+     rule ".navbar-header .navbar-brand"
+          (do color "#fff"
+              fontSize "inherit"
+              fontWeight "bold"
+              rule ".logo"
+                   (do marginRight "0.5em"
+                       fontFamily "haskell"
+                       fontWeight "normal"))
+     rule ".navbar-header .navbar-brand:hover"
+          (color "#fff")
+     rule ".navbar-default .navbar-nav > .active > a"
+          (do theme
+              backgroundColor "#312b3f"
+              borderBottom "0.3em solid #465787")
+     rule ".navbar-default .navbar-nav > .active > a:hover"
+          (do theme
+              backgroundColor "#312b3f")
+     rule ".navbar-default .navbar-nav > li > a"
+          theme
+  where theme =
+          do color "#ffffff !important"
+             backgroundColor "inherit"
+
+breadcrumb =
+  rule ".breadcrumb"
+       (do marginLeft "0"
+           paddingLeft "0"
+           backgroundColor "inherit"
+           marginBottom "0")
+
+footer =
+  rule ".footer"
+       (do backgroundColor "#323232"
+           color "#999999"
+           position "absolute"
+           bottom "0"
+           width "100%"
+           height "4em"
+           lineHeight "2em"
+           rule "p"
+                (do marginTop "1em"
+                    fontSize "13px"))

src/Main.hs

@@ -5,10 +5,12 @@ module Main where
 import HL.Foundation
 import HL.Dispatch ()
 
+import Control.Concurrent.Chan
 import Yesod.Static
 
 -- | Main entry point.
 main :: IO ()
 main =
   do s <- static "static"
-     warp 1990 (App s)
+     c <- newChan
+     warp 1990 (App s c)

src/Yesod/Blaze.hs

@@ -2,17 +2,23 @@
 
 module Yesod.Blaze
   (module Yesod.Blaze
-  ,module Yesod
-  ,module Blaze)
+  ,module Yesod)
   where
 
 import Yesod hiding (object)
 import Blaze
 
-type Blaze a = (Route a -> AttributeValue) -> Html
+-- | A blaze generator.
+type Blaze a =
+  Maybe (Route a) ->
+  (Route a -> AttributeValue) ->
+  Html
 
 -- | Output some blaze, passes a URL renderer to the continuation.
-blaze :: MonadHandler m => ((Route (HandlerSite m) -> AttributeValue) -> b) -> m b
-blaze f =
+blaze :: MonadHandler m => Blaze (HandlerSite m) -> m Html
+blaze cont =
   do render <- getUrlRender
-     return (f (toValue . render))
+     current <- getCurrentRoute
+     return
+       (cont current
+             (toValue . render))

static/css/fonts/Haskell.dev.svg

@@ -0,0 +1,15 @@
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" >
+<svg xmlns="http://www.w3.org/2000/svg">
+<metadata>
+This is a custom SVG font generated by IcoMoon.
+<iconset grid="16"></iconset>
+</metadata>
+<defs>
+<font id="Haskell" horiz-adv-x="512" >
+<font-face units-per-em="512" ascent="480" descent="-32" />
+<missing-glyph horiz-adv-x="512" />
+<glyph class="hidden" unicode="&#xf000;" d="M0,480L 512 -32L0 -32 z" horiz-adv-x="0" />
+<glyph unicode="&#xe000;" d="M 0-31.643 L 170.431,224.002 L 0,479.646 L 127.822,479.646 L 298.254,224.002 L 127.822-31.643 L 0-31.643 Z M 0-31.643 M 170.431-31.643 L 340.864,224.002 L 170.431,479.646 L 298.254,479.646 L 639.112-31.643 L 511.289-31.643 L 404.775,128.131 L 298.254-31.643 L 170.431-31.643 Z M 170.431-31.643 M 582.305,117.481 L 525.499,202.693 L 724.331,202.699 L 724.331,117.481 L 582.305,117.481 Z M 582.305,117.481 M 497.092,245.304 L 440.279,330.516 L 724.331,330.522 L 724.331,245.304 L 497.092,245.304 Z M 497.092,245.304 " horiz-adv-x="724.329" data-tags="Haskell-Logo" />
+<glyph unicode="&#x20;" horiz-adv-x="256" />
+</font></defs></svg>

static/css/fonts/Haskell.svg

@@ -0,0 +1,15 @@
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" >
+<svg xmlns="http://www.w3.org/2000/svg">
+<metadata>
+This is a custom SVG font generated by IcoMoon.
+<iconset grid="16"></iconset>
+</metadata>
+<defs>
+<font id="Haskell" horiz-adv-x="512" >
+<font-face units-per-em="512" ascent="480" descent="-32" />
+<missing-glyph horiz-adv-x="512" />
+<glyph class="hidden" unicode="&#xf000;" d="M0,480L 512 -32L0 -32 z" horiz-adv-x="0" />
+<glyph unicode="&#xe000;" d="M 0-31.643 L 170.431,224.002 L 0,479.646 L 127.822,479.646 L 298.254,224.002 L 127.822-31.643 L 0-31.643 Z M 0-31.643 M 170.431-31.643 L 340.864,224.002 L 170.431,479.646 L 298.254,479.646 L 639.112-31.643 L 511.289-31.643 L 404.775,128.131 L 298.254-31.643 L 170.431-31.643 Z M 170.431-31.643 M 582.305,117.481 L 525.499,202.693 L 724.331,202.699 L 724.331,117.481 L 582.305,117.481 Z M 582.305,117.481 M 497.092,245.304 L 440.279,330.516 L 724.331,330.522 L 724.331,245.304 L 497.092,245.304 Z M 497.092,245.304 " horiz-adv-x="724.329"  />
+<glyph unicode="&#x20;" horiz-adv-x="256" />
+</font></defs></svg>

static/css/haskell.font.css

@@ -0,0 +1,10 @@
+@font-face {
+  font-family: 'Haskell';
+  src:url('fonts/Haskell.eot');
+  src:url('fonts/Haskell.eot?#iefix') format('embedded-opentype'),
+  url('fonts/Haskell.woff') format('woff'),
+  url('fonts/Haskell.ttf') format('truetype'),
+  url('fonts/Haskell.svg#Haskell') format('svg');
+  font-weight: normal;
+  font-style: normal;
+}

static/js/warp.reload.js

@@ -0,0 +1,3 @@
+$.get('/reload',function(){
+    window.location.reload();
+});