source: project/release/4/apropos/trunk/apropos.scm @ 35138

Last change on this file since 35138 was 35138, checked in by kon, 8 months ago

fix apropos-list unrecognized #:sort

File size: 34.3 KB
Line 
1;;;; apropos.scm -*- Hen -*-
2;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
3;;;; Kon Lovett, Mar '09
4;;;; Kon Lovett, Oct '17
5
6;; Issues
7;;
8;; - Use of 'global-symbol' routines is just wrong when an
9;; evaluation-environment (##sys#environment?) is not the
10;; interaction-environment.
11;;
12;; - Doesn't show something similar to procedure-information for macros. And
13;; how could it.
14;;
15;; - Could be re-written to use the "environments" extension. Which in turn would
16;; need to support syntactic environments, at least for lookup opertations.
17;;
18;; - The Chicken 'environment' object does not hold the (syntactic) bindings
19;; for any syntactic keywords from the R5RS. The public API of 'apropos'
20;; attempts to hide this fact.
21;;
22;; - old csi option
23;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode #:prefix|#:suffix|#t}}
24;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.
25
26(declare
27  (bound-to-procedure
28    ##sys#symbol-has-toplevel-binding?
29    ##sys#qualified-symbol?
30    ##sys#macro-environment
31    ##sys#current-environment
32    ##sys#macro? ) )
33
34(module apropos
35
36(;export
37  ;
38  apropos-interning apropos-default-options
39  ;Original
40  apropos apropos-list apropos-information-list
41  ;Crispy
42  ;apropos/environment apropos-list/environment apropos-information-list/environment
43  ;Extra Crispy
44  ;apropos/environments apropos-list/environments apropos-information-list/environments
45)
46
47(import
48  scheme
49  chicken
50  foreign
51  (only csi toplevel-command))
52
53(use
54  (only data-structures
55    sort! any?
56    alist-ref alist-update!
57    butlast
58    string-split)
59  (only ports
60    with-input-from-string)
61  (only extras
62    read-file read-line)
63  (only srfi-1
64    cons*
65    fold
66    reverse! append!
67    last-pair)
68  (only srfi-13
69    string-join
70    string-trim-both
71    string-contains string-contains-ci
72    string-drop string-take string-index)
73  (only irregex
74    sre->irregex
75    irregex irregex?
76    irregex-num-submatches
77    irregex-search irregex-match
78    irregex-match-data? irregex-match-num-submatches
79    irregex-replace)
80  (only memoized-string
81    make-string*)
82  (only symbol-utils
83    symbol->keyword
84    symbol-printname=? symbol-printname<?
85    symbol-printname-length max-symbol-printname-length )
86  (only type-checks
87    check-fixnum define-check+error-type)
88  (only type-errors
89    define-error-type error-argument-type)
90  miscmacros)
91
92;;; Support
93
94;;
95
96(define-constant *CHICKEN-MAXIMUM-BASE* 16)
97
98;;
99
100(define (->boolean obj)
101  (and
102    obj
103    #t ) )
104
105;; irregex extensions
106
107(define (irregex-submatches? mt #!optional ire)
108  (and
109    (irregex-match-data? mt)
110    (or
111      (not ire)
112      (fx=
113        (irregex-match-num-submatches mt)
114        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
115
116;; raw access renames
117
118(define system-current-environment ##sys#current-environment)
119
120(define system-macro-environment ##sys#macro-environment)
121
122(define (global-symbol-bound? sym)
123  (##sys#symbol-has-toplevel-binding? sym) )
124
125(define (global-symbol-ref sym)
126  (##sys#slot sym 0) )
127
128(define (symbol-macro-in-environment? sym macenv)
129  (and sym macenv (##sys#macro? sym macenv)) )
130
131(define (qualified-symbol? sym)
132  (and sym (##sys#qualified-symbol? sym)) )
133
134;; Types
135
136(define (search-pattern? obj)
137  (or
138    (keyword? obj)
139    (symbol? obj)
140    (string? obj)
141    (irregex? obj)
142    (pair? obj)) )
143
144(define (sort-key? obj)
145  (or
146    (not obj)
147    (eq? #:name obj)
148    (eq? #:module obj)
149    (eq? #:type obj)) )
150
151;; Errors
152
153(define (error-argument loc arg)
154  (if (keyword? arg)
155    (error loc "unrecognized keyword argument" arg)
156    (error loc "unrecognized argument" arg) ) )
157
158;; Argument Checking
159
160(define-check+error-type search-pattern search-pattern?
161  "symbol/keyword/string/irregex/irregex-sre/quoted")
162
163(define-check+error-type sort-key sort-key? "#:name, #:module, #:type or #f")
164
165#; ;UNSUPPORTED
166(define-check+error-type environment system-environment?)
167
168;; Number Base
169
170(define-constant *APROPOS-DEFAULT-BASE* 10)
171
172(define (number-base? obj)
173  (and (fixnum? obj) (fx<= 2 obj) (<= obj *CHICKEN-MAXIMUM-BASE*)) )
174
175(define *number-base-error-message*
176  (string-append "fixnum in 2.." (number->string *CHICKEN-MAXIMUM-BASE*)))
177
178(define (check-number-base loc obj #!optional (var 'base))
179  (unless (number-base? obj)
180    (error-argument-type loc obj *number-base-error-message* var) )
181  obj )
182
183(define (check-split-component loc obj #!optional (var 'split))
184  (case obj
185    ((#f)
186      obj )
187    ((#:module #:name)
188      obj )
189    (else
190      (error-argument-type loc obj "invalid identifier component" var)) ) )
191
192;; Symbols
193
194(define (string-irregex-match? str patt)
195  (irregex-search patt str) )
196
197(define (string-exact-match? str patt)
198  (string-contains str patt) )
199
200(define (string-ci-match? str patt)
201  (string-contains-ci str patt) )
202
203(define (symbol-irregex-match? sym patt)
204  (string-irregex-match? (symbol->string sym) patt) )
205
206(define (symbol-exact-match? sym patt)
207  (string-exact-match? (symbol->string sym) patt) )
208
209(define (symbol-ci-match? sym patt)
210  (string-ci-match? (symbol->string sym) patt) )
211
212(define *TOPLEVEL-MODULE-SYMBOL* '||)
213(define *TOPLEVEL-MODULE-STRING* "" #;(symbol->string *TOPLEVEL-MODULE-SYMBOL*))
214
215(: split-prefixed-symbol (symbol --> string string))
216(define (split-prefixed-symbol sym)
217  (let* (
218    (str (symbol->string sym))
219    (idx (string-index str #\#))
220    (mod (if idx (string-take str idx) *TOPLEVEL-MODULE-STRING*))
221    (nam (if idx (string-drop str (fx+ 1 idx)) str)) )
222    ;
223    (values mod nam) ) )
224
225;; special stuff from the runtime & scheme API
226
227#>
228#define ROOT_SYMBOL_TABLE_NAME  "."
229
230#define raw_symbol_table_size( stable )       ((stable)->size)
231#define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
232
233#define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
234#define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
235
236static C_regparm C_SYMBOL_TABLE *
237find_root_symbol_table()
238{
239  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
240}
241
242static C_regparm C_SYMBOL_TABLE *
243remember_root_symbol_table()
244{
245  static C_SYMBOL_TABLE *root_symbol_table = NULL;
246  if(!root_symbol_table) {
247    root_symbol_table = find_root_symbol_table();
248  }
249
250  return root_symbol_table;
251}
252
253//FIXME root_symbol_table re-allocated?
254//#define use_root_symbol_table   find_root_symbol_table
255#define use_root_symbol_table    remember_root_symbol_table
256<#
257
258(: root-symbol-table-size (--> fixnum))
259(define root-symbol-table-size
260  (foreign-lambda* int ()
261    "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )
262
263(: root-symbol-table-element (fixnum --> pair))
264(define root-symbol-table-element
265  (foreign-lambda* scheme-object ((int i))
266    "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
267
268(: bucket-symbol (pair --> symbol))
269(define bucket-symbol
270  (foreign-lambda* scheme-object ((scheme-object bucket))
271    "C_return( raw_bucket_symbol( bucket ) );"))
272
273(: bucket-link (pair --> list))
274(define bucket-link
275  (foreign-lambda* scheme-object ((scheme-object bucket))
276    "C_return( raw_bucket_link( bucket ) );"))
277
278(: bucket-last? (list --> boolean))
279(define bucket-last? null?)
280
281;;
282
283(define-type <symbol-table-cursor> (or boolean pair))
284
285(: make-symbol-table-cursor (* * --> <symbol-table-cursor>))
286(define make-symbol-table-cursor cons)
287
288(: symbol-table-cursor-active? (* --> boolean))
289(define symbol-table-cursor-active? pair?)
290
291(: symbol-table-cursor? (* --> boolean))
292(define (symbol-table-cursor? obj)
293  (or
294    (not obj)
295    (symbol-table-cursor-active? obj)) )
296
297(: symbol-table-cursor-index (<symbol-table-cursor> --> *))
298(define symbol-table-cursor-index car)
299
300(: set-symbol-table-cursor-index! (<symbol-table-cursor> * -> void))
301(define set-symbol-table-cursor-index! set-car!)
302
303(: symbol-table-cursor-bucket (<symbol-table-cursor> --> *))
304(define symbol-table-cursor-bucket cdr)
305
306(: set-symbol-table-cursor-bucket! (<symbol-table-cursor> * -> void))
307(define set-symbol-table-cursor-bucket! set-cdr!)
308
309(: symbol-table-cursor (--> <symbol-table-cursor>))
310(define (symbol-table-cursor)
311  (make-symbol-table-cursor -1 '()) )
312
313;;
314
315(: search-interaction-environment-symbols (* procedure --> list))
316(define (search-interaction-environment-symbols env optarg?)
317  (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
318    (let ((sym (root-symbol cursor)))
319      (if (not sym)
320        syms
321        (let ((syms (if (optarg? sym) (cons sym syms) syms)))
322          (loop (next-root-symbol cursor) syms) ) ) ) ) )
323
324(: search-list-environment-symbols (list procedure --> list))
325(define (search-list-environment-symbols env optarg?)
326  (fold
327    (lambda (cell syms)
328      (let ((sym (car cell)))
329        (if (optarg? sym)
330          (cons sym syms)
331          syms ) ) )
332    '()
333    env) )
334
335(: search-macro-environment-symbols (list procedure --> list))
336(define (search-macro-environment-symbols env optarg?)
337  (search-list-environment-symbols env optarg?) )
338
339(: search-system-environment-symbols (list procedure --> list))
340(define (search-system-environment-symbols env optarg?)
341  (if env
342    (search-list-environment-symbols env optarg?)
343    (search-interaction-environment-symbols env optarg?) ) )
344
345;;
346
347(: next-root-symbol (<symbol-table-cursor> --> <symbol-table-cursor>))
348(define (next-root-symbol cursor)
349  (and
350    (symbol-table-cursor-active? cursor)
351    (let loop (
352      (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
353      (idx (symbol-table-cursor-index cursor)))
354      ;gotta bucket ?
355      (if (and bkt (not (bucket-last? bkt)))
356        ;then found something => where we are
357        (make-symbol-table-cursor idx bkt)
358        ;else try next hash-root slot
359        (let ((idx (fx+ 1 idx)))
360          (and
361            ;more to go ?
362            (< idx (root-symbol-table-size))
363            ;this slot
364            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
365
366(: initial-symbol-table-cursor (--> <symbol-table-cursor>))
367(define (initial-symbol-table-cursor)
368  (next-root-symbol (symbol-table-cursor)) )
369
370(: root-symbol (<symbol-table-cursor> --> (or boolean symbol)))
371(define (root-symbol cursor)
372  (and
373    (symbol-table-cursor-active? cursor)
374    (bucket-symbol-ref (symbol-table-cursor-bucket cursor)) ) )
375
376(: bucket-symbol-ref (list --> (or boolean symbol)))
377(define (bucket-symbol-ref bkt)
378  (and
379    (not (bucket-last? bkt))
380    (bucket-symbol bkt) ) )
381
382(: bucket-link-ref (list --> (or boolean list)))
383(define (bucket-link-ref bkt)
384  (and
385    (not (bucket-last? bkt))
386    (bucket-link bkt)) )
387
388;;
389
390;;
391
392#; ;UNSUPPORTED
393(define (system-environment? obj)
394  (or (##sys#environment? obj) (sys::macro-environment? obj)) )
395
396;; Environment Search
397
398(define (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
399  (let (
400    (optarg?
401      (if qualified?
402        any?
403        (lambda (x)
404          (not (qualified-symbol? x))))))
405    (search-macro-environment-symbols macenv
406      (lambda (sym)
407        (and
408          (symbol-match? sym)
409          (optarg? sym)))) ) )
410
411(define (*apropos-list/environment loc symbol-match? env qualified?)
412  (let (
413    (optarg?
414      (if qualified?
415        global-symbol-bound?
416        (lambda (x)
417          (and
418            (not (qualified-symbol? x))
419            (global-symbol-bound? x))))))
420    ;
421    (search-system-environment-symbols env
422      (lambda (sym)
423        (and
424          (symbol-match? sym)
425          (optarg? sym)))) ) )
426
427;;
428
429; => (envsyms . macenvsyms)
430(define (*apropos-list loc symbol-match? env macenv qualified?)
431  (append
432    (*apropos-list/environment loc symbol-match? env qualified?)
433    (if macenv
434      (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
435      '())) )
436
437;; Argument List Parsing
438
439(define default-environment system-current-environment)
440(define default-macro-environment system-macro-environment)
441
442(define (make-apropos-matcher loc patt #!optional (case-insensitive? #f) (split #f) (force-regexp? #f))
443  ;
444  (define (gen-irregex-options-list)
445    (if case-insensitive? '(case-insensitive) '()) )
446  ;
447  (define (gen-irregex patt)
448    (apply irregex patt (gen-irregex-options-list)) )
449  ;
450  (define (gen-irregex-matcher irx)
451    (cond
452      ((eq? #:module split)
453        (lambda (sym)
454          (let-values (
455            ((mod nam) (split-prefixed-symbol sym)) )
456            (string-irregex-match? mod irx) ) ) )
457      ((eq? #:name split)
458        (lambda (sym)
459          (let-values (
460            ((mod nam) (split-prefixed-symbol sym)) )
461            (string-irregex-match? nam irx) ) ) )
462      ((not split)
463        (cut symbol-irregex-match? <> irx) ) ) )
464  ;
465  (define (gen-string-matcher str)
466    (if (not split)
467      ;no split
468      (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> str)
469      ;splitting
470      (let (
471        (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
472        (cond
473          ((eq? #:module split)
474            (lambda (sym)
475              (let-values (
476                ((mod nam) (split-prefixed-symbol sym)) )
477                (matcher mod str) ) ) )
478          ((eq? #:name split)
479            (lambda (sym)
480              (let-values (
481                ((mod nam) (split-prefixed-symbol sym)) )
482                (matcher nam str) ) ) ) ) ) ) )
483  ;
484  (cond
485    ((symbol? patt)
486      (make-apropos-matcher loc (symbol->string patt) case-insensitive? split force-regexp?) )
487    ((string? patt)
488      (if force-regexp?
489        (gen-irregex-matcher (gen-irregex patt))
490        (gen-string-matcher patt) ) )
491    ((pair? patt)
492      (if (eq? 'quote (car patt))
493        (make-apropos-matcher loc (cadr patt) case-insensitive? split #t)
494        (gen-irregex-matcher (gen-irregex patt)) ) )
495    ((irregex? patt)
496      (gen-irregex-matcher patt) )
497    (else
498      (error loc "invalid apropos pattern form" patt) ) ) )
499
500;;
501
502; => (values val args)
503(define (keyword-argument args kwd #!optional val)
504  (let loop ((args args) (oargs '()))
505    (if (null? args)
506      (values val (reverse! oargs))
507      (let ((arg (car args)))
508        (cond
509          ((eq? kwd arg)
510            (set! val (cadr args))
511            (loop (cddr args) oargs) )
512          (else
513            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
514
515; => (values sort-key args)
516(define (parse-sort-key-argument loc args)
517  (receive (sort-key args) (keyword-argument args #:sort #:type)
518    (values (check-sort-key loc sort-key #:sort) args) ) )
519
520;;
521
522;#!optional (env (default-environment)) macenv #!key macros? qualified? base (split #:all)
523;
524;macenv is #t for default macro environment or a macro-environment object.
525;
526;=> (values apropos-ls macenv)
527(define (parse-arguments-and-match loc patt iargs)
528  (let-values (
529    ((env macenv qualified? case-insensitive? base raw? split)
530      (parse-rest-arguments loc iargs)))
531    ;
532    (let* (
533      (patt
534        (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
535      (matcher
536        (make-apropos-matcher loc patt case-insensitive? split) )
537      (als
538        (*apropos-list loc matcher env macenv qualified?) ) )
539      ;
540      (values als macenv raw?) ) ) )
541;;
542
543;=> (values env macenv qualified? base)
544(define (parse-rest-arguments loc iargs)
545  (let (
546    (env #f)        ;(default-environment)
547    (macenv #f)
548    (qualified? #f)
549    (raw? #f)
550    (case-insensitive? #f)
551    (split #f)
552    (base *APROPOS-DEFAULT-BASE*)
553    (1st-arg? #t) )
554    ;
555    (let loop ((args iargs))
556      (if (null? args)
557        ;seen 'em all
558        (values env macenv qualified? case-insensitive? base raw? split)
559        ;process potential arg
560        (let ((arg (car args)))
561          ;keyword argument?
562          (cond
563            ;
564            ((eq? #:split arg)
565              (set! split (check-split-component loc (cadr args)))
566              (loop (cddr args)) )
567            ;
568            ((eq? #:raw? arg)
569              (set! raw? (cadr args))
570              (loop (cddr args)) )
571            ;
572            ((eq? #:base arg)
573              (when (cadr args)
574                (set! base (check-number-base loc (cadr args))) )
575              (loop (cddr args)) )
576            ;
577            ((eq? #:macros? arg)
578              ;only flag supported
579              (when (cadr args)
580                (set! macenv (default-macro-environment)) )
581              (loop (cddr args)) )
582            ;
583            ((eq? #:qualified? arg)
584              (set! qualified? (cadr args))
585              (loop (cddr args)) )
586            ;
587            ((eq? #:case-insensitive? arg)
588              (set! case-insensitive? (cadr args))
589              (loop (cddr args)) )
590            ;environment argument?
591            (1st-arg?
592              ;FIXME need real 'environment?' predicate
593              (unless (list? arg)
594                (error-argument loc arg) )
595              (set! 1st-arg? #f)
596              (set! env arg)
597              (loop (cdr args)) )
598            ;unkown argument
599            (else
600              (error-argument loc arg) ) ) ) ) ) ) )
601
602;;
603
604(define (fixup-pattern-argument patt #!optional (base *APROPOS-DEFAULT-BASE*))
605  (cond
606    ((boolean? patt)
607      (if patt "#t" "#f") )
608    ((char? patt)
609      (string patt) )
610    ((number? patt)
611      (number->string patt base) )
612    ;? pair vector ... ->string , struct use tag as patt ?
613    (else
614      patt ) ) )
615
616#| ;UNSUPPORTED ;FIXME case-insensitive support
617;;
618
619(define (macro-environment obj)
620  (and
621    (sys::macro-environment? obj)
622    obj) )
623
624;;
625
626; => (values envsyms macenv)
627
628(define (parse-arguments/environment loc patt env qualified?)
629  (check-search-pattern loc patt 'pattern)
630  (let ((macenv (macro-environment (check-environment loc env 'environment))))
631    (values
632      (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv qualified?)
633      macenv) ) )
634
635;;
636
637; #!key qualified?
638;
639; => (... (macenv . syms) ...)
640
641(define (parse-arguments/environments loc patt args)
642  ;
643  (define (parse-rest-arguments)
644    (let ((qualified? #f))
645      (let loop ((args args) (envs '()))
646        (if (null? args)
647          (values (reverse! envs) qualified?)
648          (let ((arg (car args)))
649            ;keyword argument?
650            (cond
651              ((eq? #:qualified? arg)
652                (when (cadr args) (set! qualified? #t))
653                (loop (cddr args) envs) )
654              ;environment argument?
655              (else
656                (unless (##sys#environment? arg)
657                  (error-argument loc arg) )
658                (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
659  ;
660  (let ((patt (fixup-pattern-argument patt)))
661    (check-search-pattern loc patt 'pattern)
662    (receive (envs qualified?) (parse-rest-arguments)
663      (let ((regexp (make-apropos-matcher loc patt)))
664        (let loop ((envs envs) (envsyms '()))
665          (if (null? envs)
666            (reverse! envsyms)
667            (let* ((env (car envs))
668                   (macenv (macro-environment (check-environment loc env 'environment)))
669                   (make-envsyms
670                     (lambda ()
671                       (cons
672                         macenv
673                         (*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
674              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
675|#
676
677;;; Display
678
679;;
680
681(define apropos-interning (make-parameter #t (lambda (x)
682  (if (boolean? x)
683    x
684    (begin
685      (warning 'apropos-interning "not a boolean: " x)
686      (apropos-interning))))))
687
688(define (string->display-symbol str)
689  ((if (apropos-interning) string->symbol string->uninterned-symbol) str) )
690
691;;
692
693;;
694
695#| ;A Work In Progress
696
697; UNDECIDEDABLE - given the data available from `procedure-information',
698; serial nature of `gensym', and serial nature of argument coloring by
699; compiler.
700
701; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
702; gensym identifiers can just be colored using a base of 1.
703
704;best guess:
705;
706;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
707;here `(foo a1 b2)'                       `(foo a1 b2)'
708;here `(a380384 a379385)'                 `(arg1 arg2)'
709;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'
710
711(define apropos-gensym-suffix-limit 1)
712
713;When > limit need to keep leading digit
714
715; un-qualified symbols only!
716(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
717  (let* (
718    (str (symbol->string sym))
719    (idx (string-skip-right str char-set:digit))
720    (idx (and idx (fx+ 1 idx))) )
721    ;
722    (cond
723      ((not idx)
724        sym )
725      ((fx< (fx- (string-length str) idx) limit)
726        sym )
727      (else
728        (string->display-symbol (substring str 0 idx)) ) ) ) )
729
730; arg-lst-template is-a pair!
731(define (scrub-gensym-effect arg-lst-template)
732  (let (
733    (heads (butlast arg-lst-template))
734    (tailing (last-pair arg-lst-template)) )
735    ;
736    (append!
737      (map scrub-gensym-taste heads)
738      (if (null? (cdr tailing))
739        (list (scrub-gensym-taste (car tailing)))
740        (cons
741          (scrub-gensym-taste (car tailing))
742          (scrub-gensym-taste (cdr tailing)))) ) ) )
743|#
744
745(define (identifier-components sym raw?)
746  (cond
747    (raw?
748      (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
749    ((qualified-symbol? sym)
750      (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
751    (else
752      (let-values (
753        ((mod nam) (split-prefixed-symbol sym)) )
754        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
755
756;FIXME make patt a param ?
757(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
758(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
759
760(define (canonical-identifier-name id raw?)
761  (if raw?
762    id
763    (let* (
764      (pname (symbol->string id) )
765      (mt (irregex-match *GENSYM_SRE* pname) ) )
766      ;
767      (if (irregex-submatches? mt *GENSYM_SRE*)
768        (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
769        id ) ) ) )
770
771(define (canonicalize-identifier-names form raw?)
772  (cond
773    (raw?
774      form )
775    ((symbol? form)
776      (canonical-identifier-name form raw?) )
777    ((pair? form)
778      (cons
779        (canonicalize-identifier-names (car form) raw?)
780        (canonicalize-identifier-names (cdr form) raw?)) )
781    (else
782      form ) ) )
783
784; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
785(define (procedure-details proc raw?)
786  (let ((info (procedure-information proc)))
787    (cond
788      ((not info)
789        'procedure )
790      ((pair? info)
791        `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
792      (else
793        ;was ,(symbol->string info) (? why)
794        `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
795
796; => 'macro | 'keyword | 'variable | <procedure-details>
797(define (identifier-type-details sym #!optional macenv raw?)
798  (cond
799    ((symbol-macro-in-environment? sym macenv)
800      'macro )
801    ((keyword? sym)
802      'keyword )
803    (else
804      (let ((val (global-symbol-ref sym)))
805        (if (procedure? val)
806          (procedure-details val raw?)
807          'variable ) ) ) ) )
808
809;;
810
811(define (make-information sym macenv raw?)
812  (cons
813    (identifier-components sym raw?)
814    (identifier-type-details sym macenv raw?)) )
815
816(define (*make-information-list syms macenv raw?)
817  (map (cut make-information <> macenv raw?) syms) )
818
819(define (identifier-information-module ident-info)
820  (car ident-info) )
821
822(define (identifier-information-name ident-info)
823  (cdr ident-info) )
824
825(define (detail-information-kind dets-info)
826  (car dets-info) )
827
828(define (detail-information-arguments dets-info)
829  (cdr dets-info) )
830
831(define (information-identifiers info)
832  (car info) )
833
834(define (information-module info)
835  (identifier-information-module (information-identifiers info)) )
836
837(define (information-name info)
838  (identifier-information-name (information-identifiers info)) )
839
840(define (information-details info)
841  (cdr info) )
842
843(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
844  (receive
845    (field-1-ref field-2-ref)
846      (if (eq? #:name sort-key)
847        (values information-name information-module)
848        (values information-module information-name) )
849    (let (
850      (sym-1-1 (field-1-ref info1) )
851      (sym-1-2 (field-1-ref info2) ) )
852      (if (not (symbol-printname=? sym-1-1 sym-1-2))
853        (symbol-printname<? sym-1-1 sym-1-2)
854        (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
855
856(define (information-kind info)
857  (let ((d (information-details info)))
858    (if (symbol? d) d (car d)) ) )
859
860(define (information-kind=? info1 info2)
861  (symbol-printname=?
862    (information-kind info1)
863    (information-kind info2)) )
864
865(define (information-kind<? info1 info2)
866  (symbol-printname<?
867    (information-kind info1)
868    (information-kind info2)) )
869
870(define (information<? info1 info2 #!optional (sort-key #:name))
871  (if (information-kind=? info1 info2)
872    (information-identifier<? info1 info2 sort-key)
873    (information-kind<? info1 info2) ) )
874
875;;
876
877(define (make-sorted-information-list syms macenv sort-key raw?)
878  (let (
879    (lessp
880      (case sort-key
881        ((#:name #:module)
882          (cut information-identifier<? <> <> sort-key) )
883        ((#:type)
884          (cut information<? <> <> #:name) )
885        (else
886          #f ) ) )
887    (ails
888      (*make-information-list syms macenv raw?) ) )
889    ;
890    (if lessp
891      (sort! ails lessp)
892      ails ) ) )
893
894(define (symbol-pad-length sym maxsymlen)
895  (let* (
896    (len (symbol-printname-length sym) )
897    (maxlen (fxmin maxsymlen len) ) )
898    ;
899    (fx- maxsymlen maxlen) ) )
900
901(define (display-apropos isyms macenv sort-key raw?)
902  ;
903  (let* (
904    (ails (make-sorted-information-list isyms macenv sort-key raw?) )
905    (mods (map information-module ails) )
906    (syms (map information-name ails) )
907    (maxmodlen (max-symbol-printname-length mods) )
908    (maxsymlen (max-symbol-printname-length syms) ) )
909    ;
910    (define (display-symbol-information info)
911      ;<sym><tab>
912      (let* (
913        (sym (information-name info) )
914        (sym-padlen (symbol-pad-length sym maxsymlen) ) )
915        ;
916        (display sym)
917        (display (make-string* (fx+ 2 sym-padlen))) )
918      ;<mod><tab>
919      (let* (
920        (mod (information-module info) )
921        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
922        ;
923        (if (eq? *TOPLEVEL-MODULE-SYMBOL* mod)
924          (display (make-string* mod-padlen))
925          (begin
926            (display mod)
927            (display (make-string* (fx+ 2 mod-padlen))) ) ) )
928      ;<details>
929      (let ((dets (information-details info)))
930        (cond
931          ((symbol? dets)
932            (display dets) )
933          (else
934            (display (detail-information-kind dets))
935            (display #\space)
936            (write (detail-information-arguments dets)) ) ) )
937      ;d'oy
938      (newline) )
939    ;
940    (for-each display-symbol-information ails) ) )
941
942;;; API
943
944(define-constant KRL-OPTIONS '(
945  #:sort #:module #:case-insensitive? #t #:qualified? #t #:macros? #t))
946
947(define apropos-default-options (make-parameter '() (lambda (x)
948  (cond
949    ((boolean? x)
950      (or
951        (and x KRL-OPTIONS)
952        '() ) )
953    ((list? x)
954      x )
955    (else
956      (warning 'apropos-default-options "not a list of options" x)
957      (apropos-default-options))))))
958
959;; Original
960
961(define (apropos patt . args)
962  (let (
963    (args (if (null? args) (apropos-default-options) args)) )
964    (let*-values (
965      ((sort-key args) (parse-sort-key-argument 'apropos args) )
966      ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
967      ;
968      (display-apropos syms macenv sort-key raw?) ) ) )
969
970(define (apropos-list patt . args)
971  (let (
972    (args (if (null? args) (apropos-default-options) args)) )
973    (let*-values (
974      ((sort-key args) (parse-sort-key-argument 'apropos-list args) )
975      ((syms macenv raw?) (parse-arguments-and-match 'apropos-list patt args) ) )
976      ;
977      syms ) ) )
978
979(define (apropos-information-list patt . args)
980  (let (
981    (args (if (null? args) (apropos-default-options) args)) )
982    (let*-values (
983      ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
984      ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
985      ;
986      (make-sorted-information-list syms macenv sort-key raw?) ) ) )
987
988;;;
989;;; REPL Integeration
990;;;
991
992(define (interp-split-arg loc arg)
993  (case arg
994    ((n nam name)
995      #:name )
996    ((m mod module)
997      #:module )
998    (else
999      (if (not arg)
1000        #f
1001        (error-sort-key loc "unknown split key" arg) ) ) ) )
1002
1003(define (interp-sort-arg loc arg)
1004  (case arg
1005    ((n nam name)
1006      #:name )
1007    ((m mod module)
1008      #:module )
1009    ((t typ type)
1010      #:type )
1011    (else
1012      (if (not arg)
1013        #f
1014        (error-sort-key loc "unknown sort key" arg) ) ) ) )
1015
1016(define *csi-apropos-help*
1017  ",a PATT ARG...    Apropos of PATT with ARG from mac, split [nam|mod|#f], qual, ci, sort [nam|mod|typ|#f] Or ?")
1018
1019;rmvd ", raw, base [#]"
1020(define (display-apropos-help)
1021  (print #<<EOS
1022Apropos arguments:
1023
1024 macros            Include macro bound symbols
1025 qualified         Include "qualified" symbols
1026 ci | case-insensitive
1027                   Pattern has no capitals
1028 sort [name | module | type | #f]
1029                   Order items (optional when last argument)
1030 split [name | module | #f]
1031                   Pattern match component (optional when last argument)
1032 all               Means "ci qual mac""
1033 krl               Means "all sort mod""
1034 base              For number valued pattern
1035 raw               No symbol interpretation
1036
1037 Use a PATT of "?" to list symbols containing a #\?.
1038EOS
1039  ) )
1040
1041(define (parse-csi-apropos-arguments iargs)
1042  (let loop ((args iargs) (oargs '()))
1043    ;
1044    (define (thisargs next kwd init optarg?)
1045      (cond
1046        ((null? next)
1047          (cons* init kwd oargs) )
1048        (optarg?
1049          (cons* (optarg? (car next)) kwd oargs) )
1050        (else
1051          (cons* init kwd oargs) ) ) )
1052    ;
1053    (define (restargs next optarg?)
1054      (cond
1055        ((null? next)
1056          '() )
1057        (optarg?
1058          (cdr next) )
1059        (else
1060          next ) ) )
1061    ;
1062    (define (addarg kwd init #!optional optarg?)
1063      (let* (
1064        (next (cdr args) )
1065        (args (restargs next optarg?) )
1066        (oargs (thisargs next kwd init optarg?) ) )
1067        ;
1068        (loop args oargs) ) )
1069    ;
1070    (if (null? args)
1071      ; original ordering
1072      (reverse! oargs)
1073      ;csi-apropos-syntax => keyword-apropos-syntax
1074      (let ((arg (car args)))
1075        (case arg
1076          ;
1077          ((krl)
1078            (loop
1079              (restargs (cons* 'all (cdr args)) #f)
1080              (cons* #:module #:sort oargs)) )
1081          ;
1082          ((all)
1083            (loop
1084              (restargs (cdr args) #f)
1085              (cons* #t #:case-insensitive? #t #:qualified? #t #:macros? oargs)) )
1086          ;
1087          ((mac macros)
1088            (addarg #:macros? #t) )
1089          ;
1090          ((qual qualified)
1091            (addarg #:qualified? #t) )
1092          ;
1093          ((ci case-insensitive)
1094            (addarg #:case-insensitive? #t) )
1095          ;
1096          ((raw)
1097            (addarg #:raw? #t) )
1098          ;
1099          ((base)
1100            (addarg #:base *APROPOS-DEFAULT-BASE* (cut check-number-base ',a <>)) )
1101          ;
1102          ((sort)
1103            (addarg #:sort #:type (cut interp-sort-arg ',a <>)) )
1104          ;
1105          ((split)
1106            (addarg #:split #f (cut interp-split-arg ',a <>)) )
1107          ;
1108          ((?)
1109            (loop '() '()) )
1110          ;
1111          (else
1112            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
1113
1114(define (csi-apropos-command)
1115  (let* (
1116    (cmdlin (read-line) )
1117    (istr (string-trim-both cmdlin) )
1118    (iargs (with-input-from-string istr read-file) )
1119    (aargs (parse-csi-apropos-arguments iargs)))
1120    ;NOTE will not dump the symbol-table unless explicit ; use '(: (* any))
1121    (cond
1122      ((null? aargs)
1123        (display-apropos-help) )
1124      ((null? (cdr aargs))
1125        (apply apropos (car aargs) (apropos-default-options)) )
1126      (else
1127        (apply apropos aargs) ) ) ) )
1128
1129;;; Main
1130
1131(when (feature? csi:)
1132  (toplevel-command 'a csi-apropos-command *csi-apropos-help*) )
1133
1134) ;module apropos
1135
1136#| ;UNSUPPORTED ;FIXME case-insensitive support
1137
1138;; Crispy
1139
1140==== apropos/environment
1141
1142<procedure>(apropos/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?) (#:sort SORT))</procedure>
1143
1144Displays information about identifiers matching {{PATTERN}} in the
1145{{ENVIRONMENT}}.
1146
1147Like {{apropos}}.
1148
1149; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
1150
1151==== apropos-list/environment
1152
1153<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
1154
1155Like {{apropos-list}}.
1156
1157==== apropos-information-list/environment
1158
1159<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
1160
1161Like {{apropos-information-list}}.
1162
1163(define (apropos/environment patt env #!key qualified? (sort #:name))
1164  (check-sort-key 'apropos/environment sort #:sort)
1165  (receive
1166    (syms macenv)
1167      (parse-arguments/environment 'apropos/environment patt env qualified?)
1168    ;
1169    (newline)
1170    (display-apropos syms macenv sort-key) ) )
1171
1172(define (apropos-list/environment patt env #!key qualified?)
1173  (receive
1174    (syms macenv)
1175      (parse-arguments/environment 'apropos/environment patt env qualified?)
1176    ;
1177    syms ) )
1178
1179(define (apropos-information-list/environment patt env #!key qualified?)
1180  (receive
1181    (syms macenv)
1182      (parse-arguments/environment 'apropos/environment patt env qualified?)
1183    ;
1184    (*make-information-list syms macenv) ) )
1185
1186;; Extra Crispy
1187
1188==== apropos/environments
1189
1190<procedure>(apropos/environments PATTERN (#:qualified? QUALIFIED?) (#:sort SORT) ENVIRONMENT...)</procedure>
1191
1192Displays information about identifiers matching {{PATTERN}} in each
1193{{ENVIRONMENT}}.
1194
1195Like {{apropos}}.
1196
1197; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
1198
1199==== apropos-list/environments
1200
1201<procedure>(apropos-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
1202
1203Like {{apropos-list}}.
1204
1205==== apropos-information-list/environments
1206
1207<procedure>(apropos-information-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
1208
1209Like {{apropos-information-list}}.
1210
1211(define (apropos/environments patt . args)
1212  (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
1213    (let ((i 0))
1214      (for-each
1215        (lambda (macenv+syms)
1216          (set! i (fx+ 1 i))
1217          (newline) (display "** Environment " i " **") (newline) (newline)
1218          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
1219        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
1220
1221(define (apropos-list/environments patt . args)
1222  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
1223
1224(define (apropos-information-list/environments patt . args)
1225  (map
1226    (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
1227    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
1228|#
Note: See TracBrowser for help on using the repository browser.