summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-06-18 13:40:54 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-06-18 13:40:54 +0200
commitf7b672621bc80c93c3788bc99ce850f4edc50aaa (patch)
treefc2c87172e02e0f1ad69ad43a9b03365013e11b8
parentce3ef41414442b345e5e8d9f064f0d7531addea5 (diff)
downloadgeiser-chez-f7b672621bc80c93c3788bc99ce850f4edc50aaa.tar.gz
geiser-chez-f7b672621bc80c93c3788bc99ce850f4edc50aaa.tar.bz2
Guile: filtering gensym names in autodoc display.
-rw-r--r--scheme/guile/geiser/doc.scm24
-rw-r--r--scheme/guile/geiser/modules.scm14
-rw-r--r--scheme/guile/geiser/utils.scm12
3 files changed, 28 insertions, 22 deletions
diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
index 982af95..85bf4d4 100644
--- a/scheme/guile/geiser/doc.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -38,11 +38,14 @@
(and args (signature name args))))
(define (signature id args-list)
+ (define (rem-gensyms args)
+ (map (lambda (s) (if (gensym? s) '_
+ (if (list? s) (rem-gensyms s) s))) args))
(define (arglst args kind)
(let ((args (assq-ref args kind)))
- (cond ((or (not args) (null? args)) '())
- ((list? args) args)
- (else (list args)))))
+ (rem-gensyms (cond ((or (not args) (null? args)) '())
+ ((list? args) args)
+ (else (list args))))))
(define (mkargs as)
`((required ,@(arglst as 'required))
(optional ,@(arglst as 'optional)
@@ -80,24 +83,19 @@
(else #f))))
(define (arity->args art)
+ (define (gen-arg-names count)
+ (map (lambda (x) '_) (iota (max count 0))))
(let ((req (car art))
(opt (cadr art))
(rest (caddr art)))
`(,@(if (> req 0)
- (list (cons 'required (gen-arg-names 1 req)))
+ (list (cons 'required (gen-arg-names req)))
'())
,@(if (> opt 0)
- (list (cons 'optional (gen-arg-names (+ 1 req) opt)))
+ (list (cons 'optional (gen-arg-names opt)))
'())
,@(if rest (list (cons 'rest 'rest)) '()))))
-(define (gen-arg-names fst count)
- (let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\t)))
- (len (vector-length letts))
- (lett (lambda (n) (vector-ref letts (modulo n len)))))
- (map (lambda (n) (string->symbol (format "~A" (lett (- n 1)))))
- (iota (max count 1) fst))))
-
(define (arglist->args arglist)
`((required . ,(car arglist))
(optional . ,(cadr arglist))
@@ -173,7 +171,7 @@
(with-output-to-string
(lambda ()
(let* ((type (cond ((macro? obj) "A macro")
- ((procedure? obj) "A procedure")
+ ((procedure? obj) "A procedure")
((program? obj) "A compiled program")
(else "An object")))
(modname (symbol-module sym))
diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm
index 6f499dd..7ca18c9 100644
--- a/scheme/guile/geiser/modules.scm
+++ b/scheme/guile/geiser/modules.scm
@@ -25,7 +25,7 @@
(define (module-name? module-name)
(and (list? module-name)
- (> (length module-name) 0)
+ (not (null? module-name))
(every symbol? module-name)))
(define (symbol-module sym . all)
@@ -67,13 +67,13 @@
(define (all-modules)
(define (maybe-name m)
- (let ((name (format "~A" (module-name m))))
- (and (not (string-match "^[(]#[{]" name)) name)))
+ (let ((name (module-name m)))
+ (and (not (gensym? (car name)))
+ (format "~A" name))))
(let* ((guile (resolve-module '(guile)))
- (roots (remove (lambda (m) (eq? m guile)) (root-modules))))
- (cons "(guile)"
- (filter-map maybe-name
- (apply append (map all-child-modules roots))))))
+ (roots (remove (lambda (m) (eq? m guile)) (root-modules)))
+ (children (append-map all-child-modules roots)))
+ (cons "(guile)" (filter-map maybe-name children))))
(define* (all-child-modules mod #:optional (seen '()))
(let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod))))
diff --git a/scheme/guile/geiser/utils.scm b/scheme/guile/geiser/utils.scm
index b047e6c..01dfaa0 100644
--- a/scheme/guile/geiser/utils.scm
+++ b/scheme/guile/geiser/utils.scm
@@ -1,6 +1,6 @@
;;; utils.scm -- utility functions
-;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
@@ -13,7 +13,9 @@
#:export (make-location
symbol->object
pair->list
- sort-symbols!))
+ sort-symbols!
+ gensym?)
+ #:use-module (ice-9 regex))
(define (symbol->object sym)
(and (symbol? sym)
@@ -35,4 +37,10 @@
(string<? (symbol->string l) (symbol->string r)))))
(sort! syms cmp)))
+(define (gensym? sym)
+ (and (symbol? sym) (gensym-name? (format "~A" sym))))
+
+(define (gensym-name? name)
+ (and (string-match "^#[{]" name) #t))
+
;;; utils.scm ends here