Add new script to find undocumented symbols.

1 files changed, 146 insertions, 0 deletions

diff --git a/module/scripts/find-undocumented.scm b/module/scripts/find-undocumented.scm
new file mode 100644
index 00000000..127baa74
--- /dev/null
+++ b/module/scripts/find-undocumented.scm
@@ -0,0 +1,146 @@
+(define-module (scripts find-undocumented)
+  :use-module (srfi srfi-1)
+  :use-module (hnh module-introspection all-modules)
+  :use-module (hnh util)
+  :use-module (hnh util path)
+  :use-module (ice-9 format)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 rdelim)
+  :use-module (rnrs records syntactic)
+  :export (main)
+  )
+
+(define %summary "Find all uncodumented exported declaration in a project.")
+
+(define %synopsis "find-undocumented <srcdir> <docdir>")
+
+;; (define %help "")
+
+(define texinfo-definition-forms
+ '(("deffn" _ name ...)
+   ("deftp" _ name ...)
+   ("defun" name ...)
+   ("defmac" name ...)
+   ("defspec" name ...)
+   ("deftypefn" _ _ name ...)
+   ("deftypefun" _ name ...)
+   ("defvr" _ name)
+   ("defvar" name)
+   ("defopt" name)
+   ("deftypevr" _ _ name)
+   ("deftypevar" _ name)
+   ("deftp" _ name ...)
+   ("defcv" _ _ name)
+   ("deftypecv" _ _ name)
+   ("defivar" _ name)
+   ("deftypeivar" _ _ name)
+   ("defop" _ _ name ...)
+   ("deftypeop" _ _ _ name ...)
+   ("defmethod" _ name ...)
+   ("deftypemethod" _ _ name ...)))
+
+(define (command cmd) (format #f "@ *(~a)x?" cmd))
+(define parameter "(\\{(@\\}|[^}])+\\}|[^ \t]+)")
+(define rest ".*")
+(define regexpes
+  (for form in texinfo-definition-forms
+       (list
+        form
+        (string-concatenate
+         (intersperse
+          "[ \t]*"
+          (for (idx symbol) in (enumerate form)
+               (cond ((string? symbol)  (command symbol))
+                     ((eq? '_ symbol)   parameter)
+                     ((eq? '... symbol) rest)
+                     ((symbol? symbol)  parameter)
+                     (else (scm-error 'misc-error "" "" '() #f)))))))))
+
+(define rxs
+  (for (name rx) in regexpes
+       (list name
+             (make-regexp
+              (format #f "^ *~a" rx)
+              regexp/newline))))
+
+
+(define-record-type doc-definition
+  (fields symbol type file line))
+
+(define (cmp a b)
+  (eq?
+   (doc-definition-symbol a)
+   (doc-definition-symbol b)))
+
+(define (print-header msg)
+  (define middle (format #f "= ~a =" msg))
+  (define side (make-string (string-length middle) #\=))
+  (format #t "~a~%~a~%~a~%" side middle side))
+
+(define (print-doc-definition def)
+  (display (symbol->string (doc-definition-symbol def)))
+  (cond ((doc-definition-file def)
+         => (lambda (it)
+              (display "\t(")
+              (display it)
+              (cond ((doc-definition-line def)
+                     => (lambda (it)
+                          (display " ")
+                          (display it))))
+              (display ")"))))
+  (newline))
+
+(define (main . args)
+  (define source-directory "module")
+  (define doc-dir "doc/ref")
+
+  (define documented-symbols
+    (concatenate
+     (for file in (all-files-under-directory doc-dir ".texi")
+          (let ((content (call-with-input-file file read-string)))
+            (concatenate
+             (for (form rx) in rxs
+                  (for m in (list-matches rx content)
+                       (make-doc-definition
+                        (-> m
+                            (match:substring
+                             ;; Weird offsets to account for how matching groups work
+                             (* 2 (1+ (list-index (lambda (x) (eqv? x 'name))
+                                                  (cdr form)))))
+                            (string-trim-both (string->char-set "{}"))
+                            string->symbol)
+                        (string->symbol (match:substring m 1))
+                        file
+                        (1+ (string-count (match:prefix m) (char-set #\newline)))
+                        ))))))))
+
+  (define defined-symbols
+    (concatenate
+     (for path in (all-modules-under-directory source-directory)
+          (define components* (drop (path-split path) (length (path-split source-directory))))
+          (define name
+            (map string->symbol
+                 (append (drop-right components* 1)
+                         (list (basename (last components*) ".scm")))))
+          (catch 'misc-error
+            (lambda ()
+              (cond ((resolve-interface name)
+                     => (lambda (module) (map (lambda (symb) (make-doc-definition symb #f path #f))
+                                         (module-map (lambda (k v) k) module))))
+                    (else
+                     (format (current-error-port) "~s is not a module~%" name)
+                     '())))
+            (lambda (err proc fmt args data)
+              (format (current-error-port) "Failed loading ~s: (~a) ~?~%" name proc fmt args)
+              '())))))
+
+
+  (print-header "Documented functions without (or with private) definitions:")
+  (for-each print-doc-definition (lset-difference cmp documented-symbols defined-symbols))
+  (newline)
+
+  (print-header "Defined symbols without documentation:")
+  (for-each print-doc-definition (lset-difference cmp defined-symbols documented-symbols))
+
+  (newline)
+  )