Fenced code block extension for lowdown

lowdown-fenced-code-block.scm

(module lowdown-fenced-code-block

(fenced-code-block
 enable-lowdown-fenced-code-blocks!)

(import scheme)
(import (chicken base))
(import (chicken string))

(import (srfi 13))
(import colorize)
(import comparse)
(import (clojurian syntax))
(import html-parser)
(import lowdown)
(import (lowdown lolevel))

(define (fenced-code-block-end fence)
  (any-of end-of-input
          (skip non-indent-space
                (char-seq fence)
                (zero-or-more (is (string-ref fence 0)))
                space*
                line-end)))

(define (fenced-code-block-lines indent code-block-end)
  (zero-or-more
   (preceded-by (none-of code-block-end)
                (repeated (is #\space) max: (length indent))
                line)))

(define fenced-code-block-info-string
  (as-string (zero-or-more (none-of* (is #\`) normal-line-end item))))

(define fenced-code-block
  (sequence* ((indent non-indent-space)
              (fence (as-string (repeated (in #\` #\~) min: 3)))
              (_ space*)
              (info fenced-code-block-info-string)
              (_ normal-line-end))
    (let ((code-block-end (fenced-code-block-end fence)))
      (sequence* ((code-lines (fenced-code-block-lines indent code-block-end))
                  (_ code-block-end))
        (result `(verbatim (info ,(string-trim-both info))
                           (code ,@code-lines)))))))

(define fenced-code-block-conversion-rules*
  `((verbatim . ,(lambda (_ contents)
                   (or (and-let* (((pair? contents))
                                  ((pair? (car contents)))
                                  (info (alist-ref 'info contents))
                                  (code (alist-ref 'code contents))
                                  (lang (car info))
                                  (lang* (string->symbol lang)))
                         (if (coloring-type-exists? lang*)
                             `(pre (code (@ (class ,(string-append "language-" lang))))
                                   ,@(->> (string-intersperse code "")
                                          (html-colorize lang*)
                                          (html->sxml)
                                          (cdr)))
                             #f))
                       `(pre (code ,@contents)))))))

(define (enable-lowdown-fenced-code-blocks!)
  (block-hook (cons fenced-code-block (block-hook)))
  (markdown-html-conversion-rules*
   (append fenced-code-block-conversion-rules*
           (markdown-html-conversion-rules*)))
  (void))

)