Merkkaa koodilohkot Gitean väritettäväksi

.guix/modules/data-gitea-markdown-package.scm

@@ -1,10 +1,13 @@
 (define-module (data-gitea-markdown-package)
   #:use-module (guix)
   #:use-module (guix build-system haskell)
+  #:use-module (guix build-system go)
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-check)
   #:use-module (gnu packages haskell-web)
   #:use-module (gnu packages haskell-xyz))
 
@@ -20,8 +23,63 @@
                         #:recursive? #t
                         #:select? vcs-file?))
     (build-system haskell-build-system)
-    (inputs (list ghc-pandoc ghc-pandoc-types ghc-tagsoup))
+    (arguments
+      (list
+       #:phases
+       #~(modify-phases %standard-phases
+           (add-after 'install 'wrap-binaries
+             (lambda _
+               (wrap-program
+                 (string-append #$output "/bin/gitea-markdown")
+                 `("PATH" = (,(string-append #$(this-package-input "go-chroma") "/bin")))))))))
+    (inputs
+      (list ghc-pandoc
+            ghc-pandoc-types
+            ghc-tagsoup
+            go-chroma))
     (home-page "")
     (synopsis "")
     (description "")
     (license license:agpl3+)))
+
+(define go-chroma
+  (package
+    (inherit go-github-com-alecthomas-chroma)
+    (name "go-chroma")
+    (native-inputs
+      (list go-github-com-alecthomas-assert
+            go-github-com-alecthomas-kong
+            go-github-com-danwakefield-fnmatch
+            go-github-com-dlclark-regexp2
+            go-github-com-mattn-go-colorable
+            go-github-com-mattn-go-isatty))
+    (arguments
+      (list
+       #:import-path "github.com/alecthomas/chroma/cmd/chroma"
+       #:unpack-path "github.com/alecthomas/chroma"))))
+
+(define-public go-github-com-alecthomas-kong
+  (package
+    (name "go-github-com-alecthomas-kong")
+    (version "0.2.4")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/alecthomas/kong")
+             (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "0lv8xk71p5729igwmp6slhmf9x1g5z3zmkfx1mg1y2spn2ck4q7l"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/alecthomas/kong"))
+    (propagated-inputs
+      (list go-github-com-pkg-errors
+            go-github-com-stretchr-testify))
+    (home-page "https://github.com/alecthomas/kong")
+    (synopsis "Kong is a command-line parser for Go")
+    (description
+     "Package kong aims to support arbitrarily complex command-line structures with as
+little developer effort as possible.")
+    (license license:expat)))

gitea-markdown/data-gitea-markdown.cabal

@@ -15,11 +15,13 @@ executable gitea-markdown
     data-default,
     pandoc,
     pandoc-types,
+    process,
     tagsoup,
     text
   main-is: Main.hs
   other-modules:
     Gitea.Preview.Markdown
+    Gitea.Preview.Markdown.ChromaHighlight
     Gitea.Preview.Markdown.Math
     Gitea.Preview.Markdown.Meta
     Gitea.Preview.Markdown.Signatures

gitea-markdown/src/Gitea/Preview/Markdown.hs

@@ -14,6 +14,7 @@ import qualified Data.Text.IO as T
 import Gitea.Preview.Markdown.Math
 import Gitea.Preview.Markdown.Meta
 import Gitea.Preview.Markdown.Signatures
+import Gitea.Preview.Markdown.ChromaHighlight
 
 main :: IO ()
 main = do
@@ -28,6 +29,7 @@ main = do
 pandocFilter :: Pandoc -> Pandoc
 pandocFilter = renderSignatures'
     . katexMath'
+    . chromaHighlight'
     . renderMeta'
 
 readMD :: Text -> Either PandocError Pandoc

gitea-markdown/src/Gitea/Preview/Markdown/ChromaHighlight.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gitea.Preview.Markdown.ChromaHighlight where
+
+import Control.Exception (Exception(..), throw)
+import Data.Either (fromRight)
+import Data.List (singleton)
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import System.Exit (ExitCode(..))
+import System.IO (hClose)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Process (CreateProcess(..), StdStream(..), createProcess, proc, waitForProcess)
+import Text.Pandoc (Block(..), Format(..), Pandoc)
+import Text.Pandoc.Walk (walk)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+chromaHighlight' :: Pandoc -> Pandoc
+chromaHighlight' = walk chromaHighlight
+
+chromaHighlight :: Block -> Block
+chromaHighlight (CodeBlock attr@(_, classes, _) text) = Div attr $ singleton $ RawBlock (Format "html") $
+    tryChromaHighlight (T.unpack <$> listToMaybe classes) text
+chromaHighlight x = x
+
+tryChromaHighlight :: Maybe String -> Text -> Text
+tryChromaHighlight (Just language) text = fromRight (tryChromaHighlight Nothing text) $
+    chromaHighlightText language text
+tryChromaHighlight Nothing text = either throw id $ chromaHighlightText "plain" text
+
+chromaHighlightText :: String -> Text -> Either ChromaError Text
+chromaHighlightText language text = unsafePerformIO $ do
+    (Just hIn, Just hOut, Just hErr, processHandle) <- createProcess $
+        (proc "chroma" ["--html", "--html-only", "--lexer", language])
+            {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe}
+    T.hPutStrLn hIn text
+    hClose hIn
+    highlighted <- T.hGetContents hOut
+    errors <- T.hGetContents hErr
+    exitCode <- waitForProcess processHandle
+    pure $ case exitCode of
+      ExitSuccess -> Right highlighted
+      ExitFailure err -> Left $ ChromaError err errors
+
+data ChromaError = ChromaError Int Text deriving Show
+
+instance Exception ChromaError where
+    displayException (ChromaError exitCode errors) =
+        "chroma exited with code '" <> show exitCode <> "' and error message:\n" <> T.unpack errors