Changeset 13738 in project

Timestamp:

03/13/09 21:46:09 (11 years ago)

Author:

Kon Lovett

Message:

Chgd sort. Rmvd 1st class env routines.

File:

• release/4/apropos/trunk/apropos.scm (modified) (14 diffs)

release/4/apropos/trunk/apropos.scm

@@ -60 +60 @@
           (error-invalid-environment loc obj argnam) ) ) )
 
+(define-inline (%check-sort-argument loc obj)
+  (unless (or (eq? #:name obj) (eq? #:kind obj))
+    (error-invalid-sort loc obj) ) )
+
 ;;;
 
-(require-library regex lolevel data-structures)
+#;(require-library regex lolevel data-structures extras srfi-13 csi)
 
 (module apropos (;export
   ; Original
-  apropos
-  apropos-list
-  apropos-information-list
+  apropos apropos-list apropos-information-list
   ; Crispy
-  apropos/environment
-  apropos-list/environment
-  apropos-information-list/environment
+  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
   ; Extra Crispy
-  apropos/environments
-  apropos-list/environments
-  apropos-information-list/environments)
-
-(import scheme chicken regex lolevel data-structures)
+  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
+
+(import scheme chicken regex lolevel data-structures extras srfi-13 csi)
 
 ;;; Support
@@ -97 +95 @@
   (error-argument-type loc obj 'environment argnam) )
 
-(define (error-type-procedure loc obj argnam)
-  (error-argument-type loc obj 'procedure argnam) )
+(define (error-invalid-sort loc obj)
+  (error-argument-type loc obj "#:name or #:kind" #:sort) )
 
 ;; Symbols
@@ -144 +142 @@
 ;; Environment Search
 
-(define (search-environment/searcher searcher env regexp pred lessp)
-  (let ((syms (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym))))))
-    (if lessp (sort syms lessp)
-        syms ) ) )
-
-(define (search-environment env regexp pred lessp)
-  (search-environment/searcher ##sys#environment-symbols env regexp pred lessp) )
-
-(define (search-macro-environment macenv regexp pred lessp)
-  (search-environment/searcher ##sys#syntactic-environment-symbols macenv regexp pred lessp) )
-
-(define (environment-predicate qualified?)
-  (if qualified? global-bound?
-      (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))) ) )
-
-(define (macro-environment-predicate qualified?)
-  (if qualified? any?
-      (lambda (x) (not (##sys#qualified-symbol? x))) ) )
-
-(define (*apropos-list loc regexp env macenv qualified? lessp)
+(define (*apropos-list/environment loc regexp env macenv? qualified?)
+
+  (define (search-environment/searcher searcher pred)
+    (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
+
+  (define (search-environment)
+    (search-environment/searcher
+      ##sys#environment-symbols
+      (if qualified? global-bound?
+          (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) )
+
+  (define (search-macro-environment)
+    (search-environment/searcher
+      ##sys#syntactic-environment-symbols
+      (if qualified? any?
+          (lambda (x) (not (##sys#qualified-symbol? x))))) )
+
+  (if macenv? (search-macro-environment) (search-environment)) )
+
+; => (envsyms . macenvsyms)
+(define (*apropos-list loc regexp env macenv qualified?)
   (append
-   (search-environment env regexp (environment-predicate qualified?) lessp)
+    (*apropos-list/environment loc regexp env #f qualified?)
     (if (not macenv) '()
-        (search-macro-environment macenv regexp (macro-environment-predicate qualified?) lessp))) )
-
-(define (*apropos-list/environment loc regexp env macenv? qualified? lessp)
-  (if macenv? (search-macro-environment env regexp (macro-environment-predicate qualified?) lessp))
-      (search-environment env regexp (environment-predicate qualified?) lessp) )
+        (*apropos-list/environment loc regexp macenv macenv qualified?))) )
 
 ;; Argument List Parsing
@@ -183 +178 @@
   patt )
 
+; => (values args val)
+(define (keyword-argument args kwd #!optional val)
+  (let loop ((iargs args) (oargs '()))
+    (if (null? args) (values (reverse oargs) val)
+        (let ((arg (car args)))
+          (cond ((eq? kwd arg)
+                  (set! val (cadr args))
+                  (loop (cddr iargs) oargs) )
+                (else
+                  (loop (cdr iargs) (cons arg oargs)) ) ) ) ) ) )
+
+; => (values args sort)
+(define (parse-sort-argument loc args)
+  (receive (args sort) (keyword-argument args #:sort #:name)
+    (%check-sort-argument loc sort)
+    (values args sort) ) )
+
 ; #!optional (env (default-environment)) macenv
-; #!key macros? qualified? sort?
+; #!key macros? qualified?
 ;
 ; macenv is #t for default macro environment or a syntactic-environment object.
 ;
-; => (values macenv syms)
+; => (values syms macenv)
 
 (define (parse-arguments loc patt args)
@@ -196 +208 @@
           (macenv #f)
           (qualified? #f)
-          (lessp #f)
           (1st-optarg #t)) ;keyword argument not considered an optional argument here
       (let loop ((args args))
-        (if (null? args) (values env macenv qualified? lessp)
+        (if (null? args) (values env macenv qualified?)
             (let ((arg (car args)))
                     ;keyword argument?
@@ -207 +218 @@
                     ((eq? #:qualified? arg)
                       (when (cadr args) (set! qualified? #t))
-                      (loop (cddr args)) )
-                    ((eq? #:sort? arg)
-                      (and-let* ((lsp (cadr args)))
-                        (set! lessp
-                          (cond ((boolean? lsp) symbol<?)
-                                ((procedure? lsp) lsp)
-                                (else
-                                  (error-type-procedure loc lsp #:sort?)))))
                       (loop (cddr args)) )
                     ;optional argument?
@@ -230 +233 @@
 
   (%check-search-pattern loc patt 'pattern)
-  (receive (env macenv qualified? lessp) (parse-rest-arguments)
+  (receive (env macenv qualified?) (parse-rest-arguments)
     (%check-environment loc env 'environment)
     (when macenv (%check-environment loc macenv #:macros?))
-    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
-
-; => (values macenv syms)
-
-(define (parse-arguments/environment loc patt env qualified? lessp)
+    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
+
+#|
+; => (values envsyms macenv)
+
+(define (parse-arguments/environment loc patt env qualified?)
   (%check-search-pattern loc patt 'pattern)
-  (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))
   (let ((macenv (%check-environment* loc env 'environment)))
-    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
+    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
 
 ; #!key qualified? sort?
@@ -250 +253 @@
 
   (define (parse-rest-arguments)
-    (let ((qualified? #f)
-          (lessp #f))
+    (let ((qualified? #f))
       (let loop ((args args) (envs '()))
-        (if (null? args) (values (reverse envs) qualified? lessp)
+        (if (null? args) (values (reverse envs) qualified?)
             (let ((arg (car args)))
-                    ;keyword argument?
               (cond ((eq? #:qualified? arg)
                       (when (cadr args) (set! qualified? #t))
                       (loop (cddr args) envs) )
-                    ((eq? #:sort? arg)
-                      (and-let* ((lsp (cadr args)))
-                        (set! lessp
-                          (cond ((boolean? lsp) symbol<?)
-                                ((procedure? lsp) lsp)
-                                (else
-                                  (error-type-procedure loc lsp #:sort?)))))
-                      (loop (cddr args) envs) )
                     (else
                       (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
 
   (%check-search-pattern loc patt 'pattern)
-  (receive (envs qualified? lessp) (parse-rest-arguments)
+  (receive (envs qualified?) (parse-rest-arguments)
     (let ((regexp (make-apropos-regexp patt)))
       (let loop ((envs envs) (envsyms '()))
@@ -279 +272 @@
                    (make-envsyms
                     (lambda ()
-                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )
+                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
               (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
-
+|#
 
 ;; Display
 
+; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
 (define (apropos-procedure-information proc)
   (let ((info (procedure-information proc)))
@@ -291 +285 @@
           (else `(procedure . ,(symbol->string info))) ) ) )
 
+; => 'macro | 'keyword | 'variable | <procedure-information>
 (define (apropos-information sym macenv)
   (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
@@ -299 +294 @@
                 'variable ) ) ) ) )
 
+(define (*apropos-information-list syms macenv)
+  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
+
 (define (display-spaces cnt)
   (do ((i cnt (sub1 i)))
@@ -304 +302 @@
     (display #\space) ) )
 
-(define (display-symbol-information sym maxsymlen macenv)
-  (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
-  (let ((info (apropos-information sym macenv)))
-    (display #\space)
-    (if (symbol? info) (display info)
-        (begin (display (car info)) (display #\space) (write (cdr info)) ) ) )
-  (newline) )
+(define (display-apropos syms macenv sort)
+  (let ((maxsymlen (max-symbol-print-width syms))
+        (lessp
+          (case sort
+            ((#:name)
+              (lambda (pr1 pr2) (symbol<? (car pr1) (car pr2))) )
+            ((#:kind)
+              (lambda (pr1 pr2)
+                (let ((s1 (car pr1)) (s2 (car pr2)))
+                  (symbol<? (if (symbol? s1) s1 (car s1)) (if (symbol? s2) s2 (car s2)))))))) )
+
+    (define (display-symbol-information apr)
+      (let ((sym (car apr))
+            (info (cdr apr)))
+        (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
+        (display #\space)
+        (if (symbol? info) (display info)
+            (begin (display (car info)) (display #\space) (write (cdr info)) ) )
+      (newline) ) )
+
+    (for-each
+      (cut display-symbol-information <>)
+      (sort (*apropos-information-list syms macenv) lessp)) ) )
 
 ;;; API
@@ -317 +331 @@
 
 (define (apropos patt . args)
-  (receive (macenv syms) (parse-arguments 'apropos patt args)
-    (let ((maxsymlen (max-symbol-print-width syms)))
-      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
+  (receive (args sort) (parse-sort-argument 'apropos args)
+    (receive (syms macenv) (parse-arguments 'apropos patt args)
+      (display-apropos syms macenv sort) ) ) )
 
 (define (apropos-list patt . args)
-  (receive (macenv syms) (parse-arguments 'apropos-list patt args)
+  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
     syms ) )
 
 (define (apropos-information-list patt . args)
-  (receive (macenv syms) (parse-arguments 'apropos-information-list patt args)
-    (map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )
+  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
+    (*apropos-information-list syms macenv) ) )
 
 ;; Crispy
 
-(define (apropos/environment patt env #!key qualified? (sort? symbol<?))
-  (receive (macenv syms)
-           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
-    (let ((maxsymlen (max-symbol-print-width syms)))
-      (newline)
-      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
-
-(define (apropos-list/environment patt env #!key qualified? (sort? symbol<?))
-  (receive (macenv syms)
-           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
+#|
+==== apropos/environment
+
+<procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure>
+
+Displays information about identifiers matching {{PATTERN}} in the
+{{ENVIRONMENT}}.
+
+Like {{apropos}}.
+
+; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}.
+
+==== apropos-list/environment
+
+<procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
+
+Like {{apropos-list}}.
+
+==== apropos-information-list/environment
+
+<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
+
+Like {{apropos-information-list}}.
+
+(define (apropos/environment patt env #!key qualified? (sort #:name))
+  (%check-sort-argument 'apropos/environment sort)
+  (receive (syms macenv)
+           (parse-arguments/environment 'apropos/environment patt env qualified?)
+    (newline)
+    (display-apropos syms macenv sort) ) )
+
+(define (apropos-list/environment patt env #!key qualified?)
+  (receive (syms macenv)
+           (parse-arguments/environment 'apropos/environment patt env qualified?)
     syms ) )
 
-(define (apropos-information-list/environment patt env #!key qualified? (sort? symbol<?))
-  (receive (macenv syms)
-           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
-    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
+(define (apropos-information-list/environment patt env #!key qualified?)
+  (receive (syms macenv)
+           (parse-arguments/environment 'apropos/environment patt env qualified?)
+    (*apropos-information-list syms macenv) ) )
 
 ;; Extra Crispy
 
+==== apropos/environments
+
+<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
+
+Displays information about identifiers matching {{PATTERN}} in each
+{{ENVIRONMENT}}.
+
+Like {{apropos}}.
+
+; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
+
+==== apropos-list/environments
+
+<procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
+
+
+Like {{apropos-list}}.
+
+==== apropos-information-list/environments
+
+<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
+
+Like {{apropos-information-list}}.
+
 (define (apropos/environments patt . args)
-  (let ((i 0))
-    (for-each
-      (lambda (macenv+syms)
-        (set! i (add1 i))
-        (newline) (print "** Environment " i " **") (newline)
-        (let ((macenv (car macenv+syms))
-              (syms (cdr macenv+syms)))
-          (let ((maxsymlen (max-symbol-print-width syms)))
-            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
-      (parse-arguments/environments 'apropos/environments patt args)) ) )
-    
+  (receive (args sort) (parse-sort-argument 'apropos/environments args)
+    (let ((i 0))
+      (for-each
+        (lambda (macenv+syms)
+          (set! i (add1 i))
+          (newline) (print "** Environment " i " **") (newline)
+          (display-apropos (cdr macenv+syms) (car macenv+syms) sort) )
+        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
+
 (define (apropos-list/environments patt . args)
   (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
@@ -367 +427 @@
 (define (apropos-information-list/environments patt . args)
   (map
-    (lambda (macenv+syms)
-      (let ((macenv (car macenv+syms)))
-        (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) )
+    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
     (parse-arguments/environments 'apropos-information-list/environments patt args)) )
+|#
+
+;;;
+
+(when (feature? csi:)
+  (toplevel-command 'a
+    (lambda () (apropos (string-trim-both (read-line))))
+    " ,a PATT ...       Apropos identifier") )
 
 ) ;module apropos