Add option to render pretty AP JSON using Skylighting

highligher2 doesn't have a JSON syntax and the JS lexer seems to be failing,
not sure exactly why yet. To have an alternative, I'm adding a Skylighting
option.

src/Yesod/ActivityPub.hs

@@ -187,16 +187,27 @@ provideHtmlAndAP' host object widget = selectRep $ do
         mval <- lookupGetParam "prettyjson"
         defaultLayout $
             case mval of
-                Just "true" -> renderPrettyJSON doc
+                Just "true" -> do
+                    mhl <- lookupGetParam "highlight"
+                    let sky = case mhl of
+                                Nothing -> error "Highlight style not set"
+                                Just "hl2" -> False
+                                Just "sky" -> True
+                                Just _ -> error "Invalid highlight style"
+                    if sky
+                        then renderPrettyJSONSkylighting doc
+                        else renderPrettyJSON doc
                 _ -> do
                     widget
                     mroute <- getCurrentRoute
                     for_ mroute $ \ route -> do
                         params <- reqGetParams <$> getRequest
                         let pj = ("prettyjson", "true")
+                            hl = ("highlight", "hl2")
+                            params' = pj : hl : params
                         [whamlet|
                             <div>
-                              <a href=@?{(route, pj : params)}>
+                              <a href=@?{(route, params')}>
                                 [See JSON]
                         |]
 
@@ -209,15 +220,26 @@ provideHtmlAndAP'' body widget = selectRep $ do
         mval <- lookupGetParam "prettyjson"
         defaultLayout $
             case mval of
-                Just "true" -> renderPrettyJSON' body
+                Just "true" -> do
+                    mhl <- lookupGetParam "highlight"
+                    let sky = case mhl of
+                                Nothing -> error "Highlight style not set"
+                                Just "hl2" -> False
+                                Just "sky" -> True
+                                Just _ -> error "Invalid highlight style"
+                    if sky
+                        then renderPrettyJSONSkylighting' body
+                        else renderPrettyJSON' body
                 _ -> do
                     widget
                     mroute <- getCurrentRoute
                     for_ mroute $ \ route -> do
                         params <- reqGetParams <$> getRequest
                         let pj = ("prettyjson", "true")
+                            hl = ("highlight", "hl2")
+                            params' = pj : hl : params
                         [whamlet|
                             <div>
-                              <a href=@?{(route, pj : params)}>
+                              <a href=@?{(route, params')}>
                                 [See JSON]
                         |]

src/Yesod/RenderSource.hs

@@ -42,6 +42,8 @@ module Yesod.RenderSource
     , renderPandocMarkdown
     , renderPrettyJSON
     , renderPrettyJSON'
+    , renderPrettyJSONSkylighting
+    , renderPrettyJSONSkylighting'
     )
 where
 
@@ -54,6 +56,7 @@ import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Text (Text)
 --import Formatting hiding (format)
+import Skylighting
 import Text.Blaze.Html (preEscapedToMarkup)
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName))
@@ -69,10 +72,12 @@ import Yesod.Core.Widget
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Encoding.Error as TE
 import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Text.Lazy.Encoding as TLE
 import qualified Text.Highlighter.Lexers.Haskell as L.Haskell
 import qualified Text.Highlighter.Lexers.Javascript as L.JS
@@ -264,3 +269,24 @@ renderPrettyJSON' prettyBL =
     let prettyB = BL.toStrict prettyBL
         prettyTL = TLE.decodeUtf8 prettyBL
     in  renderCode L.JS.lexer prettyTL prettyB
+
+renderPrettyJSONSkylighting' :: BL.ByteString -> WidgetFor site ()
+renderPrettyJSONSkylighting' prettyBL =
+    case tokenizeJSON prettyBL of
+        Left e -> error $ "Tokenizing JSON failed: " ++ e
+        Right sls -> do
+            toWidgetHead $ CssBuilder $ TLB.fromString $ styleToCss zenburn
+            toWidget $ formatHtmlBlock options sls
+    where
+    tokenizeJSON = tokenize config jsonSyntax . TE.decodeUtf8 . BL.toStrict
+        where
+        syntaxMap = defaultSyntaxMap
+        jsonSyntax =
+            case M.lookup "JSON" syntaxMap of
+                Nothing -> error "Skylighting JSON syntax not found"
+                Just s -> s
+        config = TokenizerConfig syntaxMap False
+    options = defaultFormatOpts { numberLines = True }
+
+renderPrettyJSONSkylighting :: ToJSON a => a -> WidgetFor site ()
+renderPrettyJSONSkylighting = renderPrettyJSONSkylighting' . encode

vervis.cabal

@@ -326,6 +326,8 @@ library
                      , resourcet
                      , safe
                      , shakespeare
+                       -- for json debug highlighting in Yesod.RenderSource
+                     , skylighting
                      , smtp-mail
                      , ssh
                        -- for holding actor key in a TVar