summaryrefslogtreecommitdiff
path: root/scheme/plt/geiser/utils.ss
diff options
context:
space:
mode:
Diffstat (limited to 'scheme/plt/geiser/utils.ss')
-rw-r--r--scheme/plt/geiser/utils.ss43
1 files changed, 28 insertions, 15 deletions
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