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

Last change on this file since 35439 was 35439, checked in by Kon Lovett, 17 months ago

ocd

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