Add code highlighting

guide.cabal

@@ -44,6 +44,7 @@ executable guide
                      , containers >= 0.5
                      , ekg
                      , ekg-core
+                     , highlighting-kate >= 0.6
                      , lucid
                      , megaparsec
                      , microlens-platform >= 0.2.3

src/Main.hs

@@ -36,6 +36,8 @@ import Lucid.Base (makeAttribute)
 import Web.Spock hiding (head, get, text)
 import qualified Web.Spock as Spock
 import Network.Wai.Middleware.Static
+-- Highlighting
+import qualified Text.Highlighting.Kate as Kate
 -- Monitoring
 import qualified System.Remote.Monitoring as EKG
 import qualified Network.Wai.Metrics as EKG
@@ -227,6 +229,10 @@ otherMethods = do
   Spock.get "js.js" $ do
     setHeader "Content-Type" "application/javascript; charset=utf-8"
     Spock.bytes $ T.encodeUtf8 (fromJS allJSFunctions)
+  -- CSS
+  Spock.get "highlight.css" $ do
+    setHeader "Content-Type" "text/css; charset=utf-8"
+    Spock.bytes $ T.encodeUtf8 (T.pack (Kate.styleToCss Kate.pygments))
 
   -- Moving things
   Spock.subcomponent "move" $ do
@@ -259,6 +265,8 @@ main = do
       createCheckpoint db
       threadDelay (1000000 * 3600)
     -- EKG metrics
+    -- TODO: stop the server upon exit, somehow (or just don't start it
+    -- unless there's been some option passed?)
     ekg <- EKG.forkServer "localhost" 5050
     waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekg)
     categoryGauge <- EKG.getGauge "db.categories" ekg
@@ -335,6 +343,7 @@ renderRoot globalState mbSearchQuery = doctypehtml_ $ do
     includeJS (cdnjs <> "autosize.js/3.0.15/autosize.min.js")
     onPageLoad (JS "autosize($('textarea'));")
     includeCSS "/css.css"
+    includeCSS "/highlight.css"
     -- Include definitions of all Javascript functions that we have defined
     -- in this file. (This isn't an actual file, so don't look for it in the
     -- static folder – it's generated and served in 'otherMethods'.)
@@ -402,8 +411,6 @@ renderRoot globalState mbSearchQuery = doctypehtml_ $ do
 
 -- TODO: mention that (@hackage) is supported somewhere
 
--- TODO: code highlighting
-
 -- TODO: when submitting a text field, gray it out (but leave it selectable)
 -- until it's been submitted
 

src/Markdown.hs

@@ -19,6 +19,7 @@ import Control.Monad.Writer
 -- Text
 import qualified Data.Text as T
 import Data.Text (Text)
+import qualified Data.Text.Lazy as TL
 -- Parsing
 import Text.Megaparsec
 -- HTML
@@ -31,6 +32,8 @@ import Data.Sequence
 import Cheapskate
 import Cheapskate.Html
 import ShortcutLinks
+-- Highlighting
+import qualified Text.Highlighting.Kate as Kate
 
 
 blazeToLucid :: Monad m => Blaze.Html -> HtmlT m ()
@@ -74,6 +77,15 @@ shortcutLinks i@(Link is url title) | '@' <- T.head url =
           Str ("[error when processing shortcut link: " <> T.pack err <> "]")
 shortcutLinks other = other
 
+highlight :: Block -> Block
+highlight (CodeBlock attr code) =
+  HtmlBlock (TL.toStrict (Blaze.renderHtml formatted))
+  where
+    lang = T.unpack (codeLang attr)
+    highlighted = Kate.highlightAs lang (T.unpack code)
+    formatted = Kate.formatHtmlBlock Kate.defaultFormatOpts highlighted
+highlight other = other
+
 -- TODO: this should be in the shortcut-links package itself
 
 -- | Parse a shortcut link. Allowed formats:
@@ -112,8 +124,8 @@ renderMarkdownLine s = do
     extractInlines HRule = mempty
 
 -- TODO: rename to renderMarkdownBlocks
--- TODO: would be nice to have syntax highlighting
 renderMarkdownBlock :: Monad m => Text -> HtmlT m ()
 renderMarkdownBlock =
   blazeToLucid . renderDoc .
-  walk shortcutLinks . markdown def{allowRawHtml=False}
+  walk highlight . walk shortcutLinks .
+  markdown def