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

Last change on this file since 36254 was 36254, checked in by Kon Lovett, 16 months ago

better symbol-table-access api

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