Initial commit

docs/docread/default.nix

@@ -0,0 +1,10 @@
+{ pkgs, eggDerivation, chickenPackages }:
+eggDerivation {
+  name = "docread";
+  src = ./.;
+
+  buildInputs = with chickenPackages.chickenEggs; [
+    r7rs
+    (pkgs.callPackage ../../core {})
+  ];
+}

docs/docread/docread.egg

@@ -0,0 +1,9 @@
+((version "0.0.1")
+ (synopsis "read doc comments")
+ (author "puck")
+ (dependencies r7rs zilch)
+ (component-options 
+  (csc-options "-X" "r7rs" "-R" "r7rs" "-optimize-level" "3"))
+ (components
+  (program docread
+   (source "docread.scm"))))

docs/docread/docread.scm

@@ -0,0 +1,88 @@
+(import (scheme base) (scheme file) (scheme write) (chicken read-syntax) (chicken process-context) (chicken irregex) (chicken format) (chicken process) (chicken file) (zilch zexpr))
+
+;; Return a string version of the passed-in val, but properly quoted as s-expression.
+(define (quotify val)
+  (call-with-port (open-output-string) (lambda (port) (write val port) (get-output-string port))))
+
+;; Read a file, and rewrite all doc comments (comments starting with ";;") with comment s-expressions.
+(define (read-file-with-rewritten-comments f)
+  (define port (open-input-file f))
+  (define str-out (open-output-string))
+  (write-string "(\n" str-out)
+  (do ((buf (string) (read-string 2048 port))) ((eof-object? buf) #f) (write-string buf str-out))
+  (close-input-port port)
+  (write-string "\n)" str-out)
+  (define comments-fixed
+    (irregex-replace/all
+      ; Written weirdly to avoid the regexp catching itself.
+      ; TODO(puck): only apply at the start of lines?
+      (string->irregex ";{2,} *([^\\n]*)" 'm)
+      (get-output-string str-out)
+
+      ;; TODO: do we need the space here? this could also be a reader macro instead.
+      (lambda (m) (string-append " " (quotify (list 'comment (irregex-match-substring m 1)))))))
+  (call-with-port (open-input-string comments-fixed) (lambda (port) (read port))))
+
+;; Iterate over the contents of a define-library, and collect comments on certain defines.
+(define (parse-library-contents contents lib-comments)
+    (define comments '())
+    (define defines '())
+    (define imports '())
+    (define exports '())
+
+    (for-each (lambda (j)
+                  (cond
+                   ;; Track imports and exports respectively.
+                   ((eq? (car j) 'import) (set! imports (append (cdr j) imports)))
+                   ((eq? (car j) 'export) (set! exports (append (cdr j) exports)))
+                   
+                   ((eq? (car j) 'begin)
+                    ; For each top-level object in the (begin) block...
+                    (for-each (lambda (i)
+                                  (cond
+                                   ; If we see a preprocessed comment, collect it
+                                   ((and (list? i) (eq? (car i) 'comment)) (set! comments (cons (cadr i) comments)))
+                                   
+                                   ; If we then see either a define or a define-record-type, emit the comments.
+                                   ((and (list? i) (or (eq? (car i) 'define) (eq? (car i) 'define-record-type)))
+                                    (if (list? (cadr i))
+                                        ; TODO(puck): bad code
+                                        (set! defines (cons (cons (car (cadr i)) (cons (cadr i) (reverse comments))) defines))
+                                        (set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines)))
+                                    (set! comments '()))))
+                              (cdr j)))))
+              contents)
+    
+    (define out-path (string-append root "/docs/modules/generated/pages"))
+    (define first #t)
+    (for-each (lambda (l) (set! out-path (string-append out-path (if first "/" ".") (symbol->string l))) (set! first #f)) (car contents))
+    (set! out-path (string-append out-path ".adoc"))
+
+    (define out-file (open-output-file out-path))
+    ; Print out the comments
+    (fprintf out-file "= `~S`\n" (car contents))
+    (for-each (lambda (l) (fprintf out-file "~A\n" l)) lib-comments)
+    (fprintf out-file "\n:toc:\n\n")
+    (for-each (lambda (i)
+                  (define val (assoc i defines))
+                  (unless (eq? val #f)
+                          (fprintf out-file "== `+~S+`\n" (cadr val))
+                          (for-each (lambda (l) (fprintf out-file "~A\n" l)) (cddr val))
+                          (fprintf out-file "\n")))
+              exports)
+    (close-output-port out-file))
+
+(define root (call-with-input-pipe "git rev-parse --show-toplevel" (lambda (p) (define path (read-string 9999999 p)) (string-copy path 0 (- (string-length path) 1)))))
+
+(define (parse-file contents)
+    (define comments '())
+    (for-each (lambda (j)
+                  (cond ((eq? (car j) 'define-library) (parse-library-contents (cdr j) (reverse comments)))
+                        ((eq? (car j) 'comment) (set! comments (cons (cadr j) comments))))) contents))
+
+
+(define (process-file fname _)
+  (parse-file (read-file-with-rewritten-comments fname)))
+     
+
+(find-files root #:test ".*\\.(sld|scm)" #:action process-file)