source: project/release/4/apropos/tags/1.0.0/apropos.scm @ 13795

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

Save.

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