source: project/release/4/apropos/trunk/apropos.scm @ 13748

;;;; apropos.scm -*- Hen -*-
;;;; Kon Lovett, Mar '09
;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662

;; Issues
;;
;; - Use of Unit lolevel 'global-' routines is just wrong when an
;; evaluation-environment (##sys#environment?) is not the
;; interaction-environment.
;;
;; - Doesn't show something similar to procedure-information for macros.
;;
;; - Runtime macros?
;;
;; - Should be re-written to use the "environments" extension. Which in turn would
;; need to support syntactic environments, at least for lookup opertations.
;;
;; - The Chicken 'environment' object does not hold the (syntactic) bindings
;; for all syntactic keywords from the R5RS. The public API of 'apropos'
;; attempts to hide this fact.

;;; Prelude

(declare
  (usual-integrations)
  (fixnum)
  (inline)
  (local)
  (no-procedure-checks)
  (bound-to-procedure
    ##sys#qualified-symbol? ##sys#symbol->qualified-string ##sys#qualified-symbol-prefix
    ##sys#symbol->string
    ##sys#current-environment ##sys#macro-environment
    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
    ##sys#environment? ##sys#environment-symbols
    ##sys#signal-hook))

;;

(cond-expand
  (unsafe
    (include "chicken-primitive-object-inlines") )
  (else ) )

;; Argument Checking

(define-inline (%check-search-pattern loc obj argnam)
  (cond-expand
    (unsafe
      (unless (or (%keyword? obj) (%symbol? obj) (%string? obj) (regexp? obj))
        (error-invalid-search loc obj argnam) ) )
    (else
      (unless (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj))
        (error-invalid-search loc obj argnam) ) ) ) )

#; ;UNUSED
(define-inline (%check-environment* loc obj argnam)
  (cond ((##sys#environment? obj) #f)
        ((##sys#syntactic-environment? obj) obj)
        (else
          (error-invalid-environment loc obj argnam) ) ) )

(define-inline (%check-sortkey-argument loc obj)
  (unless (or (not obj) (eq? #:name obj) (eq? #:kind obj))
    (error-invalid-sortkey loc obj) ) )

;;;

(require-library regex lolevel data-structures ports extras utils srfi-13)

(module apropos (;export
  ; Original
  apropos apropos-list apropos-information-list
  ; Crispy
  #;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 ports extras utils srfi-13 csi)

;;; Support

;; Errors

(define (error-argument-type loc obj kndnam #!optional argnam)
  (##sys#signal-hook
    #:type-error
    loc
    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
    obj) )

(define (error-invalid-search loc obj argnam)
  (error-argument-type loc obj "symbol/string/regexp" argnam) )

#; ;UNUSED
(define (error-invalid-environment loc obj argnam)
  (error-argument-type loc obj 'environment argnam) )

(define (error-invalid-sortkey loc obj)
  (error-argument-type loc obj "#:name, #:kind or #f" #:sort) )

(define (error-invalid-argument loc arg)
  (if (keyword? arg) (error loc "unrecognized keyword argument" arg)
      (error loc "unrecognized argument" arg) ) )

;; Symbols

(define (symbol->keyword sym)
  (if (keyword? sym) sym
      (string->keyword (symbol->string sym)) ) )

(define (symbol=? x y)
  (cond-expand
    (unsafe
      (%string=? (%symbol-string x) (%symbol-string y)) )
    (else
      (let ((sx (##sys#symbol->string x))
            (sy (##sys#symbol->string y))
            (px (##sys#qualified-symbol-prefix x))
            (py (##sys#qualified-symbol-prefix y)))
        (cond (px (and py (string=? px py) (string=? sx sy)))
              (py (or (not px) (and (string=? px py) (string=? sx sy))))
              (else (string=? sx sy) ) ) ) ) ) )

(define (symbol<? x y)
  (cond-expand
    (unsafe
      (%string<? (%symbol-string x) (%symbol-string y)) )
    (else
      (let ((sx (##sys#symbol->string x))
            (sy (##sys#symbol->string y))
            (px (##sys#qualified-symbol-prefix x))
            (py (##sys#qualified-symbol-prefix y)))
        (cond (px (and py (string<? px py) (string<? sx sy)))
              (py (or (not px) (and (string<? px py) (string<? sx sy))))
              (else (string<? sx sy) ) ) ) ) ) )

(define (symbol-print-length sym)
  (cond-expand
    (unsafe
      (let ((siz (%string-size (%symbol-string sym))))
              ; assumes keyword style is not #:none
        (cond ((%keyword? sym) siz)
              ; compensate for the '##'
              ((%qualified-symbol? sym) (%fx+ siz 2))
              ; plain old string
              (else siz) ) ) )
    (else
      (let ([len (string-length (##sys#symbol->qualified-string sym))])
        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
            len ) ) ) ) )

(define (max-symbol-print-width syms)
  (let ((maxlen 0))
    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
    maxlen ) )

(define (symbol-match? sym regexp)
  (cond-expand
    (unsafe
      (string-search regexp (%symbol-string sym)) )
    (else
      (string-search regexp (symbol->string sym)) ) ) )

;; Environment Search

(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
    (*apropos-list/environment loc regexp env #f qualified?)
    (if (not macenv) '()
        (*apropos-list/environment loc regexp macenv #t qualified?))) )

;; Argument List Parsing

(define default-environment interaction-environment)
(define default-macro-environment ##sys#macro-environment)

(define (make-apropos-regexp patt)
  (when (symbol? patt) (set! patt (symbol->string patt)))
  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
  patt )

; => (values val args)
(define (keyword-argument args kwd #!optional val)
  (let loop ((args args) (oargs '()))
    (if (null? args) (values val (reverse oargs))
        (let ((arg (car args)))
          (cond ((eq? kwd arg)
                  (set! val (cadr args))
                  (loop (cddr args) oargs) )
                (else
                  (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )

; => (values sortkey args)
(define (parse-sortkey-argument loc args)
  (receive (sortkey args) (keyword-argument args #:sort #:kind)
    (%check-sortkey-argument loc sortkey)
    (values sortkey args) ) )

; #!optional (env (default-environment)) macenv
; #!key macros? qualified?
;
; macenv is #t for default macro environment or a syntactic-environment object.
;
; => (values syms macenv)

(define (parse-arguments loc patt args)

  ; => (values env macenv qualified?)
  (define (parse-rest-arguments)
    (let ((env (default-environment))
          (macenv #f)
          (qualified? #f)
          (1st-arg? #t))
      (let loop ((args args))
        (if (null? args) (values env macenv qualified?)
            (let ((arg (car args)))
                    ;keyword argument?
              (cond ((eq? #:macros? arg)
                      (when (cadr args) (set! macenv (default-macro-environment)))
                      (loop (cddr args)) )
                    ((eq? #:qualified? arg)
                      (when (cadr args) (set! qualified? #t))
                      (loop (cddr args)) )
                    ;environment argument?
                    (1st-arg?
                      (unless (##sys#environment? arg)
                        (error-invalid-argument loc arg) )
                      (set! 1st-arg? #f)
                      (set! env arg)
                      (loop (cdr args)) )
                    ;unkown argument
                    (else
                      (error-invalid-argument loc arg) ) ) ) ) ) ) )

  (%check-search-pattern loc patt 'pattern)
  (receive (env macenv qualified?) (parse-rest-arguments)
    (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)
  (let ((macenv (%check-environment* loc env 'environment)))
    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )

; #!key qualified? sort?
;
; => (... (macenv . syms) ...)

(define (parse-arguments/environments loc patt args)

  (define (parse-rest-arguments)
    (let ((qualified? #f))
      (let loop ((args args) (envs '()))
        (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) )
                    ;environment argument?
                    (else
                      (unless (##sys#environment? arg)
                        (error-invalid-argument loc arg) )
                      (loop (cdr args) (cons env envs)) ) ) ) ) ) ) )

  (%check-search-pattern loc patt 'pattern)
  (receive (envs qualified?) (parse-rest-arguments)
    (let ((regexp (make-apropos-regexp patt)))
      (let loop ((envs envs) (envsyms '()))
        (if (null? envs) (reverse envsyms)
            (let* ((env (car envs))
                   (macenv (%check-environment* loc env 'environment))
                   (make-envsyms
                    (lambda ()
                      `(,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)))
    (cond ((not info) 'procedure)
          ((pair? info) `(procedure . ,(cdr info)))
          (else `(procedure . ,(symbol->string info))) ) ) )

; => 'macro | 'keyword | 'variable | <procedure-information>
(define (apropos-information sym macenv)
  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
        ((keyword? sym) 'keyword)
        (else
          (let ((binding (global-ref sym)))
            (if (procedure? binding) (apropos-procedure-information binding)
                '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)))
      ((zero? i))
    (display #\space) ) )

(define (apropos-information-name<? apr1 apr2)
  (symbol<? (car apr1) (car apr2)) )

(define (apropos-information-kind=? apr1 apr2)
  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
    (symbol=? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )

(define (apropos-information-kind<? apr1 apr2)
  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
    (symbol<? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )

(define (apropos-information<? apr1 apr2)
  (if (apropos-information-kind=? apr1 apr2) (apropos-information-name<? apr1 apr2)
      (apropos-information-kind<? apr1 apr2) ) )

(define (display-apropos syms macenv sortkey)
  (let ((maxsymlen (max-symbol-print-width syms)))

    (define (display-symbol-information apr)
      (let ((sym (car apr)))
        (display sym) (display #\space) (display-spaces (- maxsymlen (symbol-print-length sym))) )
      (display #\space)
      (let ((info (cdr apr)))
        (cond ((symbol? info) (display info) )
              (else (display (car info)) (display #\space) (write (cdr info)) ) ) )
      (newline) )

    (let ((lessp
            (case sortkey
              ((#:name) apropos-information-name<? )
              ((#:kind) apropos-information<? )
              (else     #f ) ) )
          (ail (*apropos-information-list syms macenv)))
      (for-each display-symbol-information (if lessp (sort ail lessp) ail)) ) ) )

;;; API

;; Original

(define (apropos patt . args)
  (receive (sortkey args) (parse-sortkey-argument 'apropos args)
    (receive (syms macenv) (parse-arguments 'apropos patt args)
      (display-apropos syms macenv sortkey) ) ) )

(define (apropos-list patt . args)
  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
    syms ) )

(define (apropos-information-list patt . args)
  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
    (*apropos-information-list syms macenv) ) )

;; Crispy

#|
==== 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-sortkey-argument 'apropos/environment sort)
  (receive (syms macenv)
           (parse-arguments/environment 'apropos/environment patt env qualified?)
    (newline)
    (display-apropos syms macenv sortkey) ) )

(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?)
  (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)
  (receive (sortkey args) (parse-sortkey-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) sortkey) )
        (parse-arguments/environments 'apropos/environments patt args)) ) ) )

(define (apropos-list/environments patt . args)
  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )

(define (apropos-information-list/environments patt . args)
  (map
    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
|#

;;;

(define (parse-csi-apropos-arguments args)
  (let loop ((args args) (oargs '()))
    (if (null? args) (reverse oargs)
        (let ((arg (car args)))
          (case arg
            ((macros)
              (loop (cdr args) (cons #t (cons #:macros? oargs))) )
            ((qualified)
              (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
            ((sort)
              (let* ((val (cadr args))
                     (key (if (symbol? val) (symbol->keyword val) val)))
                (loop (cddr args) (cons key (cons #:sort oargs))) ) )
            (else
              (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )

(when (feature? csi:)
  (toplevel-command 'a
    (lambda ()
      (apply apropos
        (parse-csi-apropos-arguments
          (with-input-from-string (string-trim-both (read-line)) read-file))) )
    ",a PATT [ARG...]  Apropos of PATT with ARG from macros, qualified, or sort name/#f") )

) ;module apropos