Merkkaa koodilohkot Gitean väritettäväksi

This commit is contained in:
Saku Laesvuori 2023-11-22 18:30:44 +02:00
parent 0ec7996bd7
commit 61ea6a7ffb
4 changed files with 114 additions and 1 deletions

View File

@ -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)))

View File

@ -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

View File

@ -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

View File

@ -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