Subject: [PATCH] doc-snarf: Add support for (ice-9 optargs) define*s.

From: Leo Prikler <[email-masked]>
Date: Sun, 18 Oct 2020 01:50:49 +0200

* module/scripts/doc-snarf.scm (supported-languages)[scheme]: Limit
signature start to define and define*.
(peek-sexp): New variable.
(find-std-int-doc): Implement in terms of peek-sexp.
(parse-entry, make-prototype, get-symbol): Use full function definition
instead of def-line.
(snarf): Adjust accordingly.
(join-symbols): Removed variable.
(parse-defun): New variable.
---
 module/scripts/doc-snarf.scm | 141 +++++++++++++++++++++--------------
 1 file changed, 86 insertions(+), 55 deletions(-)

diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm
index fa3dfb312..3dd714d9e 100644
--- a/module/scripts/doc-snarf.scm
+++ b/module/scripts/doc-snarf.scm
@@ -152,7 +152,7 @@ This procedure foos, or bars, depending on the argument @var{braz}.
      "^;;\\."
      "^;; (.*)"
      "^;;-(.*)"
-     "^\\(define"
+     "^\\(define(\\*)?( |$)"
      #t
      )))
 
@@ -178,6 +178,14 @@ This procedure foos, or bars, depending on the argument @var{braz}.
   (write-output (snarf input lang) output
                 (if texinfo? format-texinfo format-plain)))
 
+;; Read an s-expression from @var{port}, then rewind it, so that it can be
+;; read again.
+(define (peek-sexp port)
+  (let* ((pos (ftell port))
+         (sexp (read port)))
+    (seek port pos SEEK_SET)
+    sexp))
+
 ;; fixme: this comment is required to trigger standard internal
 ;; docstring snarfing...  ideally, it wouldn't be necessary.
 ;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
@@ -185,7 +193,8 @@ This procedure foos, or bars, depending on the argument @var{braz}.
   "Unread @var{line} from @var{input-port}, then read in the entire form and
 return the standard internal docstring if found.  Return #f if not."
   (unread-string line input-port)       ; ugh
-  (let ((form (read input-port)))
+  (seek input-port -1 SEEK_CUR)         ; ugh^2
+  (let ((form (peek-sexp input-port)))
     (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
                 (< 3 (length form))
                 (eq? 'define (car form))
@@ -270,9 +279,12 @@ return the standard internal docstring if found.  Return #f if not."
 		doc-strings (cons (match:substring m1 1) options) entries
 		(+ lno 1)))
 	   (m2
-            (let ((options (augmented-options line i-p options))) ; ttn-mod
-              (lp (read-line i-p) 'neutral '() '()
-                  (cons (parse-entry doc-strings options line input-file lno)
+            (let* ((options (augmented-options line i-p options)) ; ttn-mod
+                   (def (peek-sexp i-p)))
+              ;; due to the rewind in augmented-options and peek-sexp,
+              ;; we will actually see this line again, so read twice
+              (lp (begin (read-line i-p) (read-line i-p)) 'neutral '() '()
+                  (cons (parse-entry doc-strings options def input-file lno)
                         entries)
                   (+ lno 1))))
            (m3
@@ -295,9 +307,10 @@ return the standard internal docstring if found.  Return #f if not."
 		doc-strings (cons (match:substring m1 1) options) entries
 		(+ lno 1)))
 	   (m2
-            (let ((options (augmented-options line i-p options))) ; ttn-mod
-              (lp (read-line i-p) 'neutral '() '()
-                  (cons (parse-entry doc-strings options line input-file lno)
+            (let* ((options (augmented-options line i-p options)) ; ttn-mod
+                   (def (peek-sexp i-p)))
+              (lp (begin (read-line i-p) (read-line i-p)) 'neutral '() '()
+                  (cons (parse-entry doc-strings options def input-file lno)
                         entries)
                   (+ lno 1))))
 	   (m3
@@ -326,13 +339,13 @@ return the standard internal docstring if found.  Return #f if not."
 
 ;; Create a docstring entry from the docstring line list
 ;; @var{doc-strings}, the option line list @var{options} and the
-;; define line @var{def-line}
-(define (parse-entry docstrings options def-line filename line-no)
+;; definition @var{def}
+(define (parse-entry docstrings options def filename line-no)
 ;  (write-line docstrings)
   (cond
-   (def-line
-     (make-entry (get-symbol def-line)
-		 (make-prototype def-line) (reverse docstrings)
+   (def
+     (make-entry (get-symbol def)
+		 (make-prototype def) (reverse docstrings)
 		 (reverse options) filename
 		 (+ (- line-no (length docstrings) (length options)) 1)))
    ((> (length docstrings) 0)
@@ -347,48 +360,66 @@ return the standard internal docstring if found.  Return #f if not."
 
 ;; Create a string which is a procedure prototype.  The necessary
 ;; information for constructing the prototype is taken from the line
-;; @var{def-line}, which is a line starting with @code{(define...}.
-(define (make-prototype def-line)
-  (call-with-input-string
-   def-line
-   (lambda (s-p)
-     (let* ((paren (read-char s-p))
-	    (keyword (read s-p))
-	    (tmp (read s-p)))
-       (cond
-	((pair? tmp)
-	 (join-symbols tmp))
-	((symbol? tmp)
-	 (symbol->string tmp))
-	(else
-	 ""))))))
-
-(define (get-symbol def-line)
-  (call-with-input-string
-   def-line
-   (lambda (s-p)
-     (let* ((paren (read-char s-p))
-	    (keyword (read s-p))
-	    (tmp (read s-p)))
-       (cond
-	((pair? tmp)
-	 (car tmp))
-	((symbol? tmp)
-	 tmp)
-	(else
-	 'foo))))))
-
-;; Append the symbols in the string list @var{s}, separated with a
-;; space character.
-(define (join-symbols s)
-  (cond ((null? s)
-	 "")
-	((symbol? s)
-	 (string-append ". " (symbol->string s)))
-	((null? (cdr s))
-	 (symbol->string (car s)))
-	(else
-	 (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
+;; @var{def}, which is the full function definition starting with
+;; @code{(define...}.
+(define (make-prototype def)
+  (let ((tmp (false-if-exception (cadr def))))
+    (cond
+     ((pair? tmp) (parse-defun tmp))
+     ((symbol? tmp) (symbol->string tmp))
+     (else ""))))
+
+(define (get-symbol def)
+  (let ((tmp (false-if-exception (cadr def))))
+    (cond
+     ((pair? tmp) (car tmp))
+     ((symbol? tmp) tmp)
+     (else 'foo))))
+
+;; Parse function definition @var{defun}.
+;; This parser accepts the formats
+;; @itemize
+;; @item (name . args)
+;; @item (name arg1 arg2 ...)
+;; @item (name arg1 arg2 ... [#:optional optarg...] [#:key kwarg...] . rest)
+;; @item (name arg1 arg2 ... [#:optional optarg...] [#:key kwarg...] [#:rest rest])
+;; @end itemize
+(define (parse-defun defun)
+  (define (append-arg prototype arg val optional? key?)
+    (string-append prototype
+                   " "
+                   (cond
+                    (optional? "[")
+                    (key? "[#:")
+                    (else ""))
+                   (symbol->string arg)
+                   (if val (string-append "=" (object->string val write)) "")
+                   (if (or optional? key?) "]" "")))
+  (let lp ((prototype (symbol->string (car defun)))
+           (args (cdr defun))
+           (optional? #f)
+           (key? #f))
+    (cond
+     ((null? args) prototype)
+     ((symbol? args)
+      (string-append prototype " . " (symbol->string args)))
+     (else
+      (let ((arg (car args))
+            (rest (cdr args)))
+        (cond
+         ((eq? arg #:optional) (lp prototype rest #t #f))
+         ((eq? arg #:key) (lp prototype rest #f #t))
+         ((eq? arg #:rest)
+          (lp (string-append prototype " .") rest #f #f))
+         ((symbol? arg)
+          (lp (append-arg prototype arg #f optional? key?)
+              rest optional? key?))
+         ((pair? arg)
+          (lp (append-arg prototype (car arg) (cadr arg) optional? key?)
+              rest optional? key?))
+         (else
+          (error "failed to parse ~s: cannot match ~s"
+                 defun arg))))))))
 
 ;; Write @var{entries} to @var{output-file} using @var{writer}.
 ;; @var{writer} is a proc that takes one entry.
-- 
2.28.0