source: project/release/5/apropos/trunk/apropos-api.scm @ 38625

Last change on this file since 38625 was 38625, checked in by Kon Lovett, 5 months ago

add imported (visible) vs oblist (defined), sort then uniq macro syms

File size: 26.8 KB
Line 
1;;;; apropos-api.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Oct '17
4;;;; Kon Lovett, Mar '09
5;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
6
7;; Issues
8;;;
9;; - Use of 'global-symbol' routines is just wrong when an
10;; evaluation-environment (##sys#environment?) is not the
11;; interaction-environment.
12;;
13;; - Doesn't show something similar to procedure-information for macros. And
14;; how could it.
15;;
16;; - Could be re-written to use the "environments" extension. Which in turn would
17;; need to support syntactic environments, at least for lookup opertations.
18;;
19;; - The Chicken 'environment' object does not hold the (syntactic) bindings
20;; for any syntactic keywords from the R5RS. The public API of 'apropos'
21;; attempts to hide this fact.
22
23(module apropos-api
24
25(;export
26  check-apropos-number-base
27  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
28  apropos-default-base apropos-interning apropos-default-options
29  ;
30  apropos apropos-list apropos-information-list)
31
32(import scheme)
33(import (chicken base))
34(import (chicken foreign))
35(import (chicken syntax))
36(import (chicken keyword))
37(import (chicken sort))
38(import (chicken type))
39(import (only (srfi 1) any reverse! append! last-pair))
40(import (only (srfi 13)
41  string-index string-join string-trim-both
42  string-contains string-contains-ci))
43(import (only (chicken irregex)
44  sre->irregex irregex irregex?
45  irregex-num-submatches irregex-search irregex-match irregex-match-data?
46  irregex-match-num-submatches irregex-replace))
47(import (only memoized-string make-string+))
48(import (only symbol-name-utils
49  symbol->keyword symbol-printname=?
50  symbol-printname<? symbol-printname-length max-symbol-printname-length))
51(import (only type-checks check-fixnum define-check+error-type))
52(import (only type-errors define-error-type error-argument-type))
53(import symbol-environment-access)
54(import symbol-access)
55
56;;;
57
58;;
59
60;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
61(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))
62
63(define *tab-width* 2)
64
65;for our purposes
66(define-constant CHICKEN-MAXIMUM-BASE 16)
67
68;; irregex extensions
69
70(define (irregex-submatches? mt #!optional ire)
71  (and
72    (irregex-match-data? mt)
73    (or
74      (not ire)
75      (=
76        (irregex-match-num-submatches mt)
77        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
78
79;; String
80
81(define (string-match? str patt)
82  (irregex-search patt str) )
83
84(define (string-exact-match? str patt)
85  (string-contains str patt) )
86
87(define (string-ci-match? str patt)
88  (string-contains-ci str patt) )
89
90;; Symbols
91
92#; ;UNUSED
93(define (symbol-match? sym patt)
94  (string-match? (symbol->string sym) patt) )
95
96#; ;UNUSED
97(define (symbol-exact-match? sym patt)
98  (string-exact-match? (symbol->string sym) patt) )
99
100#; ;UNUSED
101(define (symbol-ci-match? sym patt)
102  (string-ci-match? (symbol->string sym) patt) )
103
104;; Types
105
106;;
107
108(define (search-pattern? obj)
109  (or
110    (keyword? obj)
111    (symbol? obj)
112    (string? obj)
113    (irregex? obj)
114    (pair? obj)) )
115
116;;
117
118(define (apropos-sort-key? obj)
119  (or
120    (not obj)
121    (eq? #:name obj)
122    (eq? #:module obj)
123    (eq? #:type obj)) )
124
125;; Errors
126
127(define (error-argument loc arg)
128  (if (keyword? arg)
129    (error loc "unrecognized keyword argument" arg)
130    (error loc "unrecognized argument" arg) ) )
131
132;; Argument Checking
133
134(define-check+error-type search-pattern search-pattern?
135  "symbol/keyword/string/irregex/irregex-sre/quoted")
136
137(define-check+error-type apropos-sort-key apropos-sort-key? "#:name, #:module, #:type or #f")
138
139#; ;UNSUPPORTED
140(define-check+error-type environment system-environment?)
141
142;; Number Base
143
144(define (number-base? obj)
145  (and (exact? obj) (integer? obj) (<= 2 obj CHICKEN-MAXIMUM-BASE)) )
146
147(define *number-base-error-message*
148  (string-append "fixnum in 2.." (number->string CHICKEN-MAXIMUM-BASE)))
149
150(define apropos-default-base (make-parameter 10 (lambda (x)
151  (if (number-base? x)
152    x
153    (begin
154      (warning 'apropos-default-base (string-append "not a " *number-base-error-message*) x)
155      (apropos-default-base))))))
156
157(define (check-apropos-number-base loc obj #!optional (var 'base))
158  (unless (number-base? obj)
159    (error-argument-type loc obj *number-base-error-message* var) )
160  obj )
161
162(define (check-split-component loc obj #!optional (var 'split))
163  (case obj
164    ((#f)               obj )
165    ((#:module #:name)  obj )
166    (else
167      (error-argument-type loc obj *number-base-error-message* var)) ) )
168
169;;
170
171;
172(define (system-current-symbol? sym)
173  ;must check full identifier name, so cdr
174  (not (null? (search-list-environment-symbols (cut eq? sym <>) (system-current-environment) cdr))) )
175
176;; Environment Search
177
178(define (*apropos-list/macro-environment loc match? macenv)
179  (search-macro-environment-symbols match? macenv) )
180
181(define (*apropos-list/environment loc match? env)
182  (search-system-environment-symbols match? env) )
183
184;;
185
186(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
187  ;(assert (sorted? ols eql?))
188  (let loop ((ls ols))
189    (let ((nxt (and (not (null? ls)) (cdr ls))))
190      (if (or (not nxt) (null? nxt))
191        ols
192        (if (eql? (car ls) (car nxt))
193          (begin
194            (set-cdr! ls (cdr nxt))
195            (loop ls) )
196          (loop nxt) ) ) ) ) )
197
198; => (envsyms . macenvsyms)
199(define (*apropos-list loc match/env? env match/macenv? macenv)
200  (append!
201    (*apropos-list/environment loc match/env? env)
202    (if macenv
203      ;FIXME why macro symbol dups?
204      (let ((syms (*apropos-list/macro-environment loc match/macenv? macenv)))
205        (import (only (chicken sort) sort!))
206        (delete-duplicates!/sorted (sort! syms symbol-printname<?) eq?) )
207      '())) )
208
209;; Argument List Parsing & Matcher Generation
210
211;FIXME separate concerns
212
213(define default-environment system-current-environment)
214(define default-macro-environment system-macro-environment)
215
216(define-constant ANY-SYMBOL '_)
217
218;(define apropos-excluded (make-parameter '() (lambda (x)
219;  (if (list? x) x (apropos-excluded)))))
220
221;(apropos-excluded "chicken.internal")
222
223(define (make-apropos-matcher loc patt
224            #!optional
225            (case-insensitive? #f)
226            (split #f)
227            (force-regexp? #f)
228            (internal? #f))
229  ;
230  ;(define excluded (apropos-excluded))
231  ;
232  (define (matcher-for pred? data)
233    (define (check? str)
234      (and
235        ;(not (any (lambda (x) (string-contains? str x)) excluded))
236        (or internal? (not (internal-module-name? str)))
237        (pred? str data) ) )
238    (cond
239      ((not split)
240        (lambda (sym)
241          (check? (symbol->string sym)) ) )
242      ((eq? #:module split)
243        (lambda (sym)
244          (let-values (((mod nam) (split-prefixed-symbol sym)))
245            (check? mod) ) ) )
246      ((eq? #:name split)
247        (lambda (sym)
248          (let-values (((mod nam) (split-prefixed-symbol sym)))
249            (check? nam) ) ) )
250        (else
251          (error loc "unknown symbol split" split patt) ) ) )
252  ;
253  (define (string-matcher str)
254    (let ((pred? (if case-insensitive? string-ci-match? string-exact-match?)))
255      (matcher-for pred? str) ) )
256  ;
257  (define (irregex-options-list)
258    (if case-insensitive? '(case-insensitive) '()) )
259  ;
260  (define (matcher-irregex patt)
261    (apply irregex patt (irregex-options-list)) )
262  ;
263  (define (irregex-matcher irx)
264    (matcher-for string-match? irx) )
265  ;
266  (cond
267    ;
268    ((symbol? patt)
269      (make-apropos-matcher loc
270        (symbol->string patt)
271        case-insensitive? split force-regexp? internal?) )
272    ;
273    ((string? patt)
274      (if force-regexp?
275        (irregex-matcher (matcher-irregex patt))
276        (string-matcher patt)) )
277    ;
278    ((irregex? patt)
279      (irregex-matcher patt) )
280    ;
281    ((pair? patt)
282      (if (not (eq? 'quote (car patt)))
283        ;then assume an irregex form
284        (irregex-matcher (matcher-irregex patt))
285        ;else some form of pattern
286        (let ((quoted (cadr patt)))
287          ;'(___ . <atom>)
288          (if (pair? quoted)
289            ;then could be a split (name|module) pattern
290            (cond
291              ;elaborate match any
292              ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
293                (make-apropos-matcher loc '(: (* any)) #f #f #t internal?) )
294              ;name split?
295              ((eq? ANY-SYMBOL (car quoted))
296                (make-apropos-matcher loc
297                  (cdr quoted)
298                  case-insensitive? #:name force-regexp? internal?) )
299              ;module split?
300              ((eq? ANY-SYMBOL (cdr quoted))
301                (make-apropos-matcher loc
302                  (car quoted)
303                  case-insensitive? #:module force-regexp? internal?) )
304              ;both name & module
305              (else
306                (let (
307                  (mod-match?
308                    (make-apropos-matcher loc
309                      (car quoted)
310                      case-insensitive? #:module force-regexp? internal?))
311                  (nam-match?
312                    (make-apropos-matcher loc
313                      (cdr quoted)
314                      case-insensitive? #:name force-regexp? internal?)) )
315                  (lambda (sym)
316                    (and (mod-match? sym) (nam-match? sym)) ) ) ) )
317            ;else interpretation of stripped
318            (make-apropos-matcher loc
319              quoted
320              case-insensitive? split #t internal?) ) ) ) )
321    ;
322    (else
323      (error loc "invalid apropos pattern form" patt) ) ) )
324
325;;
326
327; => (values val args)
328(define (keyword-argument args kwd #!optional val)
329  (let loop ((args args) (oargs '()))
330    (if (null? args)
331      (values val (reverse! oargs))
332      (let ((arg (car args)))
333        (cond
334          ((eq? kwd arg)
335            (set! val (cadr args))
336            (loop (cddr args) oargs) )
337          (else
338            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
339
340; => (values sort-key args)
341(define (parse-sort-key-argument loc args)
342  (receive (sort-key args) (keyword-argument args #:sort #:type)
343    (values (check-apropos-sort-key loc sort-key #:sort) args) ) )
344
345;;
346
347;#!optional (env (default-environment)) macenv #!key macros? internal? base (split #:all)
348;
349;macenv is #t for default macro environment or a macro-environment object.
350;
351;=> (values apropos-ls macenv)
352
353;
354(define (parse-arguments-and-match loc patt iargs)
355  (let-values (
356    ((env macenv case-insensitive? base raw? split internal? imported?) (parse-rest-arguments loc iargs)))
357    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
358    (let* (
359      (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
360      (force-regexp? #f)
361      (match? (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
362      (include? (if imported? system-current-symbol? global-symbol-bound?))
363      (als (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym))) env match? macenv)) )
364      (values als macenv raw?) ) ) )
365;;
366
367;=> (values env macenv base raw? split internal?)
368;
369(define (parse-rest-arguments loc iargs)
370  (let (
371    (env #f)        ;(default-environment) ;just the macros but looks ok in repl?
372    (macenv #f)
373    (internal? #f)
374    (raw? #f)
375    (case-insensitive? #f)
376    (split #f)
377    (base (apropos-default-base))
378    (imported? #f)
379    (1st-arg? #t) )
380    ;
381    (let loop ((args iargs))
382      (if (null? args)
383        ;seen 'em all
384        (values env macenv case-insensitive? base raw? split internal? imported?)
385        ;process potential arg
386        (let ((arg (car args)))
387          ;keyword argument?
388          (cond
389            ;
390            ((eq? #:imported? arg)
391              (set! imported? (cadr args))
392              (loop (cddr args)) )
393            ;
394            ((eq? #:split arg)
395              (set! split (check-split-component loc (cadr args)))
396              (loop (cddr args)) )
397            ;
398            ((eq? #:internal? arg)
399              (set! internal? (cadr args))
400              (loop (cddr args)) )
401            ;
402            ((eq? #:raw? arg)
403              (set! raw? (cadr args))
404              (loop (cddr args)) )
405            ;
406            ((eq? #:base arg)
407              (when (cadr args) (set! base (check-apropos-number-base loc (cadr args))))
408              (loop (cddr args)) )
409            ;
410            ((eq? #:macros? arg)
411              ;only flag supported
412              (when (cadr args) (set! macenv (default-macro-environment)))
413              (loop (cddr args)) )
414            ;
415            ((eq? #:case-insensitive? arg)
416              (set! case-insensitive? (cadr args))
417              (loop (cddr args)) )
418            ;environment argument?
419            ;FIXME need real 'environment?' predicate
420            ((and 1st-arg? (list? arg))
421              (set! 1st-arg? #f)
422              (set! env arg)
423              (loop (cdr args)) )
424            ;unkown argument
425            (else
426              (error-argument loc arg) ) ) ) ) ) ) )
427
428;;
429
430(define (fixup-pattern-argument patt #!optional (base (apropos-default-base)))
431  (cond
432    ((boolean? patt)
433      (if patt "#t" "#f") )
434    ((char? patt)
435      (string patt) )
436    ((number? patt)
437      (number->string patt base) )
438    ;? pair vector ... ->string , struct use tag as patt ?
439    (else
440      patt ) ) )
441
442#| ;UNSUPPORTED ;FIXME case-insensitive support
443;;
444
445(define (macro-environment obj)
446  (and
447    (sys::macro-environment? obj)
448    obj) )
449
450;;
451
452; => (values envsyms macenv)
453
454(define (parse-arguments/environment loc patt env)
455  (check-search-pattern loc patt 'pattern)
456  (let ((macenv (macro-environment (check-environment loc env 'environment))))
457    (values
458      (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv)
459      macenv) ) )
460
461;;
462
463; #!key internal?
464;
465; => (... (macenv . syms) ...)
466
467(define (parse-arguments/environments loc patt args)
468  ;
469  (define (parse-rest-arguments)
470    (let ((internal? #f))
471      (let loop ((args args) (envs '()))
472        (if (null? args)
473          (values (reverse! envs) internal?)
474          (let ((arg (car args)))
475            ;keyword argument?
476            (cond
477              ((eq? #:internal? arg)
478                (when (cadr args) (set! internal? #t))
479                (loop (cddr args) envs) )
480              ;environment argument?
481              (else
482                (unless (##sys#environment? arg)
483                  (error-argument loc arg) )
484                (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
485  ;
486  (let ((patt (fixup-pattern-argument patt)))
487    (check-search-pattern loc patt 'pattern)
488    (receive (envs internal?) (parse-rest-arguments)
489      (let ((regexp (make-apropos-matcher loc patt)))
490        (let loop ((envs envs) (envsyms '()))
491          (if (null? envs)
492            (reverse! envsyms)
493            (let* ((env (car envs))
494                   (macenv (macro-environment (check-environment loc env 'environment)))
495                   (make-envsyms
496                     (lambda ()
497                       (cons
498                         macenv
499                         (*apropos-list/environment loc regexp env macenv)) ) ) )
500              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
501|#
502
503;;; Display
504
505;;
506
507(define apropos-interning (make-parameter #t (lambda (x)
508  (if (boolean? x)
509    x
510    (begin
511      (warning 'apropos-interning "not a boolean: " x)
512      (apropos-interning))))))
513
514(define (string->display-symbol str)
515  (let (
516    (str2sym (if (apropos-interning) string->symbol string->uninterned-symbol)) )
517    (str2sym str) ) )
518
519;;
520
521#| ;A Work In Progress
522
523; UNDECIDEDABLE - given the data available from `procedure-information',
524; serial nature of `gensym', and serial nature of argument coloring by
525; compiler.
526
527; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
528; gensym identifiers can just be colored using a base of 1.
529
530;best guess:
531;
532;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
533;here `(foo a1 b2)'                       `(foo a1 b2)'
534;here `(a380384 a379385)'                 `(arg1 arg2)'
535;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'
536
537(define apropos-gensym-suffix-limit 1)
538
539;When > limit need to keep leading digit
540
541(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
542  (let* (
543    (str (symbol->string sym))
544    (idx (string-skip-right str char-set:digit))
545    (idx (and idx (+ 1 idx))) )
546    ;
547    (cond
548      ((not idx)
549        sym )
550      ((< (- (string-length str) idx) limit)
551        sym )
552      (else
553        (string->display-symbol (substring str 0 idx)) ) ) ) )
554
555; arg-lst-template is-a pair!
556(define (scrub-gensym-effect arg-lst-template)
557  (let (
558    (heads (butlast arg-lst-template))
559    (tailing (last-pair arg-lst-template)) )
560    ;
561    (append!
562      (map scrub-gensym-taste heads)
563      (if (null? (cdr tailing))
564        (list (scrub-gensym-taste (car tailing)))
565        (cons
566          (scrub-gensym-taste (car tailing))
567          (scrub-gensym-taste (cdr tailing)))) ) ) )
568|#
569
570(define (identifier-components sym raw?)
571  (cond
572    (raw?
573      (cons (toplevel-module-symbol) sym) )
574    (else
575      (let-values (
576        ((mod nam) (split-prefixed-symbol sym)) )
577        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
578
579;FIXME make patt a param ?
580(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
581(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
582
583(define (canonical-identifier-name id raw?)
584  (if raw?
585    id
586    (let* (
587      (pname (symbol->string id) )
588      (mt (irregex-match *GENSYM_SRE* pname) ) )
589      ;
590      (if (irregex-submatches? mt *GENSYM_SRE*)
591        (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
592        id ) ) ) )
593
594(define (canonicalize-identifier-names form raw?)
595  (cond
596    (raw?
597      form )
598    ((symbol? form)
599      (canonical-identifier-name form raw?) )
600    ((pair? form)
601      (cons
602        (canonicalize-identifier-names (car form) raw?)
603        (canonicalize-identifier-names (cdr form) raw?)) )
604    (else
605      form ) ) )
606
607; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
608;
609(define (procedure-details proc raw?)
610  (let ((info (procedure-information proc)))
611    (cond
612      ((not info)
613        'procedure )
614      ((pair? info)
615        `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
616      (else
617        ;was ,(symbol->string info) (? why)
618        `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
619
620; => 'macro | 'keyword | 'variable | <procedure-details>
621;
622(define (identifier-type-details sym #!optional macenv raw?)
623  (cond
624    ((and sym macenv (macro-symbol-in-environment? sym macenv))
625      'macro )
626    ((keyword? sym)
627      'keyword )
628    (else
629      (let ((val (global-symbol-ref sym)))
630        (if (procedure? val)
631          (procedure-details val raw?)
632          'variable ) ) ) ) )
633
634;;
635
636(define (make-information sym macenv raw?)
637  (cons
638    (identifier-components sym raw?)
639    (identifier-type-details sym macenv raw?)) )
640
641(define (*make-information-list syms macenv raw?)
642  (map (cut make-information <> macenv raw?) syms) )
643
644(define (identifier-information-module ident-info)
645  (car ident-info) )
646
647(define (identifier-information-name ident-info)
648  (cdr ident-info) )
649
650(define (detail-information-kind dets-info)
651  (car dets-info) )
652
653(define (detail-information-arguments dets-info)
654  (cdr dets-info) )
655
656(define (information-identifiers info)
657  (car info) )
658
659(define (information-module info)
660  (identifier-information-module (information-identifiers info)) )
661
662(define (information-name info)
663  (identifier-information-name (information-identifiers info)) )
664
665(define (information-details info)
666  (cdr info) )
667
668(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
669  (receive
670    (field-1-ref field-2-ref)
671      (if (eq? #:name sort-key)
672        (values information-name information-module)
673        (values information-module information-name) )
674    (let (
675      (sym-1-1 (field-1-ref info1) )
676      (sym-1-2 (field-1-ref info2) ) )
677      (if (not (symbol-printname=? sym-1-1 sym-1-2))
678        (symbol-printname<? sym-1-1 sym-1-2)
679        (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
680
681(define (information-kind info)
682  (let ((d (information-details info)))
683    (if (symbol? d) d (car d)) ) )
684
685(define (information-kind=? info1 info2)
686  (symbol-printname=? (information-kind info1) (information-kind info2)) )
687
688(define (information-kind<? info1 info2)
689  (symbol-printname<? (information-kind info1) (information-kind info2)) )
690
691(define (information<? info1 info2 #!optional (sort-key #:name))
692  (if (information-kind=? info1 info2)
693    (information-identifier<? info1 info2 sort-key)
694    (information-kind<? info1 info2) ) )
695
696;;
697
698(define (make-sorted-information-list syms macenv sort-key raw?)
699  (let (
700    (lessp
701      (case sort-key
702        ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
703        ((#:type)           information<?)
704        (else               #f ) ) )
705    (ails
706      (*make-information-list syms macenv raw?) ) )
707    ;
708    (if lessp
709      (sort! ails lessp)
710      ails ) ) )
711
712(define (symbol-pad-length sym maxsymlen #!optional (bias 0))
713  (let* (
714    (len (symbol-printname-length sym) )
715    (maxlen (min maxsymlen len) ) )
716    (+ bias (- maxsymlen maxlen)) ) )
717
718;FIXME need to know if ANY mods, then no mod pad needed (has +2)
719(define (display-apropos isyms macenv sort-key raw?)
720  ;
721  (let* (
722    (ails (make-sorted-information-list isyms macenv sort-key raw?) )
723    (mods (map information-module ails) )
724    (syms (map information-name ails) )
725    (maxmodlen (max-symbol-printname-length mods) )
726    (maxsymlen (max-symbol-printname-length syms) ) )
727    ;
728    (define (display-symbol-information info)
729      ;<sym><tab>
730      (let* (
731        (dets (information-details info))
732        (kwd? (eq? 'keyword dets))
733        (sym (information-name info) )
734        (sym-padlen (symbol-pad-length sym maxsymlen (if kwd? -1 0)) ) )
735        (display (if kwd? (symbol->keyword sym) sym))
736        (display (make-string+ (+ *tab-width* sym-padlen))) )
737      ;<mod><tab>
738      (let* (
739        (mod (information-module info) )
740        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
741        ;
742        (if (eq? (toplevel-module-symbol) mod)
743          (display (make-string+ (+ *tab-width* mod-padlen)))
744          (begin
745            (display mod)
746            (display (make-string+ (+ *tab-width* mod-padlen))) ) ) )
747      ;<details>
748      (let ((dets (information-details info)))
749        (cond
750          ((symbol? dets)
751            (display dets) )
752          (else
753            (display (detail-information-kind dets))
754            (display #\space)
755            (write (detail-information-arguments dets)) ) ) )
756      ;d'oy
757      (newline) )
758    ;
759    (for-each display-symbol-information ails) ) )
760
761;;; API
762
763(define apropos-default-options (make-parameter '() (lambda (x)
764  (cond
765    ((boolean? x)
766      (or
767        (and x KRL-OPTIONS)
768        '() ) )
769    ;FIXME actually check for proper options
770    ((list? x)
771      x )
772    (else
773      (warning 'apropos-default-options "not a list of options" x)
774      (apropos-default-options))))))
775
776;; Original
777
778(define (apropos patt . args)
779  (let (
780    (args (if (null? args) (apropos-default-options) args)) )
781    (let*-values (
782      ((sort-key args) (parse-sort-key-argument 'apropos args) )
783      ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
784      ;
785      (display-apropos syms macenv sort-key raw?) ) ) )
786
787(define (apropos-list patt . args)
788  (let (
789    (args (if (null? args) (apropos-default-options) args)) )
790    (let*-values (
791      ((sort-key args) (parse-sort-key-argument 'apropos-list args) )
792      ((syms macenv raw?) (parse-arguments-and-match 'apropos-list patt args) ) )
793      ;
794      syms ) ) )
795
796(define (apropos-information-list patt . args)
797  (let (
798    (args (if (null? args) (apropos-default-options) args)) )
799    (let*-values (
800      ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
801      ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
802      ;
803      (make-sorted-information-list syms macenv sort-key raw?) ) ) )
804
805) ;module apropos-api
806
807#| ;UNSUPPORTED ;FIXME case-insensitive support
808(export
809  ;Crispy
810  apropos/environment apropos-list/environment apropos-information-list/environment
811  ;Extra Crispy
812  apropos/environments apropos-list/environments apropos-information-list/environments)
813
814;; Crispy
815
816==== apropos/environment
817
818<procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#:sort SORT))</procedure>
819
820Displays information about identifiers matching {{PATTERN}} in the
821{{ENVIRONMENT}}.
822
823Like {{apropos}}.
824
825; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
826
827==== apropos-list/environment
828
829<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
830
831Like {{apropos-list}}.
832
833==== apropos-information-list/environment
834
835<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
836
837Like {{apropos-information-list}}.
838
839(define (apropos/environment patt env #!key internal? (sort #:name))
840  (check-sort-key 'apropos/environment sort #:sort)
841  (receive
842    (syms macenv)
843      (parse-arguments/environment 'apropos/environment patt env internal?)
844    ;
845    (newline)
846    (display-apropos syms macenv sort-key) ) )
847
848(define (apropos-list/environment patt env #!key internal?)
849  (receive
850    (syms macenv)
851      (parse-arguments/environment 'apropos/environment patt env internal?)
852    ;
853    syms ) )
854
855(define (apropos-information-list/environment patt env #!key internal?)
856  (receive
857    (syms macenv)
858      (parse-arguments/environment 'apropos/environment patt env internal?)
859    ;
860    (*make-information-list syms macenv) ) )
861
862;; Extra Crispy
863
864==== apropos/environments
865
866<procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#:sort SORT) ENVIRONMENT...)</procedure>
867
868Displays information about identifiers matching {{PATTERN}} in each
869{{ENVIRONMENT}}.
870
871Like {{apropos}}.
872
873; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
874
875==== apropos-list/environments
876
877<procedure>(apropos-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
878
879Like {{apropos-list}}.
880
881==== apropos-information-list/environments
882
883<procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
884
885Like {{apropos-information-list}}.
886
887(define (apropos/environments patt . args)
888  (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
889    (let ((i 0))
890      (for-each
891        (lambda (macenv+syms)
892          (set! i (add1 i))
893          (newline) (display "** Environment " i " **") (newline) (newline)
894          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
895        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
896
897(define (apropos-list/environments patt . args)
898  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
899
900(define (apropos-information-list/environments patt . args)
901  (map
902    (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
903    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
904|#
Note: See TracBrowser for help on using the repository browser.