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

Last change on this file since 37045 was 37045, checked in by kon, 4 months ago

quick "fix" for no more qualified symbols

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