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

Last change on this file since 36816 was 36816, checked in by Kon Lovett, 10 months ago

comments

File size: 5.9 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, qual, 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 qualified         Include "qualified" symbols
84 ci | case-insensitive
85                   Pattern has no capitals
86 sort name | module | type | #f
87                   Order items; optional when last argument
88 split name | module | #f
89                   Pattern match component; optional when last argument
90                   (also see the '(_ . _) pattern)
91 all               Means `ci qual mac`
92 krl               Means `all sort mod`
93 base              For number valued pattern
94 raw               No listing symbol interpretation (i.e. x123 ~> x)
95EOS
96)
97
98;;;
99;;; REPL Integeration
100;;;
101
102(define (interp-split-arg loc arg)
103  (case arg
104    ((n nam name)     #:name )
105    ((m mod module)   #:module )
106    (else
107      (if (not arg)
108        #f
109        (error-apropos-sort-key loc "unknown split key" arg) ) ) ) )
110
111(define (interp-sort-arg loc arg)
112  (case arg
113    ((n nam name)     #:name )
114    ((m mod module)   #:module )
115    ((t typ type)     #:type )
116    (else
117      (if (not arg)
118        #f
119        (error-apropos-sort-key loc "unknown sort key" arg) ) ) ) )
120
121(define (display-apropos-help)
122  (print CSI-HELP)
123  (print)
124  (print HELP-TEXT) )
125
126(define (parse-csi-apropos-arguments iargs)
127  ;look at every argument
128  (let loop ((args iargs) (oargs '()))
129    ;
130    (define (restargs next optarg?)
131      (cond
132        ((null? next)
133          '() )
134        (optarg?
135          (cdr next) )
136        (else
137          next ) ) )
138    ;
139    (define (arg-next kwd init #!optional optarg?)
140      ;
141      (define (thisargs next kwd init optarg?)
142        (cond
143          ((null? next)
144            (cons* init kwd oargs) )
145          (optarg?
146            (cons* (optarg? (car next)) kwd oargs) )
147          (else
148            (cons* init kwd oargs) ) ) )
149      ;
150      (let* (
151        (next (cdr args) )
152        (args (restargs next optarg?) )
153        (oargs (thisargs next kwd init optarg?) ) )
154        ;
155        (loop args oargs) ) )
156    ;
157    (if (null? args)
158      ; original ordering
159      (reverse! oargs)
160      ;csi-apropos-syntax => keyword-apropos-syntax
161      (let ((arg (car args)))
162        (case arg
163          ;
164          ((krl)
165            (loop
166              (restargs (cons* 'all (cdr args)) #f)
167              (cons* #:module #:sort oargs)) )
168          ;
169          ((all)
170            (loop
171              (restargs (cdr args) #f)
172              (cons* #t #:case-insensitive? #t #:qualified? #t #:macros? oargs)) )
173          ;
174          ((mac macros)
175            (arg-next #:macros? #t) )
176          ;
177          ((qual qualified)
178            (arg-next #:qualified? #t) )
179          ;
180          ((ci case-insensitive)
181            (arg-next #:case-insensitive? #t) )
182          ;
183          ((raw)
184            (arg-next #:raw? #t) )
185          ;
186          ((base)
187            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)) )
188          ;
189          ((sort)
190            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
191          ;
192          ((split)
193            (arg-next #:split #f (cut interp-split-arg ',a <>)) )
194          ;
195          ((?)
196            (loop '() '()) )
197          ;
198          (else
199            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
200
201(define (csi-apropos-command)
202  ;FIXME could be empty of args
203  (let* (
204    (cmdlin (read-line))
205    (args (with-input-from-string cmdlin read-list))
206    (apropos-args (parse-csi-apropos-arguments args)) )
207    ;NOTE will not dump the symbol-table unless explicit - use '(: (* any))
208    (cond
209      ((null? apropos-args)
210        (display-apropos-help) )
211      ((null? (cdr apropos-args))
212        (apply apropos (car apropos-args) (apropos-default-options)) )
213      (else
214        (apply apropos apropos-args) ) ) ) )
215
216;;; Main
217
218(when (feature? csi:)
219  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )
220
221) ;module apropos-csi
Note: See TracBrowser for help on using the repository browser.