mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

(help): Use provided?' instead of feature?'.

Browse source 
Factor "TYPE not found for X" output into internal proc.
Support `(quote SYMBOL)'; call `search-documentation-files'.
(help-doc): If initial search fails, try using
`search-documentation-files'.
(apropos-fold-accessible, apropos-fold-all): Use `identity'
instead of `(lambda (x) x)'.  "An identity edit", ha ha.
This commit is contained in:
Thien-Thi Nguyen 2001-05-18 17:05:06 +00:00
parent adcbdb1687
commit de25f281fd
1 changed files with 119 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

101
ice-9/session.scm
View file

@ -33,39 +33,57 @@
Prints useful information. Try `(help)'." Prints useful information. Try `(help)'."
(cond ((not (= (length exp) 2)) (cond ((not (= (length exp) 2))
(help-usage)) (help-usage))
((not (feature? 'regex)) ((not (provided? 'regex))
(display "`help' depends on the `regex' feature. (display "`help' depends on the `regex' feature.
You don't seem to have regular expressions installed.\n")) You don't seem to have regular expressions installed.\n"))
(else (else
(let ((name (cadr exp))) (let ((name (cadr exp))
(cond ((symbol? name) (not-found (lambda (type x)
(simple-format #t "No ~A found for ~A\n"
type x))))
(cond
;; SYMBOL
((symbol? name)
(help-doc name (help-doc name
(string-append "^" (simple-format
(regexp-quote #f "^~A$"
(symbol->string name)) (regexp-quote (symbol->string name)))))
"$")))
;; "STRING"
((string? name) ((string? name)
(help-doc name name)) (help-doc name name))
;; (unquote SYMBOL)
((and (list? name) ((and (list? name)
(= (length name) 2) (= (length name) 2)
(eq? (car name) 'unquote)) (eq? (car name) 'unquote))
(let ((doc (object-documentation (local-eval (cadr name) (cond ((object-documentation
env)))) (local-eval (cadr name) env))
(if (not doc) => write-line)
(simple-format #t "No documentation found for ~S\n" (else (not-found 'documentation (cadr name)))))
(cadr name))
(write-line doc)))) ;; (quote SYMBOL)
((and (list? name)
(= (length name) 2)
(eq? (car name) 'quote)
(symbol? (cadr name)))
(cond ((search-documentation-files (cadr name))
=> write-line)
(else (not-found 'documentation (cadr name)))))
;; (SYM1 SYM2 ...)
((and (list? name) ((and (list? name)
(and-map symbol? name) (and-map symbol? name)
(not (null? name)) (not (null? name))
(not (eq? (car name) 'quote))) (not (eq? (car name) 'quote)))
(let ((doc (module-commentary name))) (cond ((module-commentary name)
(if (not doc) => (lambda (doc)
(simple-format
#t "No commentary found for module ~S\n" name)
(begin
(display name) (write-line " commentary:") (display name) (write-line " commentary:")
(write-line doc))))) (write-line doc)))
(else (not-found 'commentary name))))
;; unrecognized
(else (else
(help-usage))) (help-usage)))
*unspecified*)))))) *unspecified*))))))
@ -104,23 +122,15 @@ You don't seem to have regular expressions installed.\n"))
(name cadr) (name cadr)
(doc caddr) (doc caddr)
(type cadddr)) (type cadddr))
(if (null? entries) (cond ((not (null? entries))
;; no matches
(begin
(display "Did not find any object ")
(simple-format #t
(if (symbol? term)
"named `~A'\n"
"matching regexp \"~A\"\n")
term))
(let ((first? #t) (let ((first? #t)
(undocumented-entries '()) (undocumented-entries '())
(documented-entries '()) (documented-entries '())
(documentations '())) (documentations '()))
(for-each (lambda (entry) (for-each (lambda (entry)
(let ((entry-summary (simple-format #f (let ((entry-summary (simple-format
"~S: ~S\n" #f "~S: ~S\n"
(module-name (module entry)) (module-name (module entry))
(name entry)))) (name entry))))
(if (doc entry) (if (doc entry)
@ -129,15 +139,16 @@ You don't seem to have regular expressions installed.\n"))
(cons entry-summary documented-entries)) (cons entry-summary documented-entries))
;; *fixme*: Use `describe' when we have GOOPS? ;; *fixme*: Use `describe' when we have GOOPS?
(set! documentations (set! documentations
(cons (simple-format #f (cons (simple-format
"`~S' is ~A in the ~S module.\n\n~A\n" #f "`~S' is ~A in the ~S module.\n\n~A\n"
(name entry) (name entry)
(type entry) (type entry)
(module-name (module entry)) (module-name (module entry))
(doc entry)) (doc entry))
documentations))) documentations)))
(set! undocumented-entries (set! undocumented-entries
(cons entry-summary undocumented-entries))))) (cons entry-summary
undocumented-entries)))))
entries) entries)
(if (and (not (null? documented-entries)) (if (and (not (null? documented-entries))
@ -145,7 +156,8 @@ You don't seem to have regular expressions installed.\n"))
(not (null? undocumented-entries)))) (not (null? undocumented-entries))))
(begin (begin
(display "Documentation found for:\n") (display "Documentation found for:\n")
(for-each (lambda (entry) (display entry)) documented-entries) (for-each (lambda (entry) (display entry))
documented-entries)
(set! first? #f))) (set! first? #f)))
(for-each (lambda (entry) (for-each (lambda (entry)
@ -161,7 +173,20 @@ You don't seem to have regular expressions installed.\n"))
(set! first? #f) (set! first? #f)
(newline)) (newline))
(display "No documentation found for:\n") (display "No documentation found for:\n")
(for-each (lambda (entry) (display entry)) undocumented-entries))))))) (for-each (lambda (entry) (display entry))
undocumented-entries)))))
((search-documentation-files term)
=> (lambda (doc)
(write-line "Documentation from file:")
(write-line doc)))
(else
;; no matches
(display "Did not find any object ")
(simple-format #t
(if (symbol? term)
"named `~A'\n"
"matching regexp \"~A\"\n")
term)))))
(define (help-usage) (define (help-usage)
(display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
@ -318,7 +343,7 @@ It is an image under the mapping EXTRACT."
(define-public (apropos-fold-accessible module) (define-public (apropos-fold-accessible module)
(make-fold-modules (lambda () (list module)) (make-fold-modules (lambda () (list module))
module-uses module-uses
(lambda (x) x))) identity))
(define (root-modules) (define (root-modules)
(cons the-root-module (cons the-root-module
@ -338,7 +363,7 @@ It is an image under the mapping EXTRACT."
(make-fold-modules root-modules submodules module-public-interface)) (make-fold-modules root-modules submodules module-public-interface))
(define-public apropos-fold-all (define-public apropos-fold-all
(make-fold-modules root-modules submodules (lambda (x) x))) (make-fold-modules root-modules submodules identity))
(define-public (source obj) (define-public (source obj)
(cond ((procedure? obj) (procedure-source obj)) (cond ((procedure? obj) (procedure-source obj))
@ -396,3 +421,5 @@ It is an image under the mapping EXTRACT."
(set-system-module! m s) (set-system-module! m s)
(string-append "Module " (symbol->string (module-name m)) (string-append "Module " (symbol->string (module-name m))
" is now a " (if s "system" "user") " module.")))))) " is now a " (if s "system" "user") " module."))))))
;;; session.scm ends here