Re-organize and simplify some bits

.gitignore

@@ -7,3 +7,4 @@ cabal-dev/
 TAGS
 tags
 *.tag
+client_session_key.aes

hl.cabal

@@ -15,9 +15,12 @@ executable hl
   hs-source-dirs:    src/
   ghc-options:       -Wall -O2
   main-is:           Main.hs
-  build-depends:     xml-conduit >= 1.1.0.9,
-                     conduit >= 1.0.15,
-                     warp >= 2.0.3.2,
+  build-depends:     monad-extras == 0.5.4,
+                     filepath == 1.3.0.0,
+                     markdown == 0.1.7,
+                     xml-conduit == 1.1.0.9,
+                     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,

src/Blaze/Prelude.hs

@@ -4,6 +4,7 @@ module Blaze.Prelude
   (module Blaze.Attributes
   ,module Blaze.Senza
   ,module Prelude
+  ,AttributeValue
   ,docTypeHtml)
   where
 

src/DevelMain.hs

@@ -2,13 +2,14 @@
 
 module DevelMain where
 
-import HL.Foundation
 import HL.Dispatch ()
+import HL.Foundation
 
 import Control.Concurrent
 import Data.IORef
 import Foreign.Store
 import Network.Wai.Handler.Warp
+import Yesod
 import Yesod.Static
 
 -- | Start the web server.
@@ -25,9 +26,9 @@ main =
                     do handler <- readIORef ref
                        handler req))
      _ <- newStore tid
-     ref <- newStore ref
-     newStore c
-     return ref
+     ref' <- newStore ref
+     _ <- newStore c
+     return ref'
 
 -- | Update the server, start it if not running.
 update :: IO (Store (IORef Application))

src/HL.hs

@@ -1,3 +0,0 @@
--- | Haskell web site.
-
-module HL where

src/HL/C.hs

@@ -0,0 +1,19 @@
+-- | Controller library.
+
+module HL.C
+  (module C
+  ,App(..)
+  ,C
+  ,io)
+  where
+
+import HL.Foundation (Handler)
+import HL.Foundation as C (Route(..),App(..))
+
+import Control.Monad.Extra
+import Data.Text as C (Text)
+import Yesod as C
+import Yesod.Blaze as C
+
+-- | Controller type.
+type C = Handler

src/HL/C/Community.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Community page controller.
+
+module HL.C.Community where
+
+import HL.C.Markdown
+import HL.C
+
+-- | Community controller.
+getCommunityR :: C Html
+getCommunityR =
+  markdownPage CommunityR "Community" "community.md"

src/HL/C/Documentation.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Documentation page controller.
+
+module HL.C.Documentation where
+
+import HL.C.Markdown
+import HL.C
+
+-- | Documentation controller.
+getDocumentationR :: C Html
+getDocumentationR =
+  markdownPage DocumentationR "Documentation" "documentation.md"

src/HL/C/Downloads.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Downloads page controller.
+
+module HL.C.Downloads where
+
+import HL.C.Markdown
+import HL.C
+
+-- | Downloads controller.
+getDownloadsR :: C Html
+getDownloadsR =
+  markdownPage DownloadsR "Downloads" "downloads.md"

src/HL/C/Home.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Home page controller.
+
+module HL.C.Home where
+
+import HL.C.Markdown
+import HL.C
+
+-- | Home controller.
+getHomeR :: C Html
+getHomeR =
+  markdownPage HomeR "Home" "home.md"

src/HL/C/Markdown.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Get markdown templates.
+
+module HL.C.Markdown where
+
+import           HL.C
+import           HL.M.Markdown
+import           HL.V.Markdown
+
+-- | Render a simple markdown page.
+markdownPage :: Route App -> Text -> FilePath -> C Html
+markdownPage route t name =
+  do content <- getMarkdown name
+     blaze (markdownV route t content)

src/HL/C/News.hs

@@ -0,0 +1,10 @@
+-- | News page controller.
+
+module HL.C.News where
+
+import HL.C
+import HL.V.News
+
+-- | News controller.
+getNewsR :: C Html
+getNewsR = blaze newsV

src/HL/C/Reload.hs

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

src/HL/C/Report.hs

@@ -0,0 +1,10 @@
+-- | Report page controller.
+
+module HL.C.Report where
+
+import HL.C
+import HL.V.Report
+
+-- | Report controller.
+getReportR :: Int -> C Html
+getReportR _ = blaze reportV

src/HL/C/Theme.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | CSS theme.
+
+module HL.C.Theme where
+
+import HL.C hiding (Text)
+import HL.V.Theme
+
+import Data.Text.Lazy (Text)
+import Language.CSS
+
+-- | Generate CSS from theme.
+getThemeR :: C TypedContent
+getThemeR =
+  respondSource "text/css" (sendChunk themeCss)
+
+-- | The theme's CSS.
+themeCss :: Text
+themeCss =
+  renderCSS (runCSS theme)

src/HL/C/Wiki.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Wiki page controller.
+
+module HL.C.Wiki where
+
+import HL.C
+import HL.M.Wiki
+import HL.V.Wiki
+
+import Prelude hiding (readFile,catch)
+
+-- | Wiki home (no page specified).
+getWikiHomeR :: C Html
+getWikiHomeR =
+  redirect (WikiR "HaskellWiki:Community")
+
+-- | Wiki controller.
+getWikiR :: Text -> C Html
+getWikiR name =
+  do url <- getUrlRender
+     result <- getWikiPage name
+     blaze (wikiV url result)

src/HL/Controller.hs

@@ -0,0 +1,11 @@
+-- | Controller library.
+
+module HL.Controller
+  (module C)
+  where
+
+import HL.Foundation
+
+import Yesod as C
+
+type Controller = Handler

src/HL/Controller/Community.hs

@@ -1,10 +0,0 @@
--- | 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

@@ -1,10 +0,0 @@
--- | 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

@@ -1,10 +0,0 @@
--- | 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/Home.hs

@@ -1,10 +0,0 @@
--- | Home page controller.
-
-module HL.Controller.Home where
-
-import HL.Foundation
-import HL.View.Home
-
--- | Home controller.
-getHomeR :: Handler Html
-getHomeR = blaze homeV

src/HL/Controller/News.hs

@@ -1,10 +0,0 @@
--- | 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/Report.hs

@@ -1,10 +0,0 @@
--- | Report page controller.
-
-module HL.Controller.Report where
-
-import HL.Foundation
-import HL.View.Report
-
--- | Report controller.
-getReportR :: Int -> Handler Html
-getReportR year = blaze reportV

src/HL/Controller/Theme.hs

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

src/HL/Controller/Wiki.hs

@@ -1,111 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Wiki page controller.
-
-module HL.Controller.Wiki where
-
-import           HL.Foundation
-import           HL.View.Wiki
-
-import Text.Pandoc.Options
-import           Blaze (renderHtml)
-import           Language.Haskell.HsColour.CSS (hscolour)
-import           Control.Exception.Lifted (catch)
-import           Data.Conduit
-import           Data.Conduit.Binary
-import qualified Data.Conduit.List as CL
-import           Data.List (isPrefixOf)
-import           Data.Maybe
-import           Data.Monoid
-import           Data.Text (Text,unpack,pack)
-import           Network.HTTP.Conduit
-import           Prelude hiding (readFile,catch)
-import           Text.Pandoc.Definition
-import           Text.Pandoc.Readers.MediaWiki
-import           Text.Pandoc.Walk
-import           Text.Pandoc.Writers.HTML
-import           Text.XML
-import           Text.XML.Cursor
-
--- | Wiki home (no page specified).
-getWikiHomeR :: Handler Html
-getWikiHomeR =
-  redirect (WikiR "HaskellWiki:Community")
-
--- | Wiki controller.
-getWikiR :: Text -> Handler Html
-getWikiR name =
-  do url <- getUrlRender
-     html <- liftIO (getWikiPageHtml url name)
-     blaze (wikiV html)
-
--- | Get the MediaWiki markup of a wiki page and then convert it to
--- HTML.
-getWikiPageHtml url article =
-  do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article)
-     withManager $ \manager -> do
-       response <- http request manager
-       doc <- catch (fmap Just (responseBody response $$+- sinkDoc def))
-                    (\(e::UnresolvedEntityException) -> return Nothing)
-       case doc >>= parse of
-         Nothing -> return (Left "Unable to parse XML from haskell.org.")
-         Just (title,text) -> return (Right (title,writeHtml writeOptions text))
-  where
-    writeOptions = def { writerTableOfContents = True }
-    parse doc =
-      do let cursor = fromDocument doc
-         title <- listToMaybe (getTitle cursor)
-         text <- listToMaybe (getText cursor)
-         return (title,(highlightBlock . highlightInline . relativize url)
-                       (readMediaWiki def (unpack text)))
-    name n =
-      Name {nameLocalName = n
-           ,nameNamespace = Just "http://www.mediawiki.org/xml/export-0.6/"
-           ,namePrefix = Nothing}
-    getText cursor =
-      element (name "mediawiki") cursor >>=
-      descendant >>=
-      element (name "page") >>=
-      descendant >>=
-      element (name "text") >>=
-      descendant >>=
-      content
-    getTitle cursor =
-      element (name "mediawiki") cursor >>=
-      descendant >>=
-      element (name "page") >>=
-      descendant >>=
-      element (name "title") >>=
-      descendant >>=
-      content
-
--- | Make all wiki links use the wiki route.
-relativize :: (Route App -> Text) -> Pandoc -> Pandoc
-relativize url = walk links
-  where links asis@(Link is (ref,title))
-          | isPrefixOf "http://" ref || isPrefixOf "https://" ref = asis
-          | otherwise = Link is (unpack (url (WikiR (pack ref))),title)
-        links x = x
-
--- | Highlight code blocks and inline code samples with a decent
--- Haskell syntax highlighter.
-highlightBlock :: Pandoc -> Pandoc
-highlightBlock = walk codes
-  where codes (CodeBlock attrs@("",["haskell"],[]) text) =
-          RawBlock "html" (hscolour False text)
-        codes x = x
-
--- | Highlight code blocks and inline code samples with a decent
--- Haskell syntax highlighter.
-highlightInline :: Pandoc -> Pandoc
-highlightInline = walk codes
-  where codes (Code attrs@("",["haskell"],[]) text) =
-          RawInline "html" (codeEl (stripCPre (stripPre (hscolour False text))))
-        codes x = x
-        stripPre ('<':'p':'r':'e':'>':xs) = xs
-        stripPre xs = xs
-        stripCPre (reverse -> ('<':'/':'p':'r':'e':'>':xs)) = reverse xs
-        stripCPre xs = xs
-        codeEl xs = "<code>" ++ xs ++ "</code>"

src/HL/Dispatch.hs

@@ -5,15 +5,17 @@
 
 module HL.Dispatch () where
 
-import HL.Controller.Community
-import HL.Controller.Documentation
-import HL.Controller.Downloads
-import HL.Controller.Home
-import HL.Controller.News
-import HL.Controller.Reload
-import HL.Controller.Report
-import HL.Controller.Theme
-import HL.Controller.Wiki
+import HL.C.Community
+import HL.C.Documentation
+import HL.C.Downloads
+import HL.C.Home
+import HL.C.News
+import HL.C.Reload
+import HL.C.Report
+import HL.C.Theme
+import HL.C.Wiki
 import HL.Foundation
 
+import Yesod
+
 mkYesodDispatch "App" resourcesApp

src/HL/Foundation.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-orphans #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -7,7 +8,6 @@
 
 module HL.Foundation
   (module HL.Static
-  ,module Yesod.Blaze
   ,App(..)
   ,Route(..)
   ,Handler
@@ -16,22 +16,15 @@ module HL.Foundation
   where
 
 import HL.Static
+import HL.Types
 
-import Control.Concurrent.Chan
 import Data.Text (Text)
 import Network.Wai.Logger
 import System.Log.FastLogger
 import Yesod
-import Yesod.Blaze
 import Yesod.Core.Types
 import Yesod.Static
 
--- | Application state.
-data App = App
-  { appStatic :: Static
-  , appReload :: Chan ()
-  }
-
 -- | Generate boilerplate.
 mkYesodData "App" $(parseRoutesFile "config/routes")
 

src/HL/M.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Model library.
+
+module HL.M where
+
+import Control.Applicative
+
+-- | The model monad.
+newtype Model a = Model (IO a)
+  deriving (Monad,Functor,Applicative)

src/HL/M/Markdown.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Markdown files.
+
+module HL.M.Markdown where
+
+import           HL.C
+import           HL.Types
+
+import           Control.Exception
+import qualified Data.Text.Lazy.IO as LT
+import           System.Directory
+import           System.FilePath
+import           Text.Markdown
+
+-- | Get the HTML for the given markdown static file.
+getMarkdown :: FilePath -> C Html
+getMarkdown name =
+  do exists <- io (doesFileExist fp)
+     if exists
+        then do text <- io (LT.readFile fp)
+                let !html = markdown def text
+                return html
+        else throw (MarkdownFileUnavailable name)
+  where fp = "static" </> "markdown" </> name

src/HL/M/Wiki.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Model for wiki.
+
+module HL.M.Wiki where
+
+import HL.C
+
+import Control.Exception.Lifted (catch)
+import Data.Conduit
+
+import Data.Maybe
+import Data.Monoid
+import Data.Text (unpack)
+
+import Network.HTTP.Conduit
+import Prelude hiding (readFile,catch)
+import Text.Pandoc.Definition
+import Text.Pandoc.Options
+import Text.Pandoc.Readers.MediaWiki
+
+import Text.XML
+import Text.XML.Cursor
+
+-- | Get the MediaWiki markup of a wiki page and then convert it to
+-- HTML.
+getWikiPage :: Text -> C (Either Text (Text,Pandoc))
+getWikiPage article =
+  do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article)
+     withManager $ \manager -> do
+       response <- http request manager
+       doc <- catch (fmap Just (responseBody response $$+- sinkDoc def))
+                    (\(_::UnresolvedEntityException) -> return Nothing)
+       case doc >>= parse of
+         Nothing -> return (Left "Unable to parse XML from haskell.org.")
+         Just (title,pan) -> return (Right (title,pan))
+  where
+    parse doc =
+      do let cursor = fromDocument doc
+         title <- listToMaybe (getTitle cursor)
+         text <- listToMaybe (getText cursor)
+         return (title,readMediaWiki def (unpack text))
+    name n =
+      Name {nameLocalName = n
+           ,nameNamespace = Just "http://www.mediawiki.org/xml/export-0.6/"
+           ,namePrefix = Nothing}
+    getText cursor =
+      element (name "mediawiki") cursor >>=
+      descendant >>=
+      element (name "page") >>=
+      descendant >>=
+      element (name "text") >>=
+      descendant >>=
+      content
+    getTitle cursor =
+      element (name "mediawiki") cursor >>=
+      descendant >>=
+      element (name "page") >>=
+      descendant >>=
+      element (name "title") >>=
+      descendant >>=
+      content

src/HL/Static.hs

@@ -4,4 +4,5 @@
 module HL.Static where
 
 import Yesod.Static
+
 staticFiles "static/"

src/HL/Types.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | Side-wide datatypes.
+
+module HL.Types where
+
+import Control.Concurrent.Chan
+import Control.Exception
+import Data.Typeable
+import Yesod.Static
+
+-- | A haskell-lang exception.
+data HaskellLangException =
+  MarkdownFileUnavailable FilePath
+  deriving (Show,Typeable,Eq)
+
+instance Exception HaskellLangException
+
+-- | Application state.
+data App = App
+  { appStatic :: Static
+  , appReload :: Chan ()
+  }

src/HL/V.hs

@@ -0,0 +1,14 @@
+-- | View library.
+
+module HL.V
+  (module V)
+  where
+
+import HL.Foundation as V (Route(..),App)
+import HL.Static as V
+
+import Blaze.Bootstrap as V
+import Blaze.Prelude as V
+import Data.Text as V (Text)
+import Yesod.Blaze as V
+import Control.Monad as V

src/HL/V/Documentation.hs

@@ -1,15 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS -fno-warn-unused-do-bind #-}
 
 -- | Documentation page view.
 
-module HL.View.Documentation where
+module HL.V.Documentation where
 
-import HL.Foundation
-import HL.View.Template
-
-import Blaze.Prelude
-import Blaze.Bootstrap
+import HL.V
+import HL.V.Template
 
 -- | Documentation view.
 documentationV :: Blaze App
@@ -22,15 +20,17 @@ documentationV =
          (row
             (span12
                (do h1 [] "Documentation"
-                   online url
+                   online
                    report url))))
 
-online url =
+online :: Html
+online =
   do h2 [] "Online Resources"
      p [] "There are various online resources for learning Haskell; books, \
           \articles, videos, etc. below are some of the highlights:"
 
 
+report :: (Route App -> AttributeValue) -> Html
 report url =
   do h2 [] "Language Report"
      p []

src/HL/V/Markdown.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Simple markdown page view.
+
+module HL.V.Markdown where
+
+import HL.V
+import HL.V.Template
+
+-- | Render a simple page.
+markdownV :: Route App -> Text -> Html -> Blaze App
+markdownV route t inner =
+  template
+    [(route,t)]
+    t
+    (const (container (row (span12 inner))))

src/HL/V/News.hs

@@ -3,13 +3,10 @@
 
 -- | News page view.
 
-module HL.View.News where
+module HL.V.News where
 
-import HL.Foundation
-import HL.View.Template
-
-import Blaze.Prelude
-import Blaze.Bootstrap
+import HL.V
+import HL.V.Template
 
 -- | News view.
 newsV :: Blaze App

src/HL/V/Report.hs

@@ -3,13 +3,10 @@
 
 -- | Report page view.
 
-module HL.View.Report where
+module HL.V.Report where
 
-import HL.Foundation
-import HL.View.Template
-
-import Blaze.Prelude
-import Blaze.Bootstrap
+import HL.V
+import HL.V.Template
 
 -- | Report view.
 reportV :: Blaze App
@@ -17,7 +14,7 @@ reportV =
   template
     [(ReportR 2010,"Report")]
     "Report"
-    (\url ->
+    (\_ ->
        container
          (row
             (span12

src/HL/V/Template.hs

@@ -3,16 +3,11 @@
 
 -- | Templates.
 
-module HL.View.Template where
+module HL.V.Template where
 
-import           HL.Foundation
+import           HL.V hiding (item)
 
-import           Blaze (AttributeValue)
-import           Blaze.Bootstrap
 import qualified Blaze.Elements as E
-import           Blaze.Prelude
-import           Control.Monad
-import           Data.Text (Text)
 
 -- | Render a template.
 template
@@ -64,31 +59,33 @@ navigation cur url =
       (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")
-                         ,(WikiHomeR,"Wiki")]))
-          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"))
+  where
+    items =
+      div [class_ "collapse navbar-collapse"]
+          (ul [class_ "nav navbar-nav"]
+              (mapM_ (uncurry item)
+                     [(DownloadsR,"Downloads")
+                     ,(CommunityR,"Community")
+                     ,(DocumentationR,"Documentation")
+                     ,(NewsR,"News")
+                     ,(WikiHomeR,"Wiki")]))
+      where item route t = li theclass (a [href (url route)] t)
+              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))))
+            (\(route,t) ->
+               li [] (a [href (url route)]
+                        (toHtml t))))

src/HL/V/Theme.hs

@@ -4,7 +4,7 @@
 
 -- | CSS theme.
 
-module HL.View.Theme
+module HL.V.Theme
   (theme)
   where
 
@@ -64,15 +64,15 @@ navbar =
      rule ".navbar-header .navbar-brand:hover"
           (color "#fff")
      rule ".navbar-default .navbar-nav > .active > a"
-          (do theme
+          (do theme'
               backgroundColor "#312b3f"
               borderBottom "0.3em solid #465787")
      rule ".navbar-default .navbar-nav > .active > a:hover"
-          (do theme
+          (do theme'
               backgroundColor "#312b3f")
      rule ".navbar-default .navbar-nav > li > a"
-          theme
-  where theme =
+          theme'
+  where theme' =
           do color "#d1cddc !important"
              backgroundColor "inherit"
 

src/HL/V/Wiki.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Wiki page view.
+
+module HL.V.Wiki where
+
+import HL.V
+import HL.V.Template
+
+import Data.List (isPrefixOf)
+import Data.Text (unpack,pack)
+import Language.Haskell.HsColour.CSS (hscolour)
+import Prelude hiding (readFile,catch)
+import Text.Pandoc.Definition
+import Text.Pandoc.Options
+import Text.Pandoc.Walk
+import Text.Pandoc.Writers.HTML
+
+-- | Wiki view.
+wikiV :: (Route App -> Text) -> Either Text (Text,Pandoc) -> Blaze App
+wikiV urlr result =
+  template
+    ([(WikiHomeR,"Wiki")] ++
+     [(WikiR n,n) | Right (n,_) <- [result]])
+    (case result of
+       Left{} -> "Wiki error!"
+       Right (t,_) -> t)
+    (\_ ->
+       container
+         (row
+            (span12
+               (case result of
+                  Left err ->
+                    do h1 [] "Wiki page retrieval problem!"
+                       p [] (toHtml err)
+                  Right (t,pan) ->
+                    do h1 [] (toHtml t)
+                       writeHtml writeOptions (cleanup urlr pan)))))
+  where cleanup url = highlightBlock . highlightInline . relativize url
+        writeOptions = def { writerTableOfContents = True }
+
+-- | Make all wiki links use the wiki route.
+relativize :: (Route App -> Text) -> Pandoc -> Pandoc
+relativize url = walk links
+  where links asis@(Link is (ref,t))
+          | isPrefixOf "http://" ref || isPrefixOf "https://" ref = asis
+          | otherwise = Link is (unpack (url (WikiR (pack ref))),t)
+        links x = x
+
+-- | Highlight code blocks and inline code samples with a decent
+-- Haskell syntax highlighter.
+highlightBlock :: Pandoc -> Pandoc
+highlightBlock = walk codes
+  where codes (CodeBlock ("",["haskell"],[]) text) =
+          RawBlock "html" (hscolour False text)
+        codes x = x
+
+-- | Highlight code blocks and inline code samples with a decent
+-- Haskell syntax highlighter.
+highlightInline :: Pandoc -> Pandoc
+highlightInline = walk codes
+  where codes (Code ("",["haskell"],[]) text) =
+          RawInline "html" (codeEl (stripCPre (stripPre (hscolour False text))))
+        codes x = x
+        stripPre ('<':'p':'r':'e':'>':xs) = xs
+        stripPre xs = xs
+        stripCPre (reverse -> ('<':'/':'p':'r':'e':'>':xs)) = reverse xs
+        stripCPre xs = xs
+        codeEl xs = "<code>" ++ xs ++ "</code>"

src/HL/View/Community.hs

@@ -1,33 +0,0 @@
-{-# 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")]
-    "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/Downloads.hs

@@ -1,32 +0,0 @@
-{-# 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")]
-    "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

@@ -1,39 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Home page view.
-
-module HL.View.Home where
-
-import HL.Foundation
-import HL.View.Template
-
-import Blaze.Prelude
-import Blaze.Bootstrap
-
--- | Home view.
-homeV :: Blaze App
-homeV =
-  template
-    [(HomeR,"Home")]
-    "Home"
-    (\_ ->
-       container
-         (row
-            (span12
-               (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/Wiki.hs

@@ -1,34 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Wiki page view.
-
-module HL.View.Wiki where
-
-import HL.Foundation
-import HL.View.Template
-
-import Blaze.Bootstrap
-import Blaze.Prelude
-import Data.Text (Text)
-
--- | Wiki view.
-wikiV :: Either Text (Text,Html) -> Blaze App
-wikiV result =
-  template
-    ([(WikiHomeR,"Wiki")] ++
-     [(WikiR name,name) | Right (name,_) <- [result]])
-    (case result of
-       Left{} -> "Wiki error!"
-       Right (title,_) -> title)
-    (\_ ->
-       container
-         (row
-            (span12
-               (case result of
-                  Left err ->
-                    do h1 [] "Wiki page retrieval problem!"
-                       p [] (toHtml err)
-                  Right (title,html) ->
-                    do h1 [] (toHtml title)
-                       html))))

src/Main.hs

@@ -4,7 +4,7 @@ module Main where
 
 import           HL.Foundation
 import           HL.Dispatch ()
-import           HL.Controller.Theme
+import           HL.C.Theme
 
 import           Control.Concurrent.Chan
 import qualified Data.Text.Lazy.IO as L

static/markdown/community.md

@@ -0,0 +1,9 @@
+# Community
+
+The Haskell community is spread out online across several mediums and around the world!
+
+* The Haskell-Cafe mailing list
+* StackOverflow
+* G+
+* Reddit
+* The Wiki

static/markdown/documentation.md

@@ -0,0 +1,17 @@
+# Documentation
+
+## Online Resources
+
+There are various online resources for learning Haskell; books,
+articles, videos, etc. below are some of the highlights:
+
+## Language Report
+
+The Haskell 2010 language report is available
+[online here](http://localhost:1990/report/2010).
+
+A PDF version is [available here](http://haskell.org/definition/haskell2010.pdf).
+
+It can also be downloaded as a darcs repository:
+
+    $ darcs get http://darcs.haskell.org/haskell2010-report

static/markdown/downloads.md

@@ -0,0 +1,10 @@
+# Downloads
+
+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.

static/markdown/home.md

@@ -0,0 +1 @@
+Hello!