From ab13b7ff828f1f510f66f1b5d712e03a42b85ac0 Mon Sep 17 00:00:00 2001
From: Peter <craven@gmx.net>
Date: Mon, 2 May 2016 11:03:30 +0200
Subject: Chez: add rudimentary autodoc support

---
 scheme/chez/geiser/geiser.ss | 49 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 48 insertions(+), 1 deletion(-)

(limited to 'scheme/chez/geiser')

diff --git a/scheme/chez/geiser/geiser.ss b/scheme/chez/geiser/geiser.ss
index 3dbed7f..2fa648c 100644
--- a/scheme/chez/geiser/geiser.ss
+++ b/scheme/chez/geiser/geiser.ss
@@ -52,8 +52,55 @@
               (substring? prefix el))
             (map write-to-string (library-list))))
 
+  (define (procedure-parameter-list p)
+    ;; same as (inspect object), then hitting c
+    (let ((s (((inspect/object p) 'code) 'source)))
+      (if s
+          (let ((form (s 'value)))
+            (if (and (list? form)
+                     (> (length form) 2)
+                     (eq? (car form) 'lambda))
+                (cadr form)
+                #f))
+          #f)))
+
+  (define (operator-arglist operator)
+    (let ((binding (eval operator)))
+      (if binding
+          (let ((arglist (procedure-parameter-list binding)))
+            (let loop ((arglist arglist)
+                       (optionals? #f)
+                       (required '())
+                       (optional '()))
+              (cond ((null? arglist)
+                     `(,operator ("args" (("required" ,@(reverse required))
+                                          ("optional" ,@(reverse optional))
+                                          ("key")
+                                          ;; ("module" ,module)
+                                          ))))
+                    ((symbol? arglist)
+                     (loop '()
+                           #t
+                           required
+                           (cons "..." (cons arglist optional))))
+                    (else
+                     (loop
+                      (cdr arglist)
+                      optionals?
+                      (if optionals? required (cons (car arglist) required))
+                      (if optionals? (cons (car arglist) optional) optional))))))
+          '())))
+
   (define (geiser:autodoc ids . rest)
-    '())
+    (cond ((null? ids) '())
+          ((not (list? ids))
+           (geiser:autodoc (list ids)))
+          ((not (symbol? (car ids)))
+           (geiser:autodoc (cdr ids)))
+          (else
+           (map (lambda (id)
+                  (operator-arglist id))
+                ids))))
 
   (define (geiser:no-values)
     #f)
-- 
cgit v1.2.3