Changeset 13746 in project


Ignore:
Timestamp:
03/14/09 07:41:37 (11 years ago)
Author:
Kon Lovett
Message:

Updated release w/ csi command for apropos.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/tags/1.0.0/apropos.scm

    r13730 r13746  
    4747
    4848(define-inline (%check-search-pattern loc obj argnam)
    49   (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
    50     (error-invalid-search loc obj argnam) ) )
    51 
    52 (define-inline (%check-environment loc obj argnam)
    53   (unless (or (##sys#environment? obj) (##sys#syntactic-environment? obj))
    54     (error-invalid-environment loc obj argnam) ) )
    55 
     49  (cond-expand
     50    (unsafe
     51      (unless (or (%keyword? obj) (%symbol? obj) (%string? obj) (regexp? obj))
     52        (error-invalid-search loc obj argnam) ) )
     53    (else
     54      (unless (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj))
     55        (error-invalid-search loc obj argnam) ) ) ) )
     56
     57#; ;UNUSED
    5658(define-inline (%check-environment* loc obj argnam)
    5759  (cond ((##sys#environment? obj) #f)
     
    6062          (error-invalid-environment loc obj argnam) ) ) )
    6163
     64(define-inline (%check-sortkey-argument loc obj)
     65  (unless (or (not obj) (eq? #:name obj) (eq? #:kind obj))
     66    (error-invalid-sortkey loc obj) ) )
     67
    6268;;;
    6369
    64 (require-library regex lolevel data-structures)
     70(require-library regex lolevel data-structures ports extras utils srfi-13)
    6571
    6672(module apropos (;export
    6773  ; Original
    68   apropos
    69   apropos-list
    70   apropos-information-list
     74  apropos apropos-list apropos-information-list
    7175  ; Crispy
    72   apropos/environment
    73   apropos-list/environment
    74   apropos-information-list/environment
     76  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
    7577  ; Extra Crispy
    76   apropos/environments
    77   apropos-list/environments
    78   apropos-information-list/environments)
    79 
    80 (import scheme chicken regex lolevel data-structures)
     78  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
     79
     80(import scheme chicken regex lolevel data-structures ports extras utils srfi-13 csi)
    8181
    8282;;; Support
     
    9494  (error-argument-type loc obj "symbol/string/regexp" argnam) )
    9595
     96#; ;UNUSED
    9697(define (error-invalid-environment loc obj argnam)
    9798  (error-argument-type loc obj 'environment argnam) )
    9899
    99 (define (error-type-procedure loc obj argnam)
    100   (error-argument-type loc obj 'procedure argnam) )
     100(define (error-invalid-sortkey loc obj)
     101  (error-argument-type loc obj "#:name, #:kind or #f" #:sort) )
     102
     103(define (error-invalid-argument loc arg)
     104  (if (keyword? arg) (error loc "unrecognized keyword argument" arg)
     105      (error loc "unrecognized argument" arg) ) )
    101106
    102107;; Symbols
     108
     109(define (symbol->keyword sym)
     110  (if (keyword? sym) sym
     111      (string->keyword (symbol->string sym)) ) )
     112
     113(define (symbol=? x y)
     114  (cond-expand
     115    (unsafe
     116      (%string=? (%symbol-string x) (%symbol-string y)) )
     117    (else
     118      (let ((sx (##sys#symbol->string x))
     119            (sy (##sys#symbol->string y))
     120            (px (##sys#qualified-symbol-prefix x))
     121            (py (##sys#qualified-symbol-prefix y)))
     122        (cond (px (and py (string=? px py) (string=? sx sy)))
     123              (py (or (not px) (and (string=? px py) (string=? sx sy))))
     124              (else (string=? sx sy) ) ) ) ) ) )
    103125
    104126(define (symbol<? x y)
     
    107129      (%string<? (%symbol-string x) (%symbol-string y)) )
    108130    (else
    109       (let ((x (##sys#symbol->string x))
    110             (y (##sys#symbol->string y))
     131      (let ((sx (##sys#symbol->string x))
     132            (sy (##sys#symbol->string y))
    111133            (px (##sys#qualified-symbol-prefix x))
    112134            (py (##sys#qualified-symbol-prefix y)))
    113         (cond (px (and py (string<? px py) (string<? x y)))
    114               (py (or (not px) (and (string<? px py) (string<? x y))))
    115               (else (string<? x y) ) ) ) ) ) )
     135        (cond (px (and py (string<? px py) (string<? sx sy)))
     136              (py (or (not px) (and (string<? px py) (string<? sx sy))))
     137              (else (string<? sx sy) ) ) ) ) ) )
    116138
    117139(define (symbol-print-length sym)
     
    144166;; Environment Search
    145167
    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)
     168(define (*apropos-list/environment loc regexp env macenv? qualified?)
     169
     170  (define (search-environment/searcher searcher pred)
     171    (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
     172
     173  (define (search-environment)
     174    (search-environment/searcher
     175      ##sys#environment-symbols
     176      (if qualified? global-bound?
     177          (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) )
     178
     179  (define (search-macro-environment)
     180    (search-environment/searcher
     181      ##sys#syntactic-environment-symbols
     182      (if qualified? any?
     183          (lambda (x) (not (##sys#qualified-symbol? x))))) )
     184
     185  (if macenv? (search-macro-environment) (search-environment)) )
     186
     187; => (envsyms . macenvsyms)
     188(define (*apropos-list loc regexp env macenv qualified?)
    166189  (append
    167    (search-environment env regexp (environment-predicate qualified?) lessp)
     190    (*apropos-list/environment loc regexp env #f qualified?)
    168191    (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) )
     192        (*apropos-list/environment loc regexp macenv #t qualified?))) )
    174193
    175194;; Argument List Parsing
     
    183202  patt )
    184203
     204; => (values val args)
     205(define (keyword-argument args kwd #!optional val)
     206  (let loop ((args args) (oargs '()))
     207    (if (null? args) (values val (reverse oargs))
     208        (let ((arg (car args)))
     209          (cond ((eq? kwd arg)
     210                  (set! val (cadr args))
     211                  (loop (cddr args) oargs) )
     212                (else
     213                  (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
     214
     215; => (values sortkey args)
     216(define (parse-sortkey-argument loc args)
     217  (receive (sortkey args) (keyword-argument args #:sort #:kind)
     218    (%check-sortkey-argument loc sortkey)
     219    (values sortkey args) ) )
     220
    185221; #!optional (env (default-environment)) macenv
    186 ; #!key macros? qualified? sort?
     222; #!key macros? qualified?
    187223;
    188224; macenv is #t for default macro environment or a syntactic-environment object.
    189225;
    190 ; => (values macenv syms)
     226; => (values syms macenv)
    191227
    192228(define (parse-arguments loc patt args)
    193229
     230  ; => (values env macenv qualified?)
    194231  (define (parse-rest-arguments)
    195232    (let ((env (default-environment))
    196233          (macenv #f)
    197234          (qualified? #f)
    198           (lessp #f)
    199           (1st-optarg #t)) ;keyword argument not considered an optional argument here
     235          (1st-arg? #t))
    200236      (let loop ((args args))
    201         (if (null? args) (values env macenv qualified? lessp)
     237        (if (null? args) (values env macenv qualified?)
    202238            (let ((arg (car args)))
    203239                    ;keyword argument?
     
    208244                      (when (cadr args) (set! qualified? #t))
    209245                      (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?)))))
    217                       (loop (cddr args)) )
    218                     ;optional argument?
    219                     (arg
    220                            ;specific environment?
    221                       (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
    222                             ;default macro environment?
    223                             ((boolean? args) (set! macenv (default-macro-environment)))
    224                             ;specific macro environment?
    225                             (else (set! macenv arg)))
     246                    ;environment argument?
     247                    (1st-arg?
     248                      (unless (##sys#environment? arg)
     249                        (error-invalid-argument loc arg) )
     250                      (set! 1st-arg? #f)
     251                      (set! env arg)
    226252                      (loop (cdr args)) )
    227                     ;accept #f for macenv
     253                    ;unkown argument
    228254                    (else
    229                       (loop (cdr args)) ) ) ) ) ) ) )
     255                      (error-invalid-argument loc arg) ) ) ) ) ) ) )
    230256
    231257  (%check-search-pattern loc patt 'pattern)
    232   (receive (env macenv qualified? lessp) (parse-rest-arguments)
    233     (%check-environment loc env 'environment)
    234     (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)
     258  (receive (env macenv qualified?) (parse-rest-arguments)
     259    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
     260
     261#|
     262; => (values envsyms macenv)
     263
     264(define (parse-arguments/environment loc patt env qualified?)
    240265  (%check-search-pattern loc patt 'pattern)
    241   (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))
    242266  (let ((macenv (%check-environment* loc env 'environment)))
    243     (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
     267    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
    244268
    245269; #!key qualified? sort?
     
    250274
    251275  (define (parse-rest-arguments)
    252     (let ((qualified? #f)
    253           (lessp #f))
     276    (let ((qualified? #f))
    254277      (let loop ((args args) (envs '()))
    255         (if (null? args) (values (reverse envs) qualified? lessp)
     278        (if (null? args) (values (reverse envs) qualified?)
    256279            (let ((arg (car args)))
    257280                    ;keyword argument?
     
    259282                      (when (cadr args) (set! qualified? #t))
    260283                      (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) )
     284                    ;environment argument?
    269285                    (else
    270                       (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
     286                      (unless (##sys#environment? arg)
     287                        (error-invalid-argument loc arg) )
     288                      (loop (cdr args) (cons env envs)) ) ) ) ) ) ) )
    271289
    272290  (%check-search-pattern loc patt 'pattern)
    273   (receive (envs qualified? lessp) (parse-rest-arguments)
     291  (receive (envs qualified?) (parse-rest-arguments)
    274292    (let ((regexp (make-apropos-regexp patt)))
    275293      (let loop ((envs envs) (envsyms '()))
     
    279297                   (make-envsyms
    280298                    (lambda ()
    281                       `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )
     299                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
    282300              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
    283 
     301|#
    284302
    285303;; Display
    286304
     305; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
    287306(define (apropos-procedure-information proc)
    288307  (let ((info (procedure-information proc)))
     
    291310          (else `(procedure . ,(symbol->string info))) ) ) )
    292311
     312; => 'macro | 'keyword | 'variable | <procedure-information>
    293313(define (apropos-information sym macenv)
    294314  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
     
    299319                'variable ) ) ) ) )
    300320
     321(define (*apropos-information-list syms macenv)
     322  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
     323
    301324(define (display-spaces cnt)
    302325  (do ((i cnt (sub1 i)))
    303       ((negative? i))
     326      ((zero? i))
    304327    (display #\space) ) )
    305328
    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) )
     329(define (apropos-information-name<? apr1 apr2)
     330  (symbol<? (car apr1) (car apr2)) )
     331
     332(define (apropos-information-kind=? apr1 apr2)
     333  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
     334    (symbol=? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
     335
     336(define (apropos-information-kind<? apr1 apr2)
     337  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
     338    (symbol<? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
     339
     340(define (apropos-information<? apr1 apr2)
     341  (if (apropos-information-kind=? apr1 apr2) (apropos-information-name<? apr1 apr2)
     342      (apropos-information-kind<? apr1 apr2) ) )
     343
     344(define (display-apropos syms macenv sortkey)
     345  (let ((maxsymlen (max-symbol-print-width syms)))
     346
     347    (define (display-symbol-information apr)
     348      (let ((sym (car apr)))
     349        (display sym) (display #\space) (display-spaces (- maxsymlen (symbol-print-length sym))) )
     350      (display #\space)
     351      (let ((info (cdr apr)))
     352        (cond ((symbol? info) (display info) )
     353              (else (display (car info)) (display #\space) (write (cdr info)) ) ) )
     354      (newline) )
     355
     356    (let ((lessp
     357            (case sortkey
     358              ((#:name) apropos-information-name<? )
     359              ((#:kind) apropos-information<? )
     360              (else     #f ) ) )
     361          (ail (*apropos-information-list syms macenv)))
     362      (for-each display-symbol-information (if lessp (sort ail lessp) ail)) ) ) )
    313363
    314364;;; API
     
    317367
    318368(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) ) ) )
     369  (receive (sortkey args) (parse-sortkey-argument 'apropos args)
     370    (receive (syms macenv) (parse-arguments 'apropos patt args)
     371      (display-apropos syms macenv sortkey) ) ) )
    322372
    323373(define (apropos-list patt . args)
    324   (receive (macenv syms) (parse-arguments 'apropos-list patt args)
     374  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
    325375    syms ) )
    326376
    327377(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) ) )
     378  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
     379    (*apropos-information-list syms macenv) ) )
    330380
    331381;; Crispy
    332382
    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?)
     383#|
     384==== apropos/environment
     385
     386<procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure>
     387
     388Displays information about identifiers matching {{PATTERN}} in the
     389{{ENVIRONMENT}}.
     390
     391Like {{apropos}}.
     392
     393; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}.
     394
     395==== apropos-list/environment
     396
     397<procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
     398
     399Like {{apropos-list}}.
     400
     401==== apropos-information-list/environment
     402
     403<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
     404
     405Like {{apropos-information-list}}.
     406
     407(define (apropos/environment patt env #!key qualified? (sort #:name))
     408  (%check-sortkey-argument 'apropos/environment sort)
     409  (receive (syms macenv)
     410           (parse-arguments/environment 'apropos/environment patt env qualified?)
     411    (newline)
     412    (display-apropos syms macenv sortkey) ) )
     413
     414(define (apropos-list/environment patt env #!key qualified?)
     415  (receive (syms macenv)
     416           (parse-arguments/environment 'apropos/environment patt env qualified?)
    343417    syms ) )
    344418
    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) ) )
     419(define (apropos-information-list/environment patt env #!key qualified?)
     420  (receive (syms macenv)
     421           (parse-arguments/environment 'apropos/environment patt env qualified?)
     422    (*apropos-information-list syms macenv) ) )
    349423
    350424;; Extra Crispy
    351425
     426==== apropos/environments
     427
     428<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
     429
     430Displays information about identifiers matching {{PATTERN}} in each
     431{{ENVIRONMENT}}.
     432
     433Like {{apropos}}.
     434
     435; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
     436
     437==== apropos-list/environments
     438
     439<procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
     440
     441
     442Like {{apropos-list}}.
     443
     444==== apropos-information-list/environments
     445
     446<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
     447
     448Like {{apropos-information-list}}.
     449
    352450(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    
     451  (receive (sortkey args) (parse-sortkey-argument 'apropos/environments args)
     452    (let ((i 0))
     453      (for-each
     454        (lambda (macenv+syms)
     455          (set! i (add1 i))
     456          (newline) (print "** Environment " i " **") (newline)
     457          (display-apropos (cdr macenv+syms) (car macenv+syms) sortkey) )
     458        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
     459
    364460(define (apropos-list/environments patt . args)
    365461  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
     
    367463(define (apropos-information-list/environments patt . args)
    368464  (map
    369     (lambda (macenv+syms)
    370       (let ((macenv (car macenv+syms)))
    371         (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) )
     465    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
    372466    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
     467|#
     468
     469;;;
     470
     471(define (parse-csi-apropos-arguments args)
     472  (let loop ((args args) (oargs '()))
     473    (if (null? args) (reverse oargs)
     474        (let ((arg (car args)))
     475          (case arg
     476            ((macros)
     477              (loop (cdr args) (cons #t (cons #:macros? oargs))) )
     478            ((qualified)
     479              (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
     480            ((sort)
     481              (let* ((val (cadr args))
     482                     (key (if (symbol? val) (symbol->keyword val) val)))
     483                (loop (cddr args) (cons key (cons #:sort oargs))) ) )
     484            (else
     485              (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
     486
     487(when (feature? csi:)
     488  (toplevel-command 'a
     489    (lambda ()
     490      (apply apropos
     491        (parse-csi-apropos-arguments
     492          (with-input-from-string (string-trim-both (read-line)) read-file))) )
     493    ",a PATT [ARG...]  Apropos of PATT with ARG from macros, qualified, or sort name/#f") )
    373494
    374495) ;module apropos
Note: See TracChangeset for help on using the changeset viewer.