source: project/release/4/apropos/trunk/apropos.scm @ 13680

Last change on this file since 13680 was 13680, checked in by Kon Lovett, 11 years ago

Save

File size: 7.0 KB
Line 
1;;;; apropos.scm -*- Hen -*-
2;;;; Kon Lovett, Mar '09
3;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
4
5;; Issues
6;;
7;; - Doesn't show something similar to procedure-information for macros.
8;;
9;; - Runtime macros?
10;;
11;; - Should be re-written to use the "environments" extension. Which in turn would
12;; need to support syntactic environments, at least for lookup opertations.
13
14
15(declare
16  (usual-integrations)
17  (disable-interrupts)
18  (fixnum)
19  (inline)
20  (local)
21  (no-procedure-checks)
22  (bound-to-procedure
23    ##sys#current-environment ##sys#macro-environment
24    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
25    ##sys#environment? ##sys#environment-symbols
26    ##sys#symbol->qualified-string
27    ##sys#signal-hook ) )
28
29
30;;; Prelude
31
32(require-library regex lolevel)
33
34
35;;; Support
36
37;; Errors
38
39(define-inline (%error-invalid-search loc obj)
40  (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" obj) )
41
42(define-inline (%error-invalid-environment loc obj)
43  (##sys#signal-hook #:type-error loc "bad argument type - not an environment" obj) )
44
45(define-inline (%error-invalid-macro-environment loc obj)
46  (##sys#signal-hook #:type-error loc "bad argument type - not a macro environment" obj) )
47
48;; Argument Checking
49
50(define-inline (%check-environment loc obj)
51  (unless (##sys#environment? obj)
52    (%error-invalid-environment loc obj) ) )
53
54(define-inline (%check-macro-environment loc obj)
55  (unless (##sys#syntactic-environment? obj)
56    (%error-invalid-macro-environment loc obj) ) )
57
58(define-inline (%check-search-pattern loc obj)
59  (unless (or (string? obj) (symbol? obj) (regexp? obj))
60    (%error-invalid-search loc patt) ) )
61
62;;;
63
64(module apropos (;export
65  ;
66  apropos
67  apropos-list
68  apropos-information-list
69  ;
70  environment-apropos
71  environment-apropos-list
72  environment-apropos-information-list)
73
74(import scheme chicken regex lolevel)
75
76;;; Suuport
77
78;; Symbols
79
80(define (symbol-string-length sym)
81  (let ((len (string-length (##sys#symbol->qualified-string sym))))
82    (if (keyword? sym)
83        (- len 2) ; compensate for leading '###' when only a ':' is printed
84        len ) ) )
85
86(define (largest-symbol-string-length syms)
87  (let ((maxlen 0))
88    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-string-length sym)))) syms)
89    maxlen ) )
90
91(define (symbol-match? sym regexp) (string-search regexp (symbol->string sym)))
92
93;; Environments
94
95(define (search-environment env regexp pred)
96  (##sys#environment-symbols env (lambda (sym) (and symbol-match? sym regexp) (pred sym))) )
97
98(define (search-macro-environment macenv regexp)
99  (##sys#syntactic-environment-symbols macenv (cut symbol-match? <> regexp)) )
100
101;;
102
103(define (make-apropos-regexp patt)
104  (when (symbol? patt) (set! patt (symbol->string patt)))
105  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
106  patt )
107
108; #!optional (env (interaction-environment)) macenv
109; #!key macros?
110;
111; macenv is #t for (##sys#current-environment) or a syntactic-environment object
112
113(define (parse-rest-arguments args)
114  (let ((env (interaction-environment))
115        (macenv #f)
116        (1st-optarg #t)) ;keyword argument not considered an optional argument here
117    (let loop ((args args))
118      (when (pair? args)
119        (let ((arg (car args)))
120          (cond ((eq? #:macros? arg)
121                 (when (cadr args) (set! macenv (##sys#macro-environment)))
122                 (loop (cddr args)) )
123                (arg
124                 (cond (1st-optarg      ;specific environment
125                        (set! env arg)
126                        (set! 1st-optarg #f) )
127                       ((boolean? args) ;default macro environment
128                        (set! macenv (##sys#current-environment)) )
129                       (else            ;specific macro environment
130                        (set! macenv arg) ) )
131                 (loop (cdr args)) )
132                (else ;accept #f for macenv flag
133                 (loop (cdr args)) ) ) ) )
134    (values env macenv) ) ) )
135
136(define (parse-arguments loc patt args)
137  (%check-search-pattern loc patt)
138  (let-values (((env macenv) (parse-rest-arguments args)))
139    (%check-environment loc env)
140    (%check-macro-environment loc macenv)
141    (values (make-apropos-regexp patt) env macenv) ) )
142
143(define (*apropos-list loc regexp env macenv)
144  (append
145   (search-environment env regexp global-bound?)
146   (if macenv (search-macro-environment macenv regexp) '())) )
147
148(define (*environment-apropos-list loc regexp env)
149  (cond ((##sys#environment? env)           (search-environment env regexp global-bound?))
150        ((##sys#syntactic-environment? env) (search-macro-environment env regexp))
151        (else
152         (%error-invalid-environment 'environment-apropos-list env) ) ) )
153
154;; Display
155
156(define (apropos-procedure-information proc)
157  (let ((info (procedure-information proc)))
158    (if (not info) 'procedure
159        `(procedure . ,(cdr info)) ) ) )
160
161(define (apropos-information sym env macenv)
162  (cond ((macro? sym)   'macro )
163        ((keyword? sym) 'keyword )
164        (else
165         (let ((binding (global-ref sym)))
166           (if (procedure? binding) (apropos-procedure-information proc) )
167               'identifier ) ) ) )
168
169(define (display-spaces cnt)
170  (do ((i cnt (sub1 i)))
171      ((negative? i))
172      (display #\space) ) )
173
174(define (display-symbol-information sym env macenv maxsymlen)
175  (display sym) (display-spaces (- maxsymlen (symbol-string-length sym)))
176  (let ((info (apropos-information sym)))
177    (display #\space)
178    (if (symbol? info) (display info)
179       (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
180  (newline) )
181
182;;; API
183
184;; Original
185
186(define (apropos patt . rest)
187  (let-values (((regexp env macenv) (parse-arguments args)))
188    (let* ((syms (*apropos-list 'apropos regexp env macenv))
189           (maxsymlen (largest-symbol-string-length syms)))
190      (for-each (cut display-symbol-information <> env macenv maxsymlen) syms) ) ) )
191
192(define (apropos-list patt . rest)
193   (let-values (((regexp env macenv) (parse-arguments args)))
194     (*apropos-list 'apropos-list regexp env macenv) ) )
195
196(define (apropos-information-list patt . rest)
197   (let-values (((regexp env macenv) (parse-arguments args)))
198    (map
199     (lambda (sym) (list sym (apropos-information sym)))
200     (*apropos-list 'apropos regexp env macenv)) ) )
201
202;; Crispy
203
204(define (environment-apropos loc regexp env)
205  (let-values (((regexp env macenv) (parse-arguments args)))
206    (let* ((syms (*environment-apropos-list loc regexp env))
207           (maxsymlen (largest-symbol-string-length syms)))
208      (for-each (cut display-symbol-information <> env macenv maxsymlen) syms) ) ) )
209
210(define (environment-apropos-list loc regexp env)
211  (let-values (((regexp env macenv) (parse-arguments args)))
212    (*environment-apropos-list loc regexp env) ) )
213
214(define (environment-apropos-information-list loc regexp env)
215  (let-values (((regexp env macenv) (parse-arguments args)))
216    (map
217     (lambda (sym) (list sym (apropos-information sym)))
218     (*environment-apropos-list loc regexp env)) ) )
219
220) ;module apropos
Note: See TracBrowser for help on using the repository browser.