Changeset 13738 in project
- Timestamp:
- 03/13/09 21:46:09 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/apropos/trunk/apropos.scm
r13729 r13738 60 60 (error-invalid-environment loc obj argnam) ) ) ) 61 61 62 (define-inline (%check-sort-argument loc obj) 63 (unless (or (eq? #:name obj) (eq? #:kind obj)) 64 (error-invalid-sort loc obj) ) ) 65 62 66 ;;; 63 67 64 (require-library regex lolevel data-structures)68 #;(require-library regex lolevel data-structures extras srfi-13 csi) 65 69 66 70 (module apropos (;export 67 71 ; Original 68 apropos 69 apropos-list 70 apropos-information-list 72 apropos apropos-list apropos-information-list 71 73 ; Crispy 72 apropos/environment 73 apropos-list/environment 74 apropos-information-list/environment 74 #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment 75 75 ; Extra Crispy 76 apropos/environments 77 apropos-list/environments 78 apropos-information-list/environments) 79 80 (import scheme chicken regex lolevel data-structures) 76 #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments) 77 78 (import scheme chicken regex lolevel data-structures extras srfi-13 csi) 81 79 82 80 ;;; Support … … 97 95 (error-argument-type loc obj 'environment argnam) ) 98 96 99 (define (error- type-procedure loc obj argnam)100 (error-argument-type loc obj 'procedure argnam) )97 (define (error-invalid-sort loc obj) 98 (error-argument-type loc obj "#:name or #:kind" #:sort) ) 101 99 102 100 ;; Symbols … … 144 142 ;; Environment Search 145 143 146 (define (search-environment/searcher searcher env regexp pred lessp) 147 (let ((syms (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))))) 148 (if lessp (sort syms lessp) 149 syms ) ) ) 150 151 (define (search-environment env regexp pred lessp) 152 (search-environment/searcher ##sys#environment-symbols env regexp pred lessp) ) 153 154 (define (search-macro-environment macenv regexp pred lessp) 155 (search-environment/searcher ##sys#syntactic-environment-symbols macenv regexp pred lessp) ) 156 157 (define (environment-predicate qualified?) 158 (if qualified? global-bound? 159 (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))) ) ) 160 161 (define (macro-environment-predicate qualified?) 162 (if qualified? any? 163 (lambda (x) (not (##sys#qualified-symbol? x))) ) ) 164 165 (define (*apropos-list loc regexp env macenv qualified? lessp) 144 (define (*apropos-list/environment loc regexp env macenv? qualified?) 145 146 (define (search-environment/searcher searcher pred) 147 (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) ) 148 149 (define (search-environment) 150 (search-environment/searcher 151 ##sys#environment-symbols 152 (if qualified? global-bound? 153 (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) ) 154 155 (define (search-macro-environment) 156 (search-environment/searcher 157 ##sys#syntactic-environment-symbols 158 (if qualified? any? 159 (lambda (x) (not (##sys#qualified-symbol? x))))) ) 160 161 (if macenv? (search-macro-environment) (search-environment)) ) 162 163 ; => (envsyms . macenvsyms) 164 (define (*apropos-list loc regexp env macenv qualified?) 166 165 (append 167 (search-environment env regexp (environment-predicate qualified?) lessp)166 (*apropos-list/environment loc regexp env #f qualified?) 168 167 (if (not macenv) '() 169 (search-macro-environment macenv regexp (macro-environment-predicate qualified?) lessp))) ) 170 171 (define (*apropos-list/environment loc regexp env macenv? qualified? lessp) 172 (if macenv? (search-macro-environment env regexp (macro-environment-predicate qualified?) lessp)) 173 (search-environment env regexp (environment-predicate qualified?) lessp) ) 168 (*apropos-list/environment loc regexp macenv macenv qualified?))) ) 174 169 175 170 ;; Argument List Parsing … … 183 178 patt ) 184 179 180 ; => (values args val) 181 (define (keyword-argument args kwd #!optional val) 182 (let loop ((iargs args) (oargs '())) 183 (if (null? args) (values (reverse oargs) val) 184 (let ((arg (car args))) 185 (cond ((eq? kwd arg) 186 (set! val (cadr args)) 187 (loop (cddr iargs) oargs) ) 188 (else 189 (loop (cdr iargs) (cons arg oargs)) ) ) ) ) ) ) 190 191 ; => (values args sort) 192 (define (parse-sort-argument loc args) 193 (receive (args sort) (keyword-argument args #:sort #:name) 194 (%check-sort-argument loc sort) 195 (values args sort) ) ) 196 185 197 ; #!optional (env (default-environment)) macenv 186 ; #!key macros? qualified? sort?198 ; #!key macros? qualified? 187 199 ; 188 200 ; macenv is #t for default macro environment or a syntactic-environment object. 189 201 ; 190 ; => (values macenv syms)202 ; => (values syms macenv) 191 203 192 204 (define (parse-arguments loc patt args) … … 196 208 (macenv #f) 197 209 (qualified? #f) 198 (lessp #f)199 210 (1st-optarg #t)) ;keyword argument not considered an optional argument here 200 211 (let loop ((args args)) 201 (if (null? args) (values env macenv qualified? lessp)212 (if (null? args) (values env macenv qualified?) 202 213 (let ((arg (car args))) 203 214 ;keyword argument? … … 207 218 ((eq? #:qualified? arg) 208 219 (when (cadr args) (set! qualified? #t)) 209 (loop (cddr args)) )210 ((eq? #:sort? arg)211 (and-let* ((lsp (cadr args)))212 (set! lessp213 (cond ((boolean? lsp) symbol<?)214 ((procedure? lsp) lsp)215 (else216 (error-type-procedure loc lsp #:sort?)))))217 220 (loop (cddr args)) ) 218 221 ;optional argument? … … 230 233 231 234 (%check-search-pattern loc patt 'pattern) 232 (receive (env macenv qualified? lessp) (parse-rest-arguments)235 (receive (env macenv qualified?) (parse-rest-arguments) 233 236 (%check-environment loc env 'environment) 234 237 (when macenv (%check-environment loc macenv #:macros?)) 235 (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) ) 236 237 ; => (values macenv syms) 238 239 (define (parse-arguments/environment loc patt env qualified? lessp) 238 (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) ) 239 240 #| 241 ; => (values envsyms macenv) 242 243 (define (parse-arguments/environment loc patt env qualified?) 240 244 (%check-search-pattern loc patt 'pattern) 241 (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))242 245 (let ((macenv (%check-environment* loc env 'environment))) 243 (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )246 (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) ) 244 247 245 248 ; #!key qualified? sort? … … 250 253 251 254 (define (parse-rest-arguments) 252 (let ((qualified? #f) 253 (lessp #f)) 255 (let ((qualified? #f)) 254 256 (let loop ((args args) (envs '())) 255 (if (null? args) (values (reverse envs) qualified? lessp)257 (if (null? args) (values (reverse envs) qualified?) 256 258 (let ((arg (car args))) 257 ;keyword argument?258 259 (cond ((eq? #:qualified? arg) 259 260 (when (cadr args) (set! qualified? #t)) 260 261 (loop (cddr args) envs) ) 261 ((eq? #:sort? arg)262 (and-let* ((lsp (cadr args)))263 (set! lessp264 (cond ((boolean? lsp) symbol<?)265 ((procedure? lsp) lsp)266 (else267 (error-type-procedure loc lsp #:sort?)))))268 (loop (cddr args) envs) )269 262 (else 270 263 (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) ) 271 264 272 265 (%check-search-pattern loc patt 'pattern) 273 (receive (envs qualified? lessp) (parse-rest-arguments)266 (receive (envs qualified?) (parse-rest-arguments) 274 267 (let ((regexp (make-apropos-regexp patt))) 275 268 (let loop ((envs envs) (envsyms '())) … … 279 272 (make-envsyms 280 273 (lambda () 281 `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )274 `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) ) 282 275 (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) 283 276 |# 284 277 285 278 ;; Display 286 279 280 ; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>) 287 281 (define (apropos-procedure-information proc) 288 282 (let ((info (procedure-information proc))) … … 291 285 (else `(procedure . ,(symbol->string info))) ) ) ) 292 286 287 ; => 'macro | 'keyword | 'variable | <procedure-information> 293 288 (define (apropos-information sym macenv) 294 289 (cond ((and macenv (##sys#macro? sym macenv)) 'macro) … … 299 294 'variable ) ) ) ) ) 300 295 296 (define (*apropos-information-list syms macenv) 297 (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) 298 301 299 (define (display-spaces cnt) 302 300 (do ((i cnt (sub1 i))) … … 304 302 (display #\space) ) ) 305 303 306 (define (display-symbol-information sym maxsymlen macenv) 307 (display sym) (display-spaces (- maxsymlen (symbol-print-length sym))) 308 (let ((info (apropos-information sym macenv))) 309 (display #\space) 310 (if (symbol? info) (display info) 311 (begin (display (car info)) (display #\space) (write (cdr info)) ) ) ) 312 (newline) ) 304 (define (display-apropos syms macenv sort) 305 (let ((maxsymlen (max-symbol-print-width syms)) 306 (lessp 307 (case sort 308 ((#:name) 309 (lambda (pr1 pr2) (symbol<? (car pr1) (car pr2))) ) 310 ((#:kind) 311 (lambda (pr1 pr2) 312 (let ((s1 (car pr1)) (s2 (car pr2))) 313 (symbol<? (if (symbol? s1) s1 (car s1)) (if (symbol? s2) s2 (car s2)))))))) ) 314 315 (define (display-symbol-information apr) 316 (let ((sym (car apr)) 317 (info (cdr apr))) 318 (display sym) (display-spaces (- maxsymlen (symbol-print-length sym))) 319 (display #\space) 320 (if (symbol? info) (display info) 321 (begin (display (car info)) (display #\space) (write (cdr info)) ) ) 322 (newline) ) ) 323 324 (for-each 325 (cut display-symbol-information <>) 326 (sort (*apropos-information-list syms macenv) lessp)) ) ) 313 327 314 328 ;;; API … … 317 331 318 332 (define (apropos patt . args) 319 (receive ( macenv syms) (parse-arguments 'apropos pattargs)320 ( let ((maxsymlen (max-symbol-print-width syms)))321 ( for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )333 (receive (args sort) (parse-sort-argument 'apropos args) 334 (receive (syms macenv) (parse-arguments 'apropos patt args) 335 (display-apropos syms macenv sort) ) ) ) 322 336 323 337 (define (apropos-list patt . args) 324 (receive ( macenv syms) (parse-arguments 'apropos-list patt args)338 (receive (syms macenv) (parse-arguments 'apropos-list patt args) 325 339 syms ) ) 326 340 327 341 (define (apropos-information-list patt . args) 328 (receive ( macenv syms) (parse-arguments 'apropos-information-list patt args)329 ( map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )342 (receive (syms macenv) (parse-arguments 'apropos-information-list patt args) 343 (*apropos-information-list syms macenv) ) ) 330 344 331 345 ;; Crispy 332 346 333 (define (apropos/environment patt env #!key qualified? (sort? symbol<?)) 334 (receive (macenv syms) 335 (parse-arguments/environment 'apropos/environment patt env qualified? sort?) 336 (let ((maxsymlen (max-symbol-print-width syms))) 337 (newline) 338 (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) ) 339 340 (define (apropos-list/environment patt env #!key qualified? (sort? symbol<?)) 341 (receive (macenv syms) 342 (parse-arguments/environment 'apropos/environment patt env qualified? sort?) 347 #| 348 ==== apropos/environment 349 350 <procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure> 351 352 Displays information about identifiers matching {{PATTERN}} in the 353 {{ENVIRONMENT}}. 354 355 Like {{apropos}}. 356 357 ; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}. 358 359 ==== apropos-list/environment 360 361 <procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure> 362 363 Like {{apropos-list}}. 364 365 ==== apropos-information-list/environment 366 367 <procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure> 368 369 Like {{apropos-information-list}}. 370 371 (define (apropos/environment patt env #!key qualified? (sort #:name)) 372 (%check-sort-argument 'apropos/environment sort) 373 (receive (syms macenv) 374 (parse-arguments/environment 'apropos/environment patt env qualified?) 375 (newline) 376 (display-apropos syms macenv sort) ) ) 377 378 (define (apropos-list/environment patt env #!key qualified?) 379 (receive (syms macenv) 380 (parse-arguments/environment 'apropos/environment patt env qualified?) 343 381 syms ) ) 344 382 345 (define (apropos-information-list/environment patt env #!key qualified? (sort? symbol<?))346 (receive ( macenv syms)347 (parse-arguments/environment 'apropos/environment patt env qualified? sort?)348 ( map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )383 (define (apropos-information-list/environment patt env #!key qualified?) 384 (receive (syms macenv) 385 (parse-arguments/environment 'apropos/environment patt env qualified?) 386 (*apropos-information-list syms macenv) ) ) 349 387 350 388 ;; Extra Crispy 351 389 390 ==== apropos/environments 391 392 <procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure> 393 394 Displays information about identifiers matching {{PATTERN}} in each 395 {{ENVIRONMENT}}. 396 397 Like {{apropos}}. 398 399 ; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed. 400 401 ==== apropos-list/environments 402 403 <procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure> 404 405 406 Like {{apropos-list}}. 407 408 ==== apropos-information-list/environments 409 410 <procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure> 411 412 Like {{apropos-information-list}}. 413 352 414 (define (apropos/environments patt . args) 353 (let ((i 0)) 354 (for-each 355 (lambda (macenv+syms) 356 (set! i (add1 i)) 357 (newline) (print "** Environment " i " **") (newline) 358 (let ((macenv (car macenv+syms)) 359 (syms (cdr macenv+syms))) 360 (let ((maxsymlen (max-symbol-print-width syms))) 361 (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) ) 362 (parse-arguments/environments 'apropos/environments patt args)) ) ) 363 415 (receive (args sort) (parse-sort-argument 'apropos/environments args) 416 (let ((i 0)) 417 (for-each 418 (lambda (macenv+syms) 419 (set! i (add1 i)) 420 (newline) (print "** Environment " i " **") (newline) 421 (display-apropos (cdr macenv+syms) (car macenv+syms) sort) ) 422 (parse-arguments/environments 'apropos/environments patt args)) ) ) ) 423 364 424 (define (apropos-list/environments patt . args) 365 425 (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) ) … … 367 427 (define (apropos-information-list/environments patt . args) 368 428 (map 369 (lambda (macenv+syms) 370 (let ((macenv (car macenv+syms))) 371 (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) ) 429 (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms))) 372 430 (parse-arguments/environments 'apropos-information-list/environments patt args)) ) 431 |# 432 433 ;;; 434 435 (when (feature? csi:) 436 (toplevel-command 'a 437 (lambda () (apropos (string-trim-both (read-line)))) 438 " ,a PATT ... Apropos identifier") ) 373 439 374 440 ) ;module apropos
Note: See TracChangeset
for help on using the changeset viewer.