1 files changed, 31 insertions, 0 deletions
diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
index e2fdaca..f446fde 100644
--- a/scheme/guile/geiser/doc.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -32,6 +32,7 @@
   #:use-module (system vm program)
   #:use-module (ice-9 session)
   #:use-module (ice-9 documentation)
+  #:use-module (ice-9 regex)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1))
 
@@ -108,6 +109,7 @@
    ((procedure-property proc 'arglist) => arglist->args)
    ((procedure-source proc) => source->args)
    ((program? proc) ((@ (system vm program) program-arguments) proc))
+   ((doc->args (object-documentation proc)))
    ((procedure-property proc 'arity) => arity->args)
    (else #f)))
 
@@ -139,6 +141,35 @@
     (keyword . ,(caddr arglist))
     (rest . ,(car (cddddr arglist)))))
 
+(define (doc->args doc)
+  (define proc-rx "-- Scheme Procedure: ([^[\n]+)\n")
+  (define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[\n]+]+)?)")
+  (and doc
+       (let ((match (or (string-match proc-rx doc) (string-match proc-rx2 doc))))
+         (and match (parse-signature-string (match:substring match 1))))))
+
+(define (parse-signature-string str)
+  (define opt-arg-rx "\\[([^] ]+)\\]?")
+  (define opt-arg-rx2 "([^ ])+\\]+")
+  (let ((tokens (string-tokenize str)))
+    (if (< (length tokens) 2)
+        '()
+        (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
+          (cond ((null? tokens) `((required ,@(map string->symbol (reverse! req)))
+                                  (optional ,@(map string->symbol (reverse! opt)))
+                                  ,@(if rest
+                                        (list (cons 'rest (string->symbol rest)))
+                                        '())))
+                ((string=? "." (car tokens))
+                 (if (not (null? (cdr tokens)))
+                     (loop (cddr tokens) req opt (cadr tokens))
+                     (loop '() req opt "rest")))
+                ((or (string-match opt-arg-rx (car tokens))
+                     (string-match opt-arg-rx2 (car tokens)))
+                 => (lambda (m)
+                      (loop (cdr tokens) req (cons (match:substring m 1) opt) rest)))
+                (else (loop (cdr tokens) (cons (car tokens) req) opt rest)))))))
+
 (define (generic-args gen)
   (define (src> src1 src2)
     (> (length (cadr src1)) (length (cadr src2))))