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

Last change on this file since 35745 was 35745, checked in by Kon Lovett, 2 years ago

don't show option options as optional, mv to better mod, fix types, comments, fix srfi-132 ref

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