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

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

Chgd sort. Rmvd 1st class env routines.

File size: 14.6 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;; - Use of Unit lolevel 'global-' routines is just wrong when an
8;; evaluation-environment (##sys#environment?) is not the
9;; interaction-environment.
10;;
11;; - Doesn't show something similar to procedure-information for macros.
12;;
13;; - Runtime macros?
14;;
15;; - Should be re-written to use the "environments" extension. Which in turn would
16;; need to support syntactic environments, at least for lookup opertations.
17;;
18;; - The Chicken 'environment' object does not hold the (syntactic) bindings
19;; for all syntactic keywords from the R5RS. The public API of 'apropos'
20;; attempts to hide this fact.
21
22;;; Prelude
23
24(declare
25  (usual-integrations)
26  #;(disable-interrupts)
27  (fixnum)
28  (inline)
29  (local)
30  (no-procedure-checks)
31  (bound-to-procedure
32    ##sys#qualified-symbol? ##sys#symbol->qualified-string ##sys#qualified-symbol-prefix
33    ##sys#symbol->string
34    ##sys#current-environment ##sys#macro-environment
35    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
36    ##sys#environment? ##sys#environment-symbols
37    ##sys#signal-hook))
38
39;;
40
41(cond-expand
42  (unsafe
43    (include "chicken-primitive-object-inlines") )
44  (else ) )
45
46;; Argument Checking
47
48(define-inline (%check-search-pattern loc obj argnam)
49  (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
50    (error-invalid-search loc obj argnam) ) )
51
52(define-inline (%check-environment loc obj argnam)
53  (unless (or (##sys#environment? obj) (##sys#syntactic-environment? obj))
54    (error-invalid-environment loc obj argnam) ) )
55
56(define-inline (%check-environment* loc obj argnam)
57  (cond ((##sys#environment? obj) #f)
58        ((##sys#syntactic-environment? obj) obj)
59        (else
60          (error-invalid-environment loc obj argnam) ) ) )
61
62(define-inline (%check-sort-argument loc obj)
63  (unless (or (eq? #:name obj) (eq? #:kind obj))
64    (error-invalid-sort loc obj) ) )
65
66;;;
67
68#;(require-library regex lolevel data-structures extras srfi-13 csi)
69
70(module apropos (;export
71  ; Original
72  apropos apropos-list apropos-information-list
73  ; Crispy
74  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
75  ; Extra Crispy
76  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
77
78(import scheme chicken regex lolevel data-structures extras srfi-13 csi)
79
80;;; Support
81
82;; Errors
83
84(define (error-argument-type loc obj kndnam #!optional argnam)
85  (##sys#signal-hook
86    #:type-error
87    loc
88    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
89    obj) )
90
91(define (error-invalid-search loc obj argnam)
92  (error-argument-type loc obj "symbol/string/regexp" argnam) )
93
94(define (error-invalid-environment loc obj argnam)
95  (error-argument-type loc obj 'environment argnam) )
96
97(define (error-invalid-sort loc obj)
98  (error-argument-type loc obj "#:name or #:kind" #:sort) )
99
100;; Symbols
101
102(define (symbol<? x y)
103  (cond-expand
104    (unsafe
105      (%string<? (%symbol-string x) (%symbol-string y)) )
106    (else
107      (let ((x (##sys#symbol->string x))
108            (y (##sys#symbol->string y))
109            (px (##sys#qualified-symbol-prefix x))
110            (py (##sys#qualified-symbol-prefix y)))
111        (cond (px (and py (string<? px py) (string<? x y)))
112              (py (or (not px) (and (string<? px py) (string<? x y))))
113              (else (string<? x y) ) ) ) ) ) )
114
115(define (symbol-print-length sym)
116  (cond-expand
117    (unsafe
118      (let ((siz (%string-size (%symbol-string sym))))
119              ; assumes keyword style is not #:none
120        (cond ((%keyword? sym) siz)
121              ; compensate for the '##'
122              ((%qualified-symbol? sym) (%fx+ siz 2))
123              ; plain old string
124              (else siz) ) ) )
125    (else
126      (let ([len (string-length (##sys#symbol->qualified-string sym))])
127        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
128            len ) ) ) ) )
129
130(define (max-symbol-print-width syms)
131  (let ((maxlen 0))
132    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
133    maxlen ) )
134
135(define (symbol-match? sym regexp)
136  (cond-expand
137    (unsafe
138      (string-search regexp (%symbol-string sym)) )
139    (else
140      (string-search regexp (symbol->string sym)) ) ) )
141
142;; Environment Search
143
144(define (*apropos-list/environment loc regexp env macenv? qualified?)
145
146  (define (search-environment/searcher searcher pred)
147    (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
148
149  (define (search-environment)
150    (search-environment/searcher
151      ##sys#environment-symbols
152      (if qualified? global-bound?
153          (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) )
154
155  (define (search-macro-environment)
156    (search-environment/searcher
157      ##sys#syntactic-environment-symbols
158      (if qualified? any?
159          (lambda (x) (not (##sys#qualified-symbol? x))))) )
160
161  (if macenv? (search-macro-environment) (search-environment)) )
162
163; => (envsyms . macenvsyms)
164(define (*apropos-list loc regexp env macenv qualified?)
165  (append
166    (*apropos-list/environment loc regexp env #f qualified?)
167    (if (not macenv) '()
168        (*apropos-list/environment loc regexp macenv macenv qualified?))) )
169
170;; Argument List Parsing
171
172(define default-environment interaction-environment)
173(define default-macro-environment ##sys#macro-environment)
174
175(define (make-apropos-regexp patt)
176  (when (symbol? patt) (set! patt (symbol->string patt)))
177  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
178  patt )
179
180; => (values args val)
181(define (keyword-argument args kwd #!optional val)
182  (let loop ((iargs args) (oargs '()))
183    (if (null? args) (values (reverse oargs) val)
184        (let ((arg (car args)))
185          (cond ((eq? kwd arg)
186                  (set! val (cadr args))
187                  (loop (cddr iargs) oargs) )
188                (else
189                  (loop (cdr iargs) (cons arg oargs)) ) ) ) ) ) )
190
191; => (values args sort)
192(define (parse-sort-argument loc args)
193  (receive (args sort) (keyword-argument args #:sort #:name)
194    (%check-sort-argument loc sort)
195    (values args sort) ) )
196
197; #!optional (env (default-environment)) macenv
198; #!key macros? qualified?
199;
200; macenv is #t for default macro environment or a syntactic-environment object.
201;
202; => (values syms macenv)
203
204(define (parse-arguments loc patt args)
205
206  (define (parse-rest-arguments)
207    (let ((env (default-environment))
208          (macenv #f)
209          (qualified? #f)
210          (1st-optarg #t)) ;keyword argument not considered an optional argument here
211      (let loop ((args args))
212        (if (null? args) (values env macenv qualified?)
213            (let ((arg (car args)))
214                    ;keyword argument?
215              (cond ((eq? #:macros? arg)
216                      (when (cadr args) (set! macenv (default-macro-environment)))
217                      (loop (cddr args)) )
218                    ((eq? #:qualified? arg)
219                      (when (cadr args) (set! qualified? #t))
220                      (loop (cddr args)) )
221                    ;optional argument?
222                    (arg
223                           ;specific environment?
224                      (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
225                            ;default macro environment?
226                            ((boolean? args) (set! macenv (default-macro-environment)))
227                            ;specific macro environment?
228                            (else (set! macenv arg)))
229                      (loop (cdr args)) )
230                    ;accept #f for macenv
231                    (else
232                      (loop (cdr args)) ) ) ) ) ) ) )
233
234  (%check-search-pattern loc patt 'pattern)
235  (receive (env macenv qualified?) (parse-rest-arguments)
236    (%check-environment loc env 'environment)
237    (when macenv (%check-environment loc macenv #:macros?))
238    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
239
240#|
241; => (values envsyms macenv)
242
243(define (parse-arguments/environment loc patt env qualified?)
244  (%check-search-pattern loc patt 'pattern)
245  (let ((macenv (%check-environment* loc env 'environment)))
246    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
247
248; #!key qualified? sort?
249;
250; => (... (macenv . syms) ...)
251
252(define (parse-arguments/environments loc patt args)
253
254  (define (parse-rest-arguments)
255    (let ((qualified? #f))
256      (let loop ((args args) (envs '()))
257        (if (null? args) (values (reverse envs) qualified?)
258            (let ((arg (car args)))
259              (cond ((eq? #:qualified? arg)
260                      (when (cadr args) (set! qualified? #t))
261                      (loop (cddr args) envs) )
262                    (else
263                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
264
265  (%check-search-pattern loc patt 'pattern)
266  (receive (envs qualified?) (parse-rest-arguments)
267    (let ((regexp (make-apropos-regexp patt)))
268      (let loop ((envs envs) (envsyms '()))
269        (if (null? envs) (reverse envsyms)
270            (let* ((env (car envs))
271                   (macenv (%check-environment* loc env 'environment))
272                   (make-envsyms
273                    (lambda ()
274                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
275              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
276|#
277
278;; Display
279
280; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
281(define (apropos-procedure-information proc)
282  (let ((info (procedure-information proc)))
283    (cond ((not info) 'procedure)
284          ((pair? info) `(procedure . ,(cdr info)))
285          (else `(procedure . ,(symbol->string info))) ) ) )
286
287; => 'macro | 'keyword | 'variable | <procedure-information>
288(define (apropos-information sym macenv)
289  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
290        ((keyword? sym) 'keyword)
291        (else
292          (let ((binding (global-ref sym)))
293            (if (procedure? binding) (apropos-procedure-information binding)
294                'variable ) ) ) ) )
295
296(define (*apropos-information-list syms macenv)
297  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
298
299(define (display-spaces cnt)
300  (do ((i cnt (sub1 i)))
301      ((negative? i))
302    (display #\space) ) )
303
304(define (display-apropos syms macenv sort)
305  (let ((maxsymlen (max-symbol-print-width syms))
306        (lessp
307          (case sort
308            ((#:name)
309              (lambda (pr1 pr2) (symbol<? (car pr1) (car pr2))) )
310            ((#:kind)
311              (lambda (pr1 pr2)
312                (let ((s1 (car pr1)) (s2 (car pr2)))
313                  (symbol<? (if (symbol? s1) s1 (car s1)) (if (symbol? s2) s2 (car s2)))))))) )
314
315    (define (display-symbol-information apr)
316      (let ((sym (car apr))
317            (info (cdr apr)))
318        (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
319        (display #\space)
320        (if (symbol? info) (display info)
321            (begin (display (car info)) (display #\space) (write (cdr info)) ) )
322      (newline) ) )
323
324    (for-each
325      (cut display-symbol-information <>)
326      (sort (*apropos-information-list syms macenv) lessp)) ) )
327
328;;; API
329
330;; Original
331
332(define (apropos patt . args)
333  (receive (args sort) (parse-sort-argument 'apropos args)
334    (receive (syms macenv) (parse-arguments 'apropos patt args)
335      (display-apropos syms macenv sort) ) ) )
336
337(define (apropos-list patt . args)
338  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
339    syms ) )
340
341(define (apropos-information-list patt . args)
342  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
343    (*apropos-information-list syms macenv) ) )
344
345;; Crispy
346
347#|
348==== apropos/environment
349
350<procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure>
351
352Displays information about identifiers matching {{PATTERN}} in the
353{{ENVIRONMENT}}.
354
355Like {{apropos}}.
356
357; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}.
358
359==== apropos-list/environment
360
361<procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
362
363Like {{apropos-list}}.
364
365==== apropos-information-list/environment
366
367<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
368
369Like {{apropos-information-list}}.
370
371(define (apropos/environment patt env #!key qualified? (sort #:name))
372  (%check-sort-argument 'apropos/environment sort)
373  (receive (syms macenv)
374           (parse-arguments/environment 'apropos/environment patt env qualified?)
375    (newline)
376    (display-apropos syms macenv sort) ) )
377
378(define (apropos-list/environment patt env #!key qualified?)
379  (receive (syms macenv)
380           (parse-arguments/environment 'apropos/environment patt env qualified?)
381    syms ) )
382
383(define (apropos-information-list/environment patt env #!key qualified?)
384  (receive (syms macenv)
385           (parse-arguments/environment 'apropos/environment patt env qualified?)
386    (*apropos-information-list syms macenv) ) )
387
388;; Extra Crispy
389
390==== apropos/environments
391
392<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
393
394Displays information about identifiers matching {{PATTERN}} in each
395{{ENVIRONMENT}}.
396
397Like {{apropos}}.
398
399; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
400
401==== apropos-list/environments
402
403<procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
404
405
406Like {{apropos-list}}.
407
408==== apropos-information-list/environments
409
410<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
411
412Like {{apropos-information-list}}.
413
414(define (apropos/environments patt . args)
415  (receive (args sort) (parse-sort-argument 'apropos/environments args)
416    (let ((i 0))
417      (for-each
418        (lambda (macenv+syms)
419          (set! i (add1 i))
420          (newline) (print "** Environment " i " **") (newline)
421          (display-apropos (cdr macenv+syms) (car macenv+syms) sort) )
422        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
423
424(define (apropos-list/environments patt . args)
425  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
426
427(define (apropos-information-list/environments patt . args)
428  (map
429    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
430    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
431|#
432
433;;;
434
435(when (feature? csi:)
436  (toplevel-command 'a
437    (lambda () (apropos (string-trim-both (read-line))))
438    " ,a PATT ...       Apropos identifier") )
439
440) ;module apropos
Note: See TracBrowser for help on using the repository browser.