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

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

better lolevel symenv access types, dedup macro syms (?)

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