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

Last change on this file was 35757, checked in by Kon Lovett, 14 months ago

better (_ . _), better names, better docu, better life

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