Changeset 13738 in project


Ignore:
Timestamp:
03/13/09 21:46:09 (11 years ago)
Author:
Kon Lovett
Message:

Chgd sort. Rmvd 1st class env routines.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/trunk/apropos.scm

    r13729 r13738  
    6060          (error-invalid-environment loc obj argnam) ) ) )
    6161
     62(define-inline (%check-sort-argument loc obj)
     63  (unless (or (eq? #:name obj) (eq? #:kind obj))
     64    (error-invalid-sort loc obj) ) )
     65
    6266;;;
    6367
    64 (require-library regex lolevel data-structures)
     68#;(require-library regex lolevel data-structures extras srfi-13 csi)
    6569
    6670(module apropos (;export
    6771  ; Original
    68   apropos
    69   apropos-list
    70   apropos-information-list
     72  apropos apropos-list apropos-information-list
    7173  ; Crispy
    72   apropos/environment
    73   apropos-list/environment
    74   apropos-information-list/environment
     74  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
    7575  ; 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)
    8179
    8280;;; Support
     
    9795  (error-argument-type loc obj 'environment argnam) )
    9896
    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) )
    10199
    102100;; Symbols
     
    144142;; Environment Search
    145143
    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?)
    166165  (append
    167    (search-environment env regexp (environment-predicate qualified?) lessp)
     166    (*apropos-list/environment loc regexp env #f qualified?)
    168167    (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?))) )
    174169
    175170;; Argument List Parsing
     
    183178  patt )
    184179
     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
    185197; #!optional (env (default-environment)) macenv
    186 ; #!key macros? qualified? sort?
     198; #!key macros? qualified?
    187199;
    188200; macenv is #t for default macro environment or a syntactic-environment object.
    189201;
    190 ; => (values macenv syms)
     202; => (values syms macenv)
    191203
    192204(define (parse-arguments loc patt args)
     
    196208          (macenv #f)
    197209          (qualified? #f)
    198           (lessp #f)
    199210          (1st-optarg #t)) ;keyword argument not considered an optional argument here
    200211      (let loop ((args args))
    201         (if (null? args) (values env macenv qualified? lessp)
     212        (if (null? args) (values env macenv qualified?)
    202213            (let ((arg (car args)))
    203214                    ;keyword argument?
     
    207218                    ((eq? #:qualified? arg)
    208219                      (when (cadr args) (set! qualified? #t))
    209                       (loop (cddr args)) )
    210                     ((eq? #:sort? arg)
    211                       (and-let* ((lsp (cadr args)))
    212                         (set! lessp
    213                           (cond ((boolean? lsp) symbol<?)
    214                                 ((procedure? lsp) lsp)
    215                                 (else
    216                                   (error-type-procedure loc lsp #:sort?)))))
    217220                      (loop (cddr args)) )
    218221                    ;optional argument?
     
    230233
    231234  (%check-search-pattern loc patt 'pattern)
    232   (receive (env macenv qualified? lessp) (parse-rest-arguments)
     235  (receive (env macenv qualified?) (parse-rest-arguments)
    233236    (%check-environment loc env 'environment)
    234237    (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?)
    240244  (%check-search-pattern loc patt 'pattern)
    241   (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))
    242245  (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) ) )
    244247
    245248; #!key qualified? sort?
     
    250253
    251254  (define (parse-rest-arguments)
    252     (let ((qualified? #f)
    253           (lessp #f))
     255    (let ((qualified? #f))
    254256      (let loop ((args args) (envs '()))
    255         (if (null? args) (values (reverse envs) qualified? lessp)
     257        (if (null? args) (values (reverse envs) qualified?)
    256258            (let ((arg (car args)))
    257                     ;keyword argument?
    258259              (cond ((eq? #:qualified? arg)
    259260                      (when (cadr args) (set! qualified? #t))
    260261                      (loop (cddr args) envs) )
    261                     ((eq? #:sort? arg)
    262                       (and-let* ((lsp (cadr args)))
    263                         (set! lessp
    264                           (cond ((boolean? lsp) symbol<?)
    265                                 ((procedure? lsp) lsp)
    266                                 (else
    267                                   (error-type-procedure loc lsp #:sort?)))))
    268                       (loop (cddr args) envs) )
    269262                    (else
    270263                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
    271264
    272265  (%check-search-pattern loc patt 'pattern)
    273   (receive (envs qualified? lessp) (parse-rest-arguments)
     266  (receive (envs qualified?) (parse-rest-arguments)
    274267    (let ((regexp (make-apropos-regexp patt)))
    275268      (let loop ((envs envs) (envsyms '()))
     
    279272                   (make-envsyms
    280273                    (lambda ()
    281                       `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )
     274                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
    282275              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
    283 
     276|#
    284277
    285278;; Display
    286279
     280; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
    287281(define (apropos-procedure-information proc)
    288282  (let ((info (procedure-information proc)))
     
    291285          (else `(procedure . ,(symbol->string info))) ) ) )
    292286
     287; => 'macro | 'keyword | 'variable | <procedure-information>
    293288(define (apropos-information sym macenv)
    294289  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
     
    299294                'variable ) ) ) ) )
    300295
     296(define (*apropos-information-list syms macenv)
     297  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
     298
    301299(define (display-spaces cnt)
    302300  (do ((i cnt (sub1 i)))
     
    304302    (display #\space) ) )
    305303
    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)) ) )
    313327
    314328;;; API
     
    317331
    318332(define (apropos patt . args)
    319   (receive (macenv syms) (parse-arguments 'apropos patt args)
    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) ) ) )
    322336
    323337(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)
    325339    syms ) )
    326340
    327341(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) ) )
    330344
    331345;; Crispy
    332346
    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
     352Displays information about identifiers matching {{PATTERN}} in the
     353{{ENVIRONMENT}}.
     354
     355Like {{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
     363Like {{apropos-list}}.
     364
     365==== apropos-information-list/environment
     366
     367<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
     368
     369Like {{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?)
    343381    syms ) )
    344382
    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) ) )
    349387
    350388;; Extra Crispy
    351389
     390==== apropos/environments
     391
     392<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
     393
     394Displays information about identifiers matching {{PATTERN}} in each
     395{{ENVIRONMENT}}.
     396
     397Like {{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
     406Like {{apropos-list}}.
     407
     408==== apropos-information-list/environments
     409
     410<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
     411
     412Like {{apropos-information-list}}.
     413
    352414(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
    364424(define (apropos-list/environments patt . args)
    365425  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
     
    367427(define (apropos-information-list/environments patt . args)
    368428  (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)))
    372430    (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") )
    373439
    374440) ;module apropos
Note: See TracChangeset for help on using the changeset viewer.