From cdd90c3af5a1a0fcd206293e8c8cb584b575e4f0 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Mon, 4 May 2009 01:05:33 +0200
Subject: PLT: autodoc (without argument positions).

---
 scheme/plt/geiser/utils.ss | 43 ++++++++++++++++++++++++++++---------------
 1 file changed, 28 insertions(+), 15 deletions(-)

(limited to 'scheme/plt/geiser/utils.ss')

diff --git a/scheme/plt/geiser/utils.ss b/scheme/plt/geiser/utils.ss
index 9a774df..258a55d 100644
--- a/scheme/plt/geiser/utils.ss
+++ b/scheme/plt/geiser/utils.ss
@@ -26,24 +26,37 @@
 
 #lang scheme
 
-(provide module-path-name->name)
+(provide module-path-name->name
+         pair->list
+         keyword->symbol)
 
 (require srfi/13)
 
 (define (module-path-name->name path)
-  (if (path? path)
-      (let* ((path (path->string path))
-             (cpaths (map path->string (current-library-collection-paths)))
-             (prefix-len (lambda (p)
-                           (let ((pl (string-length p)))
-                             (if (= pl (string-prefix-length p path)) pl 0))))
-             (lens (map prefix-len cpaths))
-             (real-path (substring path (apply max lens))))
-        (if (absolute-path? real-path)
-            (call-with-values (lambda () (split-path path))
-              (lambda (_ basename __) basename))
-            (regexp-replace "\\.[^./]*$" real-path "")))
-      "<top>"))
-
+  (cond ((path? path)
+         (let* ((path (path->string path))
+                (cpaths (map (compose path->string path->directory-path)
+                             (current-library-collection-paths)))
+                (prefix-len (lambda (p)
+                              (let ((pl (string-length p)))
+                                (if (= pl (string-prefix-length p path)) pl 0))))
+                (lens (map prefix-len cpaths))
+                (real-path (substring path (apply max lens))))
+           (if (absolute-path? real-path)
+               (call-with-values (lambda () (split-path path))
+                 (lambda (_ basename __) (path->string basename)))
+               (regexp-replace "\\.[^./]*$" real-path ""))))
+        ((eq? path '#%kernel) "(kernel)")
+        ((string? path) path)
+        ((symbol? path) (symbol->string path))
+        (else "<top>")))
+
+(define (pair->list pair)
+  (let loop ((d pair) (s '()))
+    (cond ((null? d) (reverse s))
+          ((symbol? d) (reverse (cons d s)))
+          (else (loop (cdr d) (cons (car d) s))))))
+
+(define keyword->symbol (compose string->symbol keyword->string))
 
 ;;; utils.ss ends here
-- 
cgit v1.2.3