From c23bfbc2f6d9f8a3602fb1273c75977647e493fb Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Thu, 23 Jul 2020 17:47:04 +0900
Subject: [PATCH] including example output in (chibi doc), translate ansi
 escape

---
 lib/chibi/doc-test.sld |  11 ++++
 lib/chibi/doc.scm      | 118 ++++++++++++++++++++++++++++++++++++++---
 lib/chibi/doc.sld      |   5 +-
 3 files changed, 124 insertions(+), 10 deletions(-)

diff --git a/lib/chibi/doc-test.sld b/lib/chibi/doc-test.sld
index 04c14637..e5663bda 100644
--- a/lib/chibi/doc-test.sld
+++ b/lib/chibi/doc-test.sld
@@ -25,4 +25,15 @@
                       (index (if (pair? o) (car o) 0))
                       (acc knil))
                (f p index fk)))))
+      (test "hello" (ansi->sxml "hello"))
+      (test '(span "[ " (span (@ (style . "color:red")) "FAIL") "]")
+          (ansi->sxml "[ \x1B;[31mFAIL\x1B;[39m]"))
+      (test '(span (u "under " (span (@ (style . "color:red")) "red") " line"))
+          (ansi->sxml "\x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
+      (test '(span "plain "
+                   (u "under "
+                      (span (@ (style . "color:red")) "red")
+                      " line"))
+          (ansi->sxml
+           "plain \x1B;[4munder \x1B;[31mred\x1B;[39m line\x1B;[24m"))
       (test-end))))
diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm
index f10c6672..637b0b82 100644
--- a/lib/chibi/doc.scm
+++ b/lib/chibi/doc.scm
@@ -79,6 +79,95 @@
 (define (sxml->sexp-list x)
   (call-with-input-string (sxml-strip x) port->sexp-list))
 
+;;> Replace ansi escape sequences in a \var{str} with the corresponding sxml.
+(define (ansi->sxml str)
+  ;; TODO: ick
+  (let ((start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (let lp1 ((from start)
+              (to start)
+              (res '()))
+      (define (lookup str)
+        (case (string->number str)
+          ((0) '/) ((1) 'b) ((3) 'i) ((4) 'u) ((9) 's)
+          ((22) '/b) ((23) '/i) ((24) '/u) ((29) '/s)
+          ((30) 'black) ((31) 'red) ((32) 'green) ((33) 'yellow)
+          ((34) 'blue) ((35) 'magenta) ((36) 'cyan) ((37) 'white)
+          ((39) '/color)
+          (else #f)))
+      (define (collect from to res)
+        (if (string-cursor<? from to)
+            (cons (substring-cursor str from to) res)
+            res))
+      (define (finish)
+        (let ((ls (reverse (collect from to res))))
+          (if (and (= 1 (length ls)) (string? (car ls)))
+              (car ls)
+              (let lp1 ((ls ls) (cur '()) (res '()))
+                (define (close to)
+                  (let lp2 ((ls cur) (tmp '()))
+                    (cond
+                     ((null? ls)
+                      (list '() `(,@(reverse tmp) ,@res)))
+                     ((eq? to (car ls))
+                      (list (cdr ls) `((,to ,@tmp) ,@res)))
+                     ((and (eq? to 'color) (memq (car ls) '(b i u s)))
+                      ;; color close came to an open non-color
+                      ;; back off and leave this open
+                      (let ((s `(,(car ls) ,@(take-while string? tmp)))
+                            (tmp (drop-while string? tmp)))
+                        (list `(,@(reverse tmp) ,@(reverse s)) res)))
+                     ((symbol? (car ls))
+                      (lp2 (cdr ls) `((,(car ls) ,@(reverse tmp)))))
+                     ((and (pair? (car ls)) (eq? 'color to))
+                      (lp2 (cdr ls) `((,@(car ls) ,@(reverse tmp)))))
+                     ((pair? (car ls))
+                      (lp2 (cdr ls) `(,(car ls) ,@(reverse tmp))))
+                     (else
+                      (lp2 (cdr ls) `(,(car ls) ,@tmp))))))
+                (cond
+                 ((null? ls)
+                  `(span ,@(reverse (cadr (close #f)))))
+                 ((and (string? (car ls)) (pair? cur))
+                  (lp1 (cdr ls) (cons (car ls) cur) res))
+                 ((string? (car ls))
+                  (lp1 (cdr ls) cur (cons (car ls) res)))
+                 (else
+                  (case (car ls)
+                    ((b i u s) (lp1 (cdr ls) (cons (car ls) cur) res))
+                    ((/b) (apply lp1 (cdr ls) (close 'b)))
+                    ((/i) (apply lp1 (cdr ls) (close 'i)))
+                    ((/u) (apply lp1 (cdr ls) (close 'u)))
+                    ((/s) (apply lp1 (cdr ls) (close 's)))
+                    ((/) (apply lp1 (cdr ls) (close 'all)))
+                    ((/color) (apply lp1 (cdr ls) (close 'color)))
+                    (else
+                     (let ((style (string-append "color:"
+                                                 (symbol->string (car ls)))))
+                       (lp1 (cdr ls)
+                            (cons `(span (@ (style . ,style))) cur)
+                            res))))))))))
+      (if (string-cursor>=? to end)
+          (finish)
+          (let ((c (string-cursor-ref str to))
+                (sc2 (string-cursor-next str to)))
+            (if (and (= 27 (char->integer c))
+                     (string-cursor<? sc2 end)
+                     (eqv? #\[ (string-cursor-ref str sc2)))
+                (let ((sc3 (string-cursor-next str sc2)))
+                  (let lp2 ((sc4 sc3))
+                    (if (string-cursor>=? sc4 end)
+                        (finish)
+                        (let ((c2 (string-cursor-ref str sc4))
+                              (sc5 (string-cursor-next str sc4)))
+                          (if (eqv? #\m c2)
+                              (let ((code (lookup
+                                           (substring-cursor str sc3 sc4)))
+                                    (res (collect from to res)))
+                                (lp1 sc5 sc5 (if code (cons code res) res)))
+                              (lp2 sc5))))))
+                (lp1 from sc2 res)))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;;> Extract the literate Scribble docs for module \var{mod-name} and
@@ -274,14 +363,25 @@
          (force (or (env-ref env 'example-env) (current-environment)))))
     `(div
       ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
-      (code
-       (div (@ (class . "result"))
-            ,(call-with-output-string
-               (lambda (out)
-                 (protect (exn (#t (print-exception exn out)))
-                   (let ((res (eval expr example-env)))
-                     (display "=> " out)
-                     (write res out))))))))))
+      ,(let* ((res-out (open-output-string))
+              (tmp-out (open-output-string))
+              (tmp-err (open-output-string))
+              (res (parameterize ((current-output-port tmp-out)
+                                  (current-error-port tmp-err))
+                     (protect (exn (#t (print-exception exn tmp-err)))
+                       (eval expr example-env)))))
+         (display "=> " res-out)
+         (write res res-out)
+         (let ((res-str (get-output-string res-out))
+               (out-str (get-output-string tmp-out))
+               (err-str (get-output-string tmp-err)))
+           `(,@(if (string-null? out-str)
+                   '()
+                   `((div (@ (class . "output")) ,(ansi->sxml out-str))))
+             ,@(if (string-null? err-str)
+                   '()
+                   `((div (@ (class . "error")) ,(ansi->sxml err-str))))
+             (div (@ (class . "result")) (code ,res-str))))))))
 
 (define (expand-example-import x env)
   (eval `(import ,@(cdr x))
@@ -385,6 +485,8 @@ div#main  {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
 div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
 div#footer {padding-bottom: 50px}
 .result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
+.output { color: #000; background-color: beige; width: 100%; padding: 3px}
+.error { color: #000; background-color: #330000; width: 100%; padding: 3px}
 .command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
 "
                  ,(highlight-style))
diff --git a/lib/chibi/doc.sld b/lib/chibi/doc.sld
index 69538e52..492808e7 100644
--- a/lib/chibi/doc.sld
+++ b/lib/chibi/doc.sld
@@ -1,7 +1,7 @@
 
 (define-library (chibi doc)
   (import
-   (except (chibi) eval) (scheme eval) (srfi 1) (srfi 95)
+   (except (chibi) eval) (scheme eval) (srfi 1) (srfi 39) (srfi 95)
    (chibi modules) (chibi ast) (chibi io) (chibi match)
    (chibi time) (chibi filesystem) (chibi process) (chibi pathname)
    (chibi string) (chibi scribble) (chibi sxml) (chibi highlight)
@@ -11,5 +11,6 @@
           generate-docs expand-docs fixup-docs
           extract-module-docs extract-module-file-docs extract-file-docs
           make-default-doc-env make-module-doc-env
-          get-optionals-signature)
+          get-optionals-signature
+          ansi->sxml)
   (include "doc.scm"))