capybara/ext-syntax/main.rkt

#lang racket/base

(require racket/list racket/match racket/port racket/runtime-path racket/string xml)

(define-runtime-path *python-path* "syntax-render.py")
(define-runtime-path *css-path* "css")

(provide transform-xexprs scss-files)

(define (brush-class? s)
  (and (string? s) (regexp-match #rx"^brush:" s) #t))

(define (transform-xexprs xexprs)
  (map transform-xexpr xexprs))

(define (run-pygments lang source)
  (define-values [proc out in err]
    (subprocess #f #f #f "/usr/bin/env" "python3" (path->string *python-path*) lang))
  (define out-str #f)
  (define err-str "")
  (define out-reader (thread (λ () (set! out-str (port->string out)))))
  (define err-reader (thread (λ () (set! err-str (port->string err)))))

  (write-string source in)
  (flush-output in)
  (close-output-port in)

  (subprocess-wait proc)
  (thread-wait out-reader)
  (thread-wait err-reader)

  (define err-trimmed (string-trim err-str))
  (unless (string=? "" err-trimmed)
    (error "pygments process raised error!" err-trimmed))

  (unless out-str
    (error "pygments process didn't return anything!"))

  (string->xexpr out-str))

(define (transform-xexpr xexpr)
  (match xexpr
    [(list 'pre (list (list 'class (? brush-class? cls)))
           (list 'code '() bodies ...))
     (define lang (second (string-split cls " ")))
     (define body (apply string-append bodies))
     (run-pygments lang body)]
    [(list 'pre '() (list 'code '() bodies ...))
     (define body (apply string-append bodies))
     (run-pygments "text" body)]
    [(list tag attrs body ...)
     (cons tag (cons attrs (map transform-xexpr body)))]
    [(? string? str) str]))

(define scss-files (list (build-path *css-path* "syntax.scss")))