source: project/release/5/apropos/trunk/apropos-csi.scm @ 37049

Last change on this file since 37049 was 37049, checked in by kon, 6 months ago

rm qualified refs

File size: 5.7 KB
Line 
1;;;; apropos-csi.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Oct '17
4;;;; Kon Lovett, Mar '09
5;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
6
7;; Issues
8;;
9;; - old csi option
10;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode #:prefix|#:suffix|#t}}
11;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.
12;;
13;; - cannot use ',?' since ',' read by read
14
15(module apropos-csi ()
16
17(import scheme
18  (chicken base)
19  (chicken fixnum)
20  (chicken platform)
21  (chicken io)
22  (chicken port)
23  (only (srfi 1) cons* reverse!)
24  #; ;Warning: the following extensions are not currently installed: chicken.csi
25  (only (chicken csi) toplevel-command)
26  apropos-api)
27
28(define-syntax apropos-toplevel-command
29  (syntax-rules ()
30    ((_ arg0 ...)
31      (chicken.csi#toplevel-command arg0 ...) ) ) )
32
33;;; Support
34
35;; string extensions
36
37(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
38  (let ((rem (fx- n (string-length x))))
39    (define (shorter?) (positive? rem))
40    (if (shorter?)
41      (string-append x (make-string rem pad))
42      (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
43
44;; Constants
45
46(define-constant CSI-HELP-HEAD-WIDTH 18)
47
48(define (csi-help-command-pad x)
49  (string-fixed-length x CSI-HELP-HEAD-WIDTH) )
50
51(define (csi-help cmd arg)
52  (string-append (string-fixed-length cmd CSI-HELP-HEAD-WIDTH) arg) )
53
54;rmvd ", raw, base [#]"
55(define CSI-HELP
56  (csi-help
57    ",a PATT ARG..."
58    "Apropos of PATT with ARG from ?, mac, ci, sort nam|mod|typ|#f, split nam|mod|#f"))
59
60(define-constant HELP-TEXT
61#<<EOS
62Pattern:
63
64 The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
65 strings are interpreted as a substring match.
66
67 The quoted PATT:
68
69    '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
70    '(PATT . _)     synonym for `PATT split module`.
71    '(_ . PATT)     synonym for `PATT split name`.
72    '(_ . _)        synonym for `(: (* any))` or match any.
73
74  '<atom>
75
76    interpret `<atom>` as an irregex.
77
78 Use "?" as a PATT to list symbols containing a `?`.
79
80Arguments:
81
82 macros            Include macro bound symbols
83 ci | case-insensitive
84                   Pattern has no capitals
85 sort name | module | type | #f
86                   Order items; optional when last argument
87 split name | module | #f
88                   Pattern match component; optional when last argument
89                   (also see the '(_ . _) pattern)
90 all               Means `ci mac`
91 krl               Means `all sort mod`
92 base              For number valued pattern
93 raw               No listing symbol interpretation (i.e. x123 ~> x)
94EOS
95)
96
97;;;
98;;; REPL Integeration
99;;;
100
101(define (interp-split-arg loc arg)
102  (case arg
103    ((n nam name)     #:name )
104    ((m mod module)   #:module )
105    (else
106      (if (not arg)
107        #f
108        (error-apropos-sort-key loc "unknown split key" arg) ) ) ) )
109
110(define (interp-sort-arg loc arg)
111  (case arg
112    ((n nam name)     #:name )
113    ((m mod module)   #:module )
114    ((t typ type)     #:type )
115    (else
116      (if (not arg)
117        #f
118        (error-apropos-sort-key loc "unknown sort key" arg) ) ) ) )
119
120(define (display-apropos-help)
121  (print CSI-HELP)
122  (print)
123  (print HELP-TEXT) )
124
125(define (parse-csi-apropos-arguments iargs)
126  ;look at every argument
127  (let loop ((args iargs) (oargs '()))
128    ;
129    (define (restargs next optarg?)
130      (cond
131        ((null? next)
132          '() )
133        (optarg?
134          (cdr next) )
135        (else
136          next ) ) )
137    ;
138    (define (arg-next kwd init #!optional optarg?)
139      ;
140      (define (thisargs next kwd init optarg?)
141        (cond
142          ((null? next)
143            (cons* init kwd oargs) )
144          (optarg?
145            (cons* (optarg? (car next)) kwd oargs) )
146          (else
147            (cons* init kwd oargs) ) ) )
148      ;
149      (let* (
150        (next (cdr args) )
151        (args (restargs next optarg?) )
152        (oargs (thisargs next kwd init optarg?) ) )
153        ;
154        (loop args oargs) ) )
155    ;
156    (if (null? args)
157      ; original ordering
158      (reverse! oargs)
159      ;csi-apropos-syntax => keyword-apropos-syntax
160      (let ((arg (car args)))
161        (case arg
162          ;
163          ((krl)
164            (loop
165              (restargs (cons* 'all (cdr args)) #f)
166              (cons* #:module #:sort oargs)) )
167          ;
168          ((all)
169            (loop
170              (restargs (cdr args) #f)
171              (cons* #t #:case-insensitive? #t #:macros? oargs)) )
172          ;
173          ((mac macros)
174            (arg-next #:macros? #t) )
175          ;
176          ((ci case-insensitive)
177            (arg-next #:case-insensitive? #t) )
178          ;
179          ((raw)
180            (arg-next #:raw? #t) )
181          ;
182          ((base)
183            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)) )
184          ;
185          ((sort)
186            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
187          ;
188          ((split)
189            (arg-next #:split #f (cut interp-split-arg ',a <>)) )
190          ;
191          ((?)
192            (loop '() '()) )
193          ;
194          (else
195            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
196
197(define (csi-apropos-command)
198  ;FIXME could be empty of args
199  (let* (
200    (cmdlin (read-line))
201    (args (with-input-from-string cmdlin read-list))
202    (apropos-args (parse-csi-apropos-arguments args)) )
203    ;NOTE will not dump the symbol-table unless explicit - use '(: (* any))
204    (cond
205      ((null? apropos-args)
206        (display-apropos-help) )
207      ((null? (cdr apropos-args))
208        (apply apropos (car apropos-args) (apropos-default-options)) )
209      (else
210        (apply apropos apropos-args) ) ) ) )
211
212;;; Main
213
214(when (feature? csi:)
215  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )
216
217) ;module apropos-csi
Note: See TracBrowser for help on using the repository browser.