chibi-scheme/tools/chibi-doc

#! /usr/bin/env chibi-scheme

(import
 (srfi 1) (chibi modules) (chibi ast) (chibi io) (chibi match) (chibi time)
 (chibi filesystem) (chibi scribble) (chibi highlight) (chibi type-inference))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (write-to-string x)
  (call-with-output-string (lambda (out) (write x out))))

(define (string-concatenate-reverse ls)
  (string-concatenate (reverse ls)))

(define (string-scan ch str . o)
  (let ((limit (string-length str)))
    (let lp ((i (if (pair? o) (car o) 0)))
      (cond ((>= i limit) #f)
            ((eqv? ch (string-ref str i)) i)
            (else (lp (+ i 1)))))))

(define (string-split str ch)
  (let ((len (string-length str)))
    (let lp ((from 0) (to 0) (res '()))
      (define (collect) (cons (substring str from to) res))
      (cond ((>= to len) (reverse (collect)))
            ((eqv? ch (string-ref str to)) (lp (+ to 1) (+ to 1) (collect)))
            (else (lp from (+ to 1) res))))))

(define (string-strip str . o)
  (let ((bad (if (pair? o) (car o) " \t\n")))
    (call-with-output-string
      (lambda (out)
        (call-with-input-string str
          (lambda (in)
            (let lp ()
              (let ((ch (read-char in)))
                (cond
                 ((not (eof-object? ch))
                  (if (not (string-scan ch bad))
                      (write-char ch out))
                  (lp)))))))))))

(define (string-first-token str sep)
  (let ((len (string-length str)))
    (let lp ((i 0))
      (cond ((= i len) str)
            ((not (string-scan (string-ref str i) sep)) (lp (+ i 1)))
            (else
             (let lp ((j (+ i 1)))
               (cond ((= j len) "")
                     ((string-scan (string-ref str j) sep) (lp (+ j 1)))
                     (else
                      (let lp ((k (+ j 1)))
                        (cond
                         ((or (= k len) (string-scan (string-ref str k) sep))
                          (substring str j k))
                         (else
                          (lp (+ k 1)))))))))))))

(define (intersperse ls x)
  (if (or (null? ls) (null? (cdr ls)))
      ls
      (let lp ((ls (cdr ls)) (res (list (car ls))))
        (let ((res (cons (car ls) (cons x res))))
          (if (null? (cdr ls))
              (reverse res)
              (lp (cdr ls) res))))))

(define (normalize-sxml x)
  (cond
   ((pair? x)
    (let lp ((ls x) (res '()))
      (cond ((null? ls)
             (string-concatenate-reverse res))
            ((string? (car ls))
             (lp (cdr ls) (cons (car ls) res)))
            ((pair? res)
             (cons (string-concatenate-reverse res)
                   (cons (car ls) (normalize-sxml (cdr ls)))))
            (else
             (cons (car ls) (normalize-sxml (cdr ls)))))))
   (else x)))

(define (map-sxml proc x)
  (if (pair? x)
      (cons (map-sxml proc (car x))  (map-sxml proc (cdr x)))
      (proc x)))

(define (sxml-body x)
  (cond ((not (and (pair? x) (pair? (cdr x)))) '())
        ((and (pair? (cadr x)) (eq? '^ (caadr x))) (cddr x))
        (else (cdr x))))

(define (env-ref env name . o)
  (cond ((assq name (car env)) => cdr)
        ((pair? o) (car o))
        (else #f)))

(define (env-set! env name value)
  (cond ((assq name (car env)) => (lambda (cell) (set-cdr! cell value)))
        (else (set-car! env (cons (cons name value) (car env))))))

(define (env-extend env vars vals)
  (append (map cons vars vals) env))

(define (make-default-env)
  `(((section . ,(expand-section 'h1))
     (subsection . ,(expand-section 'h2))
     (subsubsection . ,(expand-section 'h3))
     (subsubsubsection . ,(expand-section 'h4))
     (centered . center)
     (smaller . small)
     (larger . large)
     (bold . b)
     (italic . i)
     (emph . em)
     (subscript . sub)
     (superscript . sup)
     (itemlist . ul)
     (item . li)
     (var . code)
     (cfun . code)
     (cmacro . code)
     (ctype . code)
     (url . ,expand-url)
     (hyperlink . ,expand-hyperlink)
     (rawcode . code)
     (code . ,expand-code)
     (codeblock . ,expand-codeblock)
     (ccode
      . ,(lambda (x env)
           (expand-code `(,(car x) language: c ,@(cdr x)) env)))
     (ccodeblock
      . ,(lambda (x env)
           (expand-codeblock `(,(car x) language: c ,@(cdr x)) env)))
     (scheme
      . ,(lambda (x env)
           (expand-code `(,(car x) language: scheme ,@(cdr x)) env)))
     (schemeblock
      . ,(lambda (x env)
           (expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)))
     (command . ,expand-command)
     (author . ,expand-author)
     (margin-note . ,expand-note)
     (example . ,expand-example)
     (example-import . ,expand-example-import)
     )))

(define (sxml->sexp-list x)
  (call-with-input-string (sxml-strip x) port->sexp-list))

(define (section-name tag name)
  (string-strip
   (call-with-output-string
     (lambda (out)
       (display tag out)
       (write-char #\_ out)
       (display name out)))))

(define (expand-section tag)
  (lambda (sxml env)
    (let ((body (map (lambda (x) (expand x env)) (cdr sxml))))
      `(div (a (^ (name . ,(section-name tag (sxml-strip (cons tag body))))))
            (,tag ,@body)))))

(define (expand-url sxml env)
  (if (not (= 2 (length sxml)))
      (error "url expects one argument" sxml)
      (let ((url (expand (cadr sxml) env)))
        `(a (^ (href . ,url)) ,url))))

(define (expand-hyperlink sxml env)
  (if (not (= 3 (length sxml)))
      (error "hyperlink expects two arguments" sxml)
      (let ((url (expand (cadr sxml) env))
            (text (expand (caddr sxml) env)))
        `(a (^ (href . ,url)) ,text))))

(define (expand-note sxml env)
  `(div (^ (id . "notes"))
        ,@(map (lambda (x) (expand x env)) (cdr sxml))))

(define (expand-author sxml env)
  `(div (^ (id . "notes"))
        ,@(map (lambda (x) (expand x env)) (cdr sxml))
        (br)
        ,(seconds->string (current-seconds))))

(define (expand-code sxml env)
  (let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
                 (highlighter-for (caddr sxml))
                 highlight))
         (body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
                   (cdddr sxml)
                   (cdr sxml))))
    `(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
                       (normalize-sxml
                        (map (lambda (x) (expand x env)) body))))))

(define (expand-codeblock sxml env)
  `(pre ,(expand-code sxml env)))

(define (expand-example x env)
  (let ((expr `(begin ,@(sxml->sexp-list x)))
        (example-env (or (env-ref env 'example-env) (interaction-environment))))
    `(div
      ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
      (code
       (div (^ (class . "result"))
            ,(call-with-output-string
               (lambda (out)
                 (guard (exn (#t (print-exception exn out)))
                        (let ((res (eval expr example-env)))
                          (display "=> " out)
                          (write res out))))))))))

(define (expand-example-import x env)
  (eval `(import ,@(cdr x))
        (or (env-ref env 'example-env) (interaction-environment)))
  "")

(define (expand-command sxml env)
  `(pre (^ (class . "command"))
        (code ,@(map (lambda (x) (expand x env)) (cdr sxml)))))

(define (expand-tagged tag ls env)
  (cons tag (map (lambda (x) (expand x env)) ls)))

(define (expand sxml env)
  (cond
   ((pair? sxml)
    (cond
     ((symbol? (car sxml))
      (let ((op (env-ref env (car sxml))))
        (cond
         ((procedure? op)
          (op sxml env))
         ((symbol? op)
          (expand-tagged op (cdr sxml) env))
         (else
          (expand-tagged (car sxml) (cdr sxml) env)))))
     (else
      (map (lambda (x) (expand x env)) sxml))))
   (else
    sxml)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define header-index
  (let* ((headers '(h1 h2 h3 h4 h5 h6))
         (len (length headers)))
    (lambda (h) (- len (length (memq h headers))))))

(define (extract-contents x)
  (match x
    (('div ('a ('^ ('name . name)) . _)
           ((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section))
     `((,(header-index h)
        (a (^ (href . ,(string-append "#" name)))
           ,(sxml-strip (cons h section))))))
    ((a . b)
     (append (extract-contents a) (extract-contents b)))
    (else
     '())))

(define (get-contents x)
  (if (null? x)
      '()
      (let ((d (caar x)))
        (let lp ((ls (cdr x)) (parent (cadar x)) (kids '()) (res '()))
          (define (collect)
            (cons `(li ,parent ,(get-contents (reverse kids))) res))
          (cond
           ((null? ls)
            `(ol ,@(reverse (collect))))
           ((> (caar ls) d)
            (lp (cdr ls) parent (cons (car ls) kids) res))
           (else
            (lp (cdr ls) (cadar ls) '() (collect))))))))

(define (fix-header x)
  `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
                       (else '()))
               "\n"
               (style (^ (type . "text/css"))
                 "
body {color: #000; background-color: #FFF}
div#menu  {font-size: smaller; position: absolute; top: 0; left: 0; width: 180px; height: 100%}
div#menu ol {margin-left: 10px; padding-left: 10px}
div#main  {position: absolute; top: 0; left: 200px; width: 520px; height: 100%}
div#notes {position: relative; top: 2em; left: 550px; max-width: 200px; height: 0px; font-size: smaller;}
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
"
                 ,(highlight-style))
               "\n")
         (body
          (div (^ (id . "menu"))
               ,(get-contents (extract-contents x)))
          (div (^ (id . "main"))
               ,@(map (lambda (x)
                        (if (and (pair? x) (eq? 'title (car x)))
                            (cons 'h1 (cdr x))
                            x))
                      x)))))

(define (fix-paragraphs x)
  (let lp ((ls x) (p '()) (res '()))
    (define (collect)
      (if (pair? p) (cons `(p ,@(reverse p)) res) res))
    (define (inline? x)
      (or (string? x)
          (and (pair? x) (symbol? (car x))
               (memq (car x) '(a b i u span code small large sub sup em)))))
    (define (enclosing? x)
      (and (pair? x) (symbol? (car x))
           (memq (car x) '(div body))))
    (cond
     ((null? ls)
      (reverse (collect)))
     ((equal? "\n" (car ls))
      (if (and (pair? p) (equal? "\n" (car p)))
          (let lp2 ((ls (cdr ls)))
            (if (and (pair? ls) (equal? "\n" (car ls)))
                (lp2 (cdr ls))
                (lp ls '() (collect))))
          (lp (cdr ls) (cons (car ls) p) res)))
     ((inline? (car ls))
      (lp (cdr ls) (cons (car ls) p) res))
     ((enclosing? (car ls))
      (lp (cdr ls) '() (cons (car ls) (collect))))
     (else
      (lp (cdr ls) '() (cons (car ls) (collect)))))))

(define (fix-begins x)
  x)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (skip-whitespace in)
  (cond ((char-whitespace? (peek-char in))
         (read-char in)
         (skip-whitespace in))))

(define (external-clause? x)
  (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (caadr x)))))

(define (get-signature proc source form)
  (match form
    (('define (name . args) . body)
     (cons name args))
    (('define-syntax name ('syntax-rules () (clause . body) ...))
     (map (lambda (x) (cons name (cdr x)))
          (filter external-clause? clause)))
    (else
     (or (and (procedure? proc) (procedure-signature proc))
         (procedure-name proc)))))

(define section-number
  (let ((sections '(section subsection subsubsection subsubsubsection)))
    (lambda (x) (length (or (memq x sections) '())))))

(define (section>=? x n)
  (and (pair? x)
       (if (memq (car x) '(div))
           (any (lambda (y) (section>=? y n)) (sxml-body x))
           (>= (section-number (car x)) n))))

(define (extract-sxml tag x)
  (and (pair? x)
       (cond ((eq? tag (car x)) x)
             ((memq (car x) '(div))
              (any (lambda (y) (extract-sxml tag y)) (sxml-body x)))
             (else #f))))

(define (section-describes? x name)
  (and (pair? x) (pair? (cdr x))
       (string-ci=? (string-first-token (sxml-strip (cadr x)) " \t\r\n()#")
                    (symbol->string name))))

(define (insert-signature orig-ls name sig)
  (let lp ((ls orig-ls) (rev-pre '()))
    (cond
     ((or (null? ls) (section>=? (car ls) (section-number 'subsubsubsection)))
      `(,@(reverse rev-pre)
        ,@(if (and (pair? ls)
                   (section-describes?
                    (extract-sxml 'subsubsubsection (car ls))
                    name))
              '()
              `((subsubsubsection
                 (rawcode ,@(intersperse (map write-to-string sig) '(br))))))
        ,@ls))
     (else
      (lp (cdr ls) (cons (car ls) rev-pre))))))

(define (extract-docs file defs res)
  (call-with-input-file file
    (lambda (in)
      (let ((defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdaddr x)))
                       (filter (lambda (x) (equal? file (caaddr x))) defs))))
        (let lp ((lines '()) (cur '()) (res res))
          (define (collect)
            (if (pair? lines)
                (append
                 (reverse
                  (call-with-input-string
                      (string-concatenate (reverse lines) "\n")
                    scribble-parse))
                 cur)
                cur))
          (skip-whitespace in)
          (cond
           ((eof-object? (peek-char in))
            (append (collect) res))
           ((eqv? #\newline (peek-char in))
            (lp lines cur res))
           ((eqv? #\; (peek-char in))
            (read-char in)
            (cond
             ((and (eqv? #\; (peek-char in))
                   (begin (read-char in) (eqv? #\> (peek-char in))))
              (read-char in)
              (if (eqv? #\space (peek-char in)) (read-char in))
              (lp (cons (read-line in) lines) cur res))
             (else
              (read-line in)
              (lp '() (collect) res))))
           (else  ;; found a top-level expression
            (let* ((cur (collect))
                   (line1 (port-line in))
                   (x (read in))
                   (line2 (port-line in))
                   (procs (filter (lambda (x) (<= line1 (caddr x) line2))
                                  (filter caddr defs))))
              (cond
               ((= 1 (length procs))
                (let* ((sig (or (get-signature (caar procs) (cdar procs) x)
                                '()))
                       (res (append (insert-signature cur (caar procs) sig)
                                    res)))
                  (lp '() '() res)))
               (else
                (lp '() '() (append cur res))))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html conversions

(define (html-display-escaped-attr str . o)
  (let ((start 0)
        (end (string-length str))
        (out (if (pair? o) (car o) (current-output-port))))
    (let lp ((from start) (to start))
      (if (>= to end)
          (display (substring str from to) out)
          (let ((c (string-ref str to)))
            (cond
             ((eq? c #\<)
              (display (substring str from to) out)
              (display "&lt;" out)
              (lp (+ to 1) (+ to 1)))
             ((eq? c #\&)
              (display (substring str from to) out)
              (display "&amp;" out)
              (lp (+ to 1) (+ to 1)))
             ((eq? c #\")
              (display (substring str from to) out)
              (display "&quot;" out)
              (lp (+ to 1) (+ to 1)))
             (else
              (lp from (+ to 1)))))))))

(define (html-escape-attr str)
  (call-with-output-string
    (lambda (out) (html-display-escaped-attr str out))))

(define (html-attr->string attr)
  (if (cdr attr)
      (string-append (symbol->string (car attr))
                     "=\"" (html-escape-attr (cdr attr)) "\"")
      (symbol->string (car attr))))

(define (html-tag->string tag attrs)
  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
    (if (null? ls)
        (apply string-append (reverse (cons ">" res)))
        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))

(define (html-display-escaped-string str . o)
  (let ((start 0)
        (end (string-length str))
        (out (if (pair? o) (car o) (current-output-port))))
    (let lp ((from start) (to start))
      (if (>= to end)
          (display (substring str from to) out)
          (let ((c (string-ref str to)))
            (cond
             ((eq? c #\<)
              (display (substring str from to) out)
              (display "&lt;" out)
              (lp (+ to 1) (+ to 1)))
             ((eq? c #\&)
              (display (substring str from to) out)
              (display "&amp;" out)
              (lp (+ to 1) (+ to 1)))
             (else
              (lp from (+ to 1)))))))))

(define (html-escape str)
  (call-with-output-string
    (lambda (out) (html-display-escaped-string str out))))

(define (sxml-display-as-html sxml . o)
  (let ((out (if (pair? o) (car o) (current-output-port))))
    (let lp ((sxml sxml))
      (cond
       ((pair? sxml)
        (let ((tag (car sxml)))
          (if (symbol? tag)
              (let ((rest (cdr sxml)))
                (cond
                 ((and (pair? rest)
                       (pair? (car rest))
                       (eq? '^ (caar rest)))
                  (display (html-tag->string tag (cdar rest)) out)
                  (for-each lp (cdr rest))
                  (display "</" out) (display tag out) (display ">" out))
                 (else
                  (display (html-tag->string tag '()) out)
                  (for-each lp rest)
                  (display "</" out) (display tag out) (display ">" out))))
              (for-each lp sxml))))
       ((null? sxml))
       (else (html-display-escaped-string sxml out))))))

(define (sxml->html sxml . o)
  (call-with-output-string
    (lambda (out) (sxml-display-as-html sxml out))))

(define (sxml-strip sxml)
  (call-with-output-string
    (lambda (out)
      (let strip ((x sxml))
        (cond
         ((pair? x)
          (for-each
           strip
           (if (and (pair? (cdr x)) (eq? '^ (cadr x))) (cddr x) (cdr x))))
         ((string? x)
          (display x out)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (output doc)
  (sxml-display-as-html
   (fix-header (fix-paragraphs (fix-begins (expand doc (make-default-env)))))))

(define (convert in)
  (output (scribble-parse in)))

(define (object-source x)
  (cond ((opcode? x) #f)
        ((bytecode? x) (bytecode-source x))
        ((procedure? x) (bytecode-source (procedure-code x)))
        ((macro? x) (macro-source x))
        (else #f)))

(define (extract mod-name)
  (let* ((mod (load-module mod-name))
         (exports (module-exports mod))
         (defs (map (lambda (x) `(,(car x) ,(cdr x) ,(object-source (cdr x))))
                    (filter (lambda (x) (or (procedure? (cdr x)) (macro? (cdr x))))
                            (map (lambda (x) (cons x (module-ref mod-name x)))
                                 exports)))))
    (let lp ((includes (module-includes mod))
             (res `((title ,(write-to-string mod-name)))))
      (if (null? includes)
          (output (reverse res))
          (lp (cdr includes) (extract-docs (car includes) defs res))))))

(define (main args)
  (case (length args)
    ((0)
     (convert (current-input-port)))
    ((1)
     (cond
      ((equal? "-" (car args))
       (convert (current-input-port)))
      ((file-exists? (car args))
       (call-with-input-file (car args) convert))
      (else
       (extract (map (lambda (x) (or (string->number x) (string->symbol x)))
                     (string-split (car args) #\.))))))
    (else
     (error "usage: chibi-doc [<file-or-module-name>]"))))