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

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

Added csi command. Better sorting, arg chck.

File size: 16.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  (cond-expand
50    (unsafe
51      (unless (or (%keyword? obj) (%symbol? obj) (%string? obj) (regexp? obj))
52        (error-invalid-search loc obj argnam) ) )
53    (else
54      (unless (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj))
55        (error-invalid-search loc obj argnam) ) ) ) )
56
57#; ;UNUSED
58(define-inline (%check-environment* loc obj argnam)
59  (cond ((##sys#environment? obj) #f)
60        ((##sys#syntactic-environment? obj) obj)
61        (else
62          (error-invalid-environment loc obj argnam) ) ) )
63
64(define-inline (%check-sortkey-argument loc obj)
65  (unless (or (not obj) (eq? #:name obj) (eq? #:kind obj))
66    (error-invalid-sortkey loc obj) ) )
67
68;;;
69
70(require-library regex lolevel data-structures ports extras utils srfi-13)
71
72(module apropos (;export
73  ; Original
74  apropos apropos-list apropos-information-list
75  ; Crispy
76  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
77  ; Extra Crispy
78  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
79
80(import scheme chicken regex lolevel data-structures ports extras utils srfi-13 csi)
81
82;;; Support
83
84;; Errors
85
86(define (error-argument-type loc obj kndnam #!optional argnam)
87  (##sys#signal-hook
88    #:type-error
89    loc
90    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
91    obj) )
92
93(define (error-invalid-search loc obj argnam)
94  (error-argument-type loc obj "symbol/string/regexp" argnam) )
95
96#; ;UNUSED
97(define (error-invalid-environment loc obj argnam)
98  (error-argument-type loc obj 'environment argnam) )
99
100(define (error-invalid-sortkey loc obj)
101  (error-argument-type loc obj "#:name, #:kind or #f" #:sort) )
102
103(define (error-invalid-argument loc arg)
104  (if (keyword? arg) (error loc "unrecognized keyword argument" arg)
105      (error loc "unrecognized argument" arg) ) )
106
107;; Symbols
108
109(define (symbol->keyword sym)
110  (if (keyword? sym) sym
111      (string->keyword (symbol->string sym)) ) )
112
113(define (symbol=? x y)
114  (cond-expand
115    (unsafe
116      (%string=? (%symbol-string x) (%symbol-string y)) )
117    (else
118      (let ((sx (##sys#symbol->string x))
119            (sy (##sys#symbol->string y))
120            (px (##sys#qualified-symbol-prefix x))
121            (py (##sys#qualified-symbol-prefix y)))
122        (cond (px (and py (string=? px py) (string=? sx sy)))
123              (py (or (not px) (and (string=? px py) (string=? sx sy))))
124              (else (string=? sx sy) ) ) ) ) ) )
125
126(define (symbol<? x y)
127  (cond-expand
128    (unsafe
129      (%string<? (%symbol-string x) (%symbol-string y)) )
130    (else
131      (let ((sx (##sys#symbol->string x))
132            (sy (##sys#symbol->string y))
133            (px (##sys#qualified-symbol-prefix x))
134            (py (##sys#qualified-symbol-prefix y)))
135        (cond (px (and py (string<? px py) (string<? sx sy)))
136              (py (or (not px) (and (string<? px py) (string<? sx sy))))
137              (else (string<? sx sy) ) ) ) ) ) )
138
139(define (symbol-print-length sym)
140  (cond-expand
141    (unsafe
142      (let ((siz (%string-size (%symbol-string sym))))
143              ; assumes keyword style is not #:none
144        (cond ((%keyword? sym) siz)
145              ; compensate for the '##'
146              ((%qualified-symbol? sym) (%fx+ siz 2))
147              ; plain old string
148              (else siz) ) ) )
149    (else
150      (let ([len (string-length (##sys#symbol->qualified-string sym))])
151        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
152            len ) ) ) ) )
153
154(define (max-symbol-print-width syms)
155  (let ((maxlen 0))
156    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
157    maxlen ) )
158
159(define (symbol-match? sym regexp)
160  (cond-expand
161    (unsafe
162      (string-search regexp (%symbol-string sym)) )
163    (else
164      (string-search regexp (symbol->string sym)) ) ) )
165
166;; Environment Search
167
168(define (*apropos-list/environment loc regexp env macenv? qualified?)
169
170  (define (search-environment/searcher searcher pred)
171    (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
172
173  (define (search-environment)
174    (search-environment/searcher
175      ##sys#environment-symbols
176      (if qualified? global-bound?
177          (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) )
178
179  (define (search-macro-environment)
180    (search-environment/searcher
181      ##sys#syntactic-environment-symbols
182      (if qualified? any?
183          (lambda (x) (not (##sys#qualified-symbol? x))))) )
184
185  (if macenv? (search-macro-environment) (search-environment)) )
186
187; => (envsyms . macenvsyms)
188(define (*apropos-list loc regexp env macenv qualified?)
189  (append
190    (*apropos-list/environment loc regexp env #f qualified?)
191    (if (not macenv) '()
192        (*apropos-list/environment loc regexp macenv #t qualified?))) )
193
194;; Argument List Parsing
195
196(define default-environment interaction-environment)
197(define default-macro-environment ##sys#macro-environment)
198
199(define (make-apropos-regexp patt)
200  (when (symbol? patt) (set! patt (symbol->string patt)))
201  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
202  patt )
203
204; => (values val args)
205(define (keyword-argument args kwd #!optional val)
206  (let loop ((args args) (oargs '()))
207    (if (null? args) (values val (reverse oargs))
208        (let ((arg (car args)))
209          (cond ((eq? kwd arg)
210                  (set! val (cadr args))
211                  (loop (cddr args) oargs) )
212                (else
213                  (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
214
215; => (values sortkey args)
216(define (parse-sortkey-argument loc args)
217  (receive (sortkey args) (keyword-argument args #:sort #:kind)
218    (%check-sortkey-argument loc sortkey)
219    (values sortkey args) ) )
220
221; #!optional (env (default-environment)) macenv
222; #!key macros? qualified?
223;
224; macenv is #t for default macro environment or a syntactic-environment object.
225;
226; => (values syms macenv)
227
228(define (parse-arguments loc patt args)
229
230  ; => (values env macenv qualified?)
231  (define (parse-rest-arguments)
232    (let ((env (default-environment))
233          (macenv #f)
234          (qualified? #f)
235          (1st-arg? #t))
236      (let loop ((args args))
237        (if (null? args) (values env macenv qualified?)
238            (let ((arg (car args)))
239                    ;keyword argument?
240              (cond ((eq? #:macros? arg)
241                      (when (cadr args) (set! macenv (default-macro-environment)))
242                      (loop (cddr args)) )
243                    ((eq? #:qualified? arg)
244                      (when (cadr args) (set! qualified? #t))
245                      (loop (cddr args)) )
246                    ;environment argument?
247                    (1st-arg?
248                      (unless (##sys#environment? arg)
249                        (error-invalid-argument loc arg) )
250                      (set! 1st-arg? #f)
251                      (set! env arg)
252                      (loop (cdr args)) )
253                    ;unkown argument
254                    (else
255                      (error-invalid-argument loc arg) ) ) ) ) ) ) )
256
257  (%check-search-pattern loc patt 'pattern)
258  (receive (env macenv qualified?) (parse-rest-arguments)
259    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
260
261#|
262; => (values envsyms macenv)
263
264(define (parse-arguments/environment loc patt env qualified?)
265  (%check-search-pattern loc patt 'pattern)
266  (let ((macenv (%check-environment* loc env 'environment)))
267    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
268
269; #!key qualified? sort?
270;
271; => (... (macenv . syms) ...)
272
273(define (parse-arguments/environments loc patt args)
274
275  (define (parse-rest-arguments)
276    (let ((qualified? #f))
277      (let loop ((args args) (envs '()))
278        (if (null? args) (values (reverse envs) qualified?)
279            (let ((arg (car args)))
280                    ;keyword argument?
281              (cond ((eq? #:qualified? arg)
282                      (when (cadr args) (set! qualified? #t))
283                      (loop (cddr args) envs) )
284                    ;environment argument?
285                    (else
286                      (unless (##sys#environment? arg)
287                        (error-invalid-argument loc arg) )
288                      (loop (cdr args) (cons env envs)) ) ) ) ) ) ) )
289
290  (%check-search-pattern loc patt 'pattern)
291  (receive (envs qualified?) (parse-rest-arguments)
292    (let ((regexp (make-apropos-regexp patt)))
293      (let loop ((envs envs) (envsyms '()))
294        (if (null? envs) (reverse envsyms)
295            (let* ((env (car envs))
296                   (macenv (%check-environment* loc env 'environment))
297                   (make-envsyms
298                    (lambda ()
299                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
300              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
301|#
302
303;; Display
304
305; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
306(define (apropos-procedure-information proc)
307  (let ((info (procedure-information proc)))
308    (cond ((not info) 'procedure)
309          ((pair? info) `(procedure . ,(cdr info)))
310          (else `(procedure . ,(symbol->string info))) ) ) )
311
312; => 'macro | 'keyword | 'variable | <procedure-information>
313(define (apropos-information sym macenv)
314  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
315        ((keyword? sym) 'keyword)
316        (else
317          (let ((binding (global-ref sym)))
318            (if (procedure? binding) (apropos-procedure-information binding)
319                'variable ) ) ) ) )
320
321(define (*apropos-information-list syms macenv)
322  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
323
324(define (display-spaces cnt)
325  (do ((i cnt (sub1 i)))
326      ((zero? i))
327    (display #\space) ) )
328
329(define (apropos-information-name<? apr1 apr2)
330  (symbol<? (car apr1) (car apr2)) )
331
332(define (apropos-information-kind=? apr1 apr2)
333  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
334    (symbol=? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
335
336(define (apropos-information-kind<? apr1 apr2)
337  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
338    (symbol<? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
339
340(define (apropos-information<? apr1 apr2)
341  (if (apropos-information-kind=? apr1 apr2) (apropos-information-name<? apr1 apr2)
342      (apropos-information-kind<? apr1 apr2) ) )
343
344(define (display-apropos syms macenv sortkey)
345  (let ((maxsymlen (max-symbol-print-width syms)))
346
347    (define (display-symbol-information apr)
348      (let ((sym (car apr)))
349        (display sym) (display #\space) (display-spaces (- maxsymlen (symbol-print-length sym))) )
350      (display #\space)
351      (let ((info (cdr apr)))
352        (cond ((symbol? info) (display info) )
353              (else (display (car info)) (display #\space) (write (cdr info)) ) ) )
354      (newline) )
355
356    (let ((lessp
357            (case sortkey
358              ((#:name) apropos-information-name<? )
359              ((#:kind) apropos-information<? )
360              (else     #f ) ) )
361          (ail (*apropos-information-list syms macenv)))
362      (for-each display-symbol-information (if lessp (sort ail lessp) ail)) ) ) )
363
364;;; API
365
366;; Original
367
368(define (apropos patt . args)
369  (receive (sortkey args) (parse-sortkey-argument 'apropos args)
370    (receive (syms macenv) (parse-arguments 'apropos patt args)
371      (display-apropos syms macenv sortkey) ) ) )
372
373(define (apropos-list patt . args)
374  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
375    syms ) )
376
377(define (apropos-information-list patt . args)
378  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
379    (*apropos-information-list syms macenv) ) )
380
381;; Crispy
382
383#|
384==== apropos/environment
385
386<procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure>
387
388Displays information about identifiers matching {{PATTERN}} in the
389{{ENVIRONMENT}}.
390
391Like {{apropos}}.
392
393; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}.
394
395==== apropos-list/environment
396
397<procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
398
399Like {{apropos-list}}.
400
401==== apropos-information-list/environment
402
403<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
404
405Like {{apropos-information-list}}.
406
407(define (apropos/environment patt env #!key qualified? (sort #:name))
408  (%check-sortkey-argument 'apropos/environment sort)
409  (receive (syms macenv)
410           (parse-arguments/environment 'apropos/environment patt env qualified?)
411    (newline)
412    (display-apropos syms macenv sortkey) ) )
413
414(define (apropos-list/environment patt env #!key qualified?)
415  (receive (syms macenv)
416           (parse-arguments/environment 'apropos/environment patt env qualified?)
417    syms ) )
418
419(define (apropos-information-list/environment patt env #!key qualified?)
420  (receive (syms macenv)
421           (parse-arguments/environment 'apropos/environment patt env qualified?)
422    (*apropos-information-list syms macenv) ) )
423
424;; Extra Crispy
425
426==== apropos/environments
427
428<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
429
430Displays information about identifiers matching {{PATTERN}} in each
431{{ENVIRONMENT}}.
432
433Like {{apropos}}.
434
435; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
436
437==== apropos-list/environments
438
439<procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
440
441
442Like {{apropos-list}}.
443
444==== apropos-information-list/environments
445
446<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
447
448Like {{apropos-information-list}}.
449
450(define (apropos/environments patt . args)
451  (receive (sortkey args) (parse-sortkey-argument 'apropos/environments args)
452    (let ((i 0))
453      (for-each
454        (lambda (macenv+syms)
455          (set! i (add1 i))
456          (newline) (print "** Environment " i " **") (newline)
457          (display-apropos (cdr macenv+syms) (car macenv+syms) sortkey) )
458        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
459
460(define (apropos-list/environments patt . args)
461  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
462
463(define (apropos-information-list/environments patt . args)
464  (map
465    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
466    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
467|#
468
469;;;
470
471(define (parse-csi-apropos-arguments args)
472  (let loop ((args args) (oargs '()))
473    (if (null? args) (reverse oargs)
474        (let ((arg (car args)))
475          (case arg
476            ((macros)
477              (loop (cdr args) (cons #t (cons #:macros? oargs))) )
478            ((qualified)
479              (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
480            ((sort)
481              (let* ((val (cadr args))
482                     (key (if (symbol? val) (symbol->keyword val) val)))
483                (loop (cddr args) (cons key (cons #:sort oargs))) ) )
484            (else
485              (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
486
487(when (feature? csi:)
488  (toplevel-command 'a
489    (lambda ()
490      (apply apropos
491        (parse-csi-apropos-arguments
492          (with-input-from-string (string-trim-both (read-line)) read-file))) )
493    ",a PATT [ARG...]  Apropos of PATT with ARG from macros, qualified, or sort name/#f") )
494
495) ;module apropos
Note: See TracBrowser for help on using the repository browser.