improve Pygments support

highlight.rkt

@@ -8,14 +8,15 @@
          racket/string
          rackjure/threading
          rackjure/str
-         xml
+          xml
          (only-in html read-html-as-xml)
          pollen/debug)
 
 (provide highlight make-highlight-css)
 
+
 #|
-A small edit of Greg Hendershott's pygments.rkt,
+A small mashup of Greg Hendershott's pygments.rkt, html.rkt, and params.rkt,
 part of Frog, the static-blog generator
 http://github.com/greghendershott/frog
 
@@ -37,69 +38,87 @@ if zero is False:
 
 |#
 
-(define current-pygments-linenos? (make-parameter #t))
+(define prn0 void)
-(define current-pygments-cssclass (make-parameter "source"))
+(define prn1 message)
+
+;;;;;;;;;;;;;;;;;;
+;; from frog/html
+
+(define (read-html-as-xexprs) ;; (-> (listof xexpr?))
+  (~>> (read-html-as-xml)
+       (element #f #f 'root '())
+       xml->xexpr
+       decode-ampersands-in-attributes
+       cddr))
 
 (define (decode-ampersands-in-attributes x)
   (match x
     [`(,tag ([,ks ,vs] ...) . ,els)
      `(,tag
-       ,(for/list ([k (in-list ks)]
+       ,(for/list ([k ks]
-                   [v (in-list vs)])
+                   [v vs])
           (list k (regexp-replace* "&" v "\\&")))
        ,@(map decode-ampersands-in-attributes els))]
     [v v]))
 
+;; end frog/html
+;;;;;;;;;;;;;;;;;;
 
-(define (read-html-as-xexprs) ;; (-> (listof xexpr?))
-  (~>> (read-html-as-xml)
-       (element #f #f 'root '())
-       xml->xexpr
-       decode-ampersands-in-attributes
-       cddr))
 
+;;;;;;;;;;;;;;;;;;
+;; from frog/params
+
+(define current-pygments-linenos? (make-parameter #t))
+(define current-pygments-cssclass (make-parameter "source"))
+
+;; end frog/params
+;;;;;;;;;;;;;;;;;;
+
+
+
+;;;;;;;;;;;;;;;;;;
+;; from frog/pygments
+
+;; Process that runs Python with our pipe.py script.
 
-;; Go ahead during module load and start a thread to launch the
-;; subprocess that runs Python with our pipe.py script.
-(define-runtime-path pipe.py "pipe.py")
 (define-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
   (values #f #f #f #f #f))
+(define-runtime-path pipe.py "pipe.py")
 
-(define (make-pygments-thread)
+(define start
-  (thread
+  (let ([start-attempted? #f])
-   (thunk
+    (λ ()
-    ;; Start a subprocess running our pipe.py script.
+      (unless start-attempted?
-    (match (process (str "python -u " pipe.py
+        (set! start-attempted? #t)
-                         (if (current-pygments-linenos?) " --linenos" "")
+        (prn0 "Launching python pipe.py")
-                         " --cssclass " (current-pygments-cssclass)))
+        (match (process (str "python -u " pipe.py
-      [(list in out pid err proc)
+                             (if (current-pygments-linenos?) " --linenos" "")
-       (set!-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
+                             " --cssclass " (current-pygments-cssclass)))
-                    (values in out pid err proc))
+          [(list in out pid err proc)
-       (file-stream-buffer-mode out 'line)])
+           (set!-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
-    ;; Wait for its "ready\n"
+                        (values in out pid err proc))
-    (when (sync/timeout 3 pyg-in)
+           (file-stream-buffer-mode out 'line)
-      (read-line pyg-in 'linefeed)))))
+           (match (read-line pyg-in 'any)  ;; consume "ready" line or EOF
-
+             [(? eof-object?) (say-no-pygments)]
-(define load-thread #t)
+             [_ (say-pygments)])]
-
+          [_ (say-no-pygments)])))))
-(define (pygments-running?)
+
-  (define (pygments-status-is-running?)
+(define (say-pygments)
-    (and pyg-proc
+  (prn1 "Using Pygments."))
-         (eq? (pyg-proc 'status) 'running)))
+(define (say-no-pygments)
-  (when load-thread ;; first time
+  (prn1 "Pygments not found. Using plain `pre` blocks."))
-    (thread-wait (make-pygments-thread))
+
-    (set! load-thread #f)
+(define (running?)
-    (unless (pygments-status-is-running?)
+  (and pyg-proc
-      (message "Pygments not installed. Using plain `pre` blocks.")))
+       (eq? (pyg-proc 'status) 'running)))
-  (pygments-status-is-running?))
 
 (define (stop) ;; -> void
-  (when (pygments-running?)
+  (when (running?)
     (displayln "__EXIT__" pyg-out)
     (begin0 (or (pyg-proc 'exit-code) (pyg-proc 'kill))
-            (close-input-port pyg-in)
+      (close-input-port pyg-in)
-            (close-output-port pyg-out)
+      (close-output-port pyg-out)
-            (close-input-port pyg-err)))
+      (close-input-port pyg-err)))
   (void))
 
 (exit-handler
@@ -108,24 +127,31 @@ if zero is False:
      (stop)
      (old-exit-handler v))))
 
-(define (highlight lang . codelines)
+(define (pygmentize code lang) ;; string? string? -> (listof xexpr?)
-  (define code (string-append* codelines))
   (define (default code)
     `((pre () (code () ,code))))
-  (define result
+  (unless (running?)
-    `(div ((class "highlight"))
+    (start))
-      ,@(cond [(pygments-running?)
+  (cond [(running?)
-               (displayln lang pyg-out)
+         (displayln lang pyg-out)
-               (displayln code pyg-out)
+         (displayln code pyg-out)
-               (displayln "__END__" pyg-out)
+         (displayln "__END__" pyg-out)
-               (let loop ([s ""])
+         (let loop ([s ""])
-                 (match (read-line pyg-in 'any)
+           (match (read-line pyg-in 'any)
-                   ["__END__" (with-input-from-string s read-html-as-xexprs)]
+             ["__END__" (with-input-from-string s read-html-as-xexprs)]
-                   [(? string? v) (loop (str s v "\n"))]
+             [(? string? v) (loop (str s v "\n"))]
-                   [_ (copy-port pyg-err (current-output-port)) ;echo error msg
+             [_ (copy-port pyg-err (current-output-port)) ;echo error msg
-                      (default code)]))]
+                (default code)]))]
-              [else (default code)])))
+        [else (default code)]))
-  result)
+
+;; end frog/pygments
+;;;;;;;;;;;;;;;;;;
+
+
+(define (highlight lang . codelines)
+  (define code (string-append* codelines))
+  `(div ((class "highlight"))
+      ,@(pygmentize code lang)))
 
 ;; Other CSS options available from http://richleland.github.io/pygments-css/