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

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

rm qualified refs

File size: 26.1 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? #:case-insensitive? arg)
414              (set! case-insensitive? (cadr args))
415              (loop (cddr args)) )
416            ;environment argument?
417            (1st-arg?
418              ;FIXME need real 'environment?' predicate
419              (unless (list? arg)
420                (error-argument loc 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 qualified?)
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 qualified?)
459      macenv) ) )
460
461;;
462
463; #!key qualified?
464;
465; => (... (macenv . syms) ...)
466
467(define (parse-arguments/environments loc patt args)
468  ;
469  (define (parse-rest-arguments)
470    (let ((qualified? #f))
471      (let loop ((args args) (envs '()))
472        (if (null? args)
473          (values (reverse! envs) qualified?)
474          (let ((arg (car args)))
475            ;keyword argument?
476            (cond
477              ((eq? #:qualified? arg)
478                (when (cadr args) (set! qualified? #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 qualified?) (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 qualified?)) ) ) )
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; un-qualified symbols only!
542(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
543  (let* (
544    (str (symbol->string sym))
545    (idx (string-skip-right str char-set:digit))
546    (idx (and idx (fx+ 1 idx))) )
547    ;
548    (cond
549      ((not idx)
550        sym )
551      ((fx< (fx- (string-length str) idx) limit)
552        sym )
553      (else
554        (string->display-symbol (substring str 0 idx)) ) ) ) )
555
556; arg-lst-template is-a pair!
557(define (scrub-gensym-effect arg-lst-template)
558  (let (
559    (heads (butlast arg-lst-template))
560    (tailing (last-pair arg-lst-template)) )
561    ;
562    (append!
563      (map scrub-gensym-taste heads)
564      (if (null? (cdr tailing))
565        (list (scrub-gensym-taste (car tailing)))
566        (cons
567          (scrub-gensym-taste (car tailing))
568          (scrub-gensym-taste (cdr tailing)))) ) ) )
569|#
570
571(define (identifier-components sym raw?)
572  (cond
573    (raw?
574      (cons *toplevel-module-symbol* sym) )
575    ((qualified-symbol? sym)
576      (cons *toplevel-module-symbol* sym) )
577    (else
578      (let-values (
579        ((mod nam) (split-prefixed-symbol sym)) )
580        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
581
582;FIXME make patt a param ?
583(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
584(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
585
586(define (canonical-identifier-name id raw?)
587  (if raw?
588    id
589    (let* (
590      (pname (symbol->string id) )
591      (mt (irregex-match *GENSYM_SRE* pname) ) )
592      ;
593      (if (irregex-submatches? mt *GENSYM_SRE*)
594        (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
595        id ) ) ) )
596
597(define (canonicalize-identifier-names form raw?)
598  (cond
599    (raw?
600      form )
601    ((symbol? form)
602      (canonical-identifier-name form raw?) )
603    ((pair? form)
604      (cons
605        (canonicalize-identifier-names (car form) raw?)
606        (canonicalize-identifier-names (cdr form) raw?)) )
607    (else
608      form ) ) )
609
610; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
611(define (procedure-details proc raw?)
612  (let ((info (procedure-information proc)))
613    (cond
614      ((not info)
615        'procedure )
616      ((pair? info)
617        `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
618      (else
619        ;was ,(symbol->string info) (? why)
620        `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
621
622; => 'macro | 'keyword | 'variable | <procedure-details>
623(define (identifier-type-details sym #!optional macenv raw?)
624  (cond
625    ((macro-symbol-in-environment? sym macenv)
626      'macro )
627    ((keyword? sym)
628      'keyword )
629    (else
630      (let ((val (global-symbol-ref sym)))
631        (if (procedure? val)
632          (procedure-details val raw?)
633          'variable ) ) ) ) )
634
635;;
636
637(define (make-information sym macenv raw?)
638  (cons
639    (identifier-components sym raw?)
640    (identifier-type-details sym macenv raw?)) )
641
642(define (*make-information-list syms macenv raw?)
643  (map (cut make-information <> macenv raw?) syms) )
644
645(define (identifier-information-module ident-info)
646  (car ident-info) )
647
648(define (identifier-information-name ident-info)
649  (cdr ident-info) )
650
651(define (detail-information-kind dets-info)
652  (car dets-info) )
653
654(define (detail-information-arguments dets-info)
655  (cdr dets-info) )
656
657(define (information-identifiers info)
658  (car info) )
659
660(define (information-module info)
661  (identifier-information-module (information-identifiers info)) )
662
663(define (information-name info)
664  (identifier-information-name (information-identifiers info)) )
665
666(define (information-details info)
667  (cdr info) )
668
669(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
670  (receive
671    (field-1-ref field-2-ref)
672      (if (eq? #:name sort-key)
673        (values information-name information-module)
674        (values information-module information-name) )
675    (let (
676      (sym-1-1 (field-1-ref info1) )
677      (sym-1-2 (field-1-ref info2) ) )
678      (if (not (symbol-printname=? sym-1-1 sym-1-2))
679        (symbol-printname<? sym-1-1 sym-1-2)
680        (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
681
682(define (information-kind info)
683  (let ((d (information-details info)))
684    (if (symbol? d) d (car d)) ) )
685
686(define (information-kind=? info1 info2)
687  (symbol-printname=?
688    (information-kind info1)
689    (information-kind info2)) )
690
691(define (information-kind<? info1 info2)
692  (symbol-printname<?
693    (information-kind info1)
694    (information-kind info2)) )
695
696(define (information<? info1 info2 #!optional (sort-key #:name))
697  (if (information-kind=? info1 info2)
698    (information-identifier<? info1 info2 sort-key)
699    (information-kind<? info1 info2) ) )
700
701;;
702
703(define (make-sorted-information-list syms macenv sort-key raw?)
704  (let (
705    (lessp
706      (case sort-key
707        ((#:name #:module)
708          (cut information-identifier<? <> <> sort-key) )
709        ((#:type)
710          (cut information<? <> <> #:name) )
711        (else
712          #f ) ) )
713    (ails
714      (*make-information-list syms macenv raw?) ) )
715    ;
716    (if lessp
717      (sort! ails lessp)
718      ails ) ) )
719
720(define (symbol-pad-length sym maxsymlen)
721  (let* (
722    (len (symbol-printname-length sym) )
723    (maxlen (fxmin maxsymlen len) ) )
724    ;
725    (fx- maxsymlen maxlen) ) )
726
727;FIXME need to know if ANY mods, then no mod pad needed (has +2)
728(define (display-apropos isyms macenv sort-key raw?)
729  ;
730  (let* (
731    (ails (make-sorted-information-list isyms macenv sort-key raw?) )
732    (mods (map information-module ails) )
733    (syms (map information-name ails) )
734    (maxmodlen (max-symbol-printname-length mods) )
735    (maxsymlen (max-symbol-printname-length syms) ) )
736    ;
737    (define (display-symbol-information info)
738      ;<sym><tab>
739      (let* (
740        (sym (information-name info) )
741        (sym-padlen (symbol-pad-length sym maxsymlen) ) )
742        ;
743        (display sym)
744        (display (make-string+ (fx+ 2 sym-padlen))) )
745      ;<mod><tab>
746      (let* (
747        (mod (information-module info) )
748        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
749        ;
750        (if (eq? *toplevel-module-symbol* mod)
751          (display (make-string+ (fx+ 2 mod-padlen)))
752          (begin
753            (display mod)
754            (display (make-string+ (fx+ 2 mod-padlen))) ) ) )
755      ;<details>
756      (let ((dets (information-details info)))
757        (cond
758          ((symbol? dets)
759            (display dets) )
760          (else
761            (display (detail-information-kind dets))
762            (display #\space)
763            (write (detail-information-arguments dets)) ) ) )
764      ;d'oy
765      (newline) )
766    ;
767    (for-each display-symbol-information ails) ) )
768
769;;; API
770
771(define-constant KRL-OPTIONS '(
772  #:sort #:module #:case-insensitive? #t #:macros? #t))
773
774(define apropos-default-options (make-parameter '() (lambda (x)
775  (cond
776    ((boolean? x)
777      (or
778        (and x KRL-OPTIONS)
779        '() ) )
780    ;FIXME actually check for proper options
781    ((list? x)
782      x )
783    (else
784      (warning 'apropos-default-options "not a list of options" x)
785      (apropos-default-options))))))
786
787;; Original
788
789(define (apropos patt . args)
790  (let (
791    (args (if (null? args) (apropos-default-options) args)) )
792    (let*-values (
793      ((sort-key args) (parse-sort-key-argument 'apropos args) )
794      ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
795      ;
796      (display-apropos syms macenv sort-key raw?) ) ) )
797
798(define (apropos-list patt . args)
799  (let (
800    (args (if (null? args) (apropos-default-options) args)) )
801    (let*-values (
802      ((sort-key args) (parse-sort-key-argument 'apropos-list args) )
803      ((syms macenv raw?) (parse-arguments-and-match 'apropos-list patt args) ) )
804      ;
805      syms ) ) )
806
807(define (apropos-information-list patt . args)
808  (let (
809    (args (if (null? args) (apropos-default-options) args)) )
810    (let*-values (
811      ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
812      ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
813      ;
814      (make-sorted-information-list syms macenv sort-key raw?) ) ) )
815
816) ;module apropos-api
817
818#| ;UNSUPPORTED ;FIXME case-insensitive support
819(export
820  ;Crispy
821  apropos/environment apropos-list/environment apropos-information-list/environment
822  ;Extra Crispy
823  apropos/environments apropos-list/environments apropos-information-list/environments)
824
825;; Crispy
826
827==== apropos/environment
828
829<procedure>(apropos/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?) (#:sort SORT))</procedure>
830
831Displays information about identifiers matching {{PATTERN}} in the
832{{ENVIRONMENT}}.
833
834Like {{apropos}}.
835
836; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
837
838==== apropos-list/environment
839
840<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
841
842Like {{apropos-list}}.
843
844==== apropos-information-list/environment
845
846<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
847
848Like {{apropos-information-list}}.
849
850(define (apropos/environment patt env #!key qualified? (sort #:name))
851  (check-sort-key 'apropos/environment sort #:sort)
852  (receive
853    (syms macenv)
854      (parse-arguments/environment 'apropos/environment patt env qualified?)
855    ;
856    (newline)
857    (display-apropos syms macenv sort-key) ) )
858
859(define (apropos-list/environment patt env #!key qualified?)
860  (receive
861    (syms macenv)
862      (parse-arguments/environment 'apropos/environment patt env qualified?)
863    ;
864    syms ) )
865
866(define (apropos-information-list/environment patt env #!key qualified?)
867  (receive
868    (syms macenv)
869      (parse-arguments/environment 'apropos/environment patt env qualified?)
870    ;
871    (*make-information-list syms macenv) ) )
872
873;; Extra Crispy
874
875==== apropos/environments
876
877<procedure>(apropos/environments PATTERN (#:qualified? QUALIFIED?) (#:sort SORT) ENVIRONMENT...)</procedure>
878
879Displays information about identifiers matching {{PATTERN}} in each
880{{ENVIRONMENT}}.
881
882Like {{apropos}}.
883
884; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
885
886==== apropos-list/environments
887
888<procedure>(apropos-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
889
890Like {{apropos-list}}.
891
892==== apropos-information-list/environments
893
894<procedure>(apropos-information-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
895
896Like {{apropos-information-list}}.
897
898(define (apropos/environments patt . args)
899  (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
900    (let ((i 0))
901      (for-each
902        (lambda (macenv+syms)
903          (set! i (fx+ 1 i))
904          (newline) (display "** Environment " i " **") (newline) (newline)
905          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
906        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
907
908(define (apropos-list/environments patt . args)
909  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
910
911(define (apropos-information-list/environments patt . args)
912  (map
913    (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
914    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
915|#
Note: See TracBrowser for help on using the repository browser.