Changeset 13707 in project


Ignore:
Timestamp:
03/12/09 12:25:08 (11 years ago)
Author:
Kon Lovett
Message:

Added support for qualified symbols yes/no.

File:
1 edited

Legend:

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

    r13703 r13707  
    2323    ##sys#current-environment ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
    2424    ##sys#environment? ##sys#environment-symbols
    25     ##sys#symbol->qualified-string
     25    ##sys#qualified-symbol? ##sys#symbol->qualified-string
    2626    ##sys#signal-hook ) )
    2727
     
    2929;;; Prelude
    3030
    31 (require-library regex lolevel)
     31(require-library regex lolevel data-structures)
    3232
    3333
     
    7878  apropos-information-list/environments)
    7979
    80 (import scheme chicken regex lolevel)
     80(import scheme chicken regex lolevel data-structures)
    8181
    8282;;; Suuport
     
    104104(define (symbol-match? sym regexp) (string-search regexp (symbol->string sym)))
    105105
    106 ;; Environments
     106;; Environment Search
    107107
    108108(define (search-environment env regexp pred)
    109   (##sys#environment-symbols env (lambda (sym) (and symbol-match? sym regexp) (pred sym))) )
    110 
    111 (define (search-macro-environment macenv regexp)
    112   (##sys#syntactic-environment-symbols macenv (cut symbol-match? <> regexp)) )
    113 
    114 (define (*apropos-list loc regexp env macenv)
     109  (##sys#environment-symbols
     110    env
     111    (lambda (sym)
     112      (and (symbol-match? sym regexp) (pred sym)))) )
     113
     114(define (search-macro-environment macenv regexp pred)
     115  (##sys#syntactic-environment-symbols
     116    macenv
     117    (lambda (sym)
     118      (and (symbol-match? sym regexp) (pred sym)))) )
     119
     120;; Environment Search -> List
     121
     122(define (*apropos-list loc regexp env macenv qualified?)
    115123  (append
    116    (search-environment env regexp global-bound?)
    117    (if macenv (search-macro-environment macenv regexp) '())) )
    118 
    119 (define (*apropos-list/environment loc regexp env macenv)
    120   (if macenv (search-macro-environment env regexp)
    121       (search-environment env regexp global-bound?) ) )
    122 
    123 ;;
     124   (search-environment
     125     env
     126     regexp
     127     (if qualified? global-bound?
     128         (lambda (x)
     129           (and (not (##sys#qualified-symbol? x)) (global-bound? x)))))
     130    (if (not macenv) '()
     131        (search-macro-environment
     132         macenv
     133         regexp
     134         (if qualified? any?
     135             (lambda (x)
     136               (not (##sys#qualified-symbol? x))))))) )
     137
     138(define (*apropos-list/environment loc regexp env macenv qualified?)
     139  (if macenv (search-macro-environment env regexp #f)
     140      (search-environment
     141        env
     142        regexp
     143        (if qualified? global-bound?
     144            (lambda (x)
     145              (and (not (##sys#qualified-symbol? x)) (global-bound? x)) ) ) ) ) )
     146
     147;; Argument List Parsing
    124148
    125149(define (make-apropos-regexp patt)
     
    129153
    130154; #!optional (env (interaction-environment)) macenv
    131 ; #!key macros?
     155; #!key macros? qualified?
    132156;
    133157; macenv is #t for default macro environment (##sys#current-environment) or a
    134158; syntactic-environment object.
    135159;
    136 ; => (values macenv syms)
     160; => (values macenv qualified? syms)
    137161(define (parse-arguments loc patt args)
    138   (define (parse-rest-arguments loc args)
     162  (define (parse-rest-arguments args)
    139163    (let ((env (interaction-environment))
    140164          (macenv #f)
     165          (qualified? #f)
    141166          (1st-optarg #t)) ;keyword argument not considered an optional argument here
    142167      (let loop ((args args))
    143         (when (pair? args)
    144           (let ((arg (car args)))
    145                   ;keyword argument?
    146             (cond ((eq? #:macros? arg)
    147                     (when (cadr args) (set! macenv #t))
    148                     (loop (cddr args)) )
    149                   ;optional argument?
    150                   (arg
    151                          ;specific environment?
    152                     (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
    153                           ;default macro environment?
    154                           ((boolean? args) (set! macenv (##sys#current-environment)))
    155                           ;specific macro environment?
    156                           (else (set! macenv arg)))
    157                     (loop (cdr args)) )
    158                   ;accept #f for macenv
    159                   (else
    160                     (loop (cdr args)) ) ) ) )
    161       (values env macenv) ) ) )
     168        (if (null? args) (values env qualified? macenv)
     169            (let ((arg (car args)))
     170                    ;keyword argument?
     171              (cond ((eq? #:macros? arg)
     172                      (when (cadr args) (set! macenv (##sys#current-environment)))
     173                      (loop (cddr args)) )
     174                    ((eq? #:qualified? arg)
     175                      (when (cadr args) (set! qualified? #t))
     176                      (loop (cddr args)) )
     177                    ;optional argument?
     178                    (arg
     179                           ;specific environment?
     180                      (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
     181                            ;default macro environment?
     182                            ((boolean? args) (set! macenv (##sys#current-environment)))
     183                            ;specific macro environment?
     184                            (else (set! macenv arg)))
     185                      (loop (cdr args)) )
     186                    ;accept #f for macenv
     187                    (else
     188                      (loop (cdr args)) ) ) ) ) ) ) )
    162189  (%check-search-pattern loc patt)
    163   (receive (env macenv) (parse-rest-arguments loc args)
     190  (receive (env macenv qualified?) (parse-rest-arguments args)
    164191    (%check-environment loc env)
    165192    (%check-macro-environment loc macenv)
    166     (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv)) ) )
     193    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?)) ) )
    167194
    168195; => (values macenv syms)
    169 (define (parse-arguments/environment loc patt env)
     196(define (parse-arguments/environment loc patt env qualified?)
    170197  (%check-search-pattern loc patt)
    171198  (let ((macenv (check-any-environment/->syntactic-environment? loc env)))
    172     (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv)) ) )
    173 
    174 ; => envsyms
    175 (define (parse-arguments/environments loc patt envs)
     199    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?)) ) )
     200
     201; => (... (macenv . syms) ...)
     202(define (parse-arguments/environments loc patt args)
     203  (define (parse-rest-arguments args)
     204    (let ((qualified? #f))
     205      (let loop ((args args) (envs '()))
     206        (if (null? args) (values (reverse envs) qualified?)
     207            (let ((arg (car args)))
     208                    ;keyword argument?
     209              (cond ((eq? #:qualified? arg)
     210                      (when (cadr args) (set! qualified? #t))
     211                      (loop (cddr args) envs) )
     212                    (else
     213                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
    176214  (%check-search-pattern loc patt)
    177   (let ((regexp (make-apropos-regexp patt)))
    178     (let loop ((envs envs) (envsyms '()))
    179       (if (null? envs) envsyms
    180           (let* ((env (car envs))
    181                  (macenv (check-any-environment/->syntactic-environment? loc env)) )
    182             (loop
    183               (cdr envs)
    184               (append
    185                 envsyms
    186                 `((,macenv . ,(*apropos-list/environment loc regexp env macenv))))) ) ) ) ) )
     215  (receive (envs qualified?) (parse-rest-arguments args)
     216    (let ((regexp (make-apropos-regexp patt)))
     217      (let loop ((envs envs) (envsyms '()))
     218        (if (null? envs) (reverse envsyms)
     219            (let* ((env (car envs))
     220                   (macenv (check-any-environment/->syntactic-environment? loc env)) )
     221              (loop
     222                (cdr envs)
     223                (cons
     224                  `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?))
     225                  envsyms)) ) ) ) ) ) )
    187226
    188227
     
    225264
    226265(define (apropos-list patt . args)
    227   (receive (macenv syms) (parse-arguments 'apropos-list patt args) syms) )
     266  (receive (macenv syms) (parse-arguments 'apropos-list patt args)
     267    syms ) )
    228268
    229269(define (apropos-information-list patt . args)
     
    233273;; Crispy
    234274
    235 (define (apropos/environment patt env)
    236   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env)
     275(define (apropos/environment patt env #!key qualified?)
     276  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
    237277    (let ((maxsymlen (max-symbol-print-width syms)))
    238278      (newline)
    239279      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
    240280
    241 (define (apropos-list/environment patt env)
    242   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env) syms) )
    243 
    244 (define (apropos-information-list/environment patt env)
    245   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env)
     281(define (apropos-list/environment patt env #!key qualified?)
     282  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
     283    syms ) )
     284
     285(define (apropos-information-list/environment patt env #!key qualified?)
     286  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
    246287    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
    247288
    248289;; Extra Crispy
    249290
    250 (define (apropos/environments patt . envs)
     291(define (apropos/environments patt . args)
    251292  (let ((i 0))
    252293    (for-each
     
    258299          (let ((maxsymlen (max-symbol-print-width syms)))
    259300            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
    260       (parse-arguments/environments 'apropos/environments patt envs)) ) )
     301      (parse-arguments/environments 'apropos/environments patt args)) ) )
    261302   
    262 (define (apropos-list/environments patt . envs)
    263   (map cdr (parse-arguments/environments 'apropos-list/environments patt envs)) )
    264 
    265 (define (apropos-information-list/environments patt . envs)
     303(define (apropos-list/environments patt . args)
     304  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
     305
     306(define (apropos-information-list/environments patt . args)
    266307  (map
    267308    (lambda (macenv+syms)
     
    270311          (lambda (sym) (cons sym (apropos-information sym macenv)))
    271312          (cdr macenv+syms)) ) )
    272     (parse-arguments/environments 'apropos-information-list/environments patt envs)) )
     313    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
    273314
    274315) ;module apropos
Note: See TracChangeset for help on using the changeset viewer.