(herald apropos)                        ; Emacs, this is -*- T -*- code

;;;;;; Apropos: searching locales for bound names

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;; Simple APROPOS utility.  (APROPOS id [root-env]) searches through
;;; the given root environment, which defaults to STANDARD-ENV, and
;;; all of its inferiors, for bindings whose names include ID, and
;;; prints out the results nicely formatted to your terminal (mostly).
;;; The identifier may be a string or a symbol; strings are converted
;;; to the canonical symbol case.  APROPOS-LIST works similarly, but
;;; it returns a machine-processable list of the results of the form
;;; (<env (<inferior-result> ...) (<name> . <vcell>) ...).

;;; Lightly tested.  This does not print out syntax bindings, because,
;;; for whatever reason, there are no introspective operations on
;;; syntax tables.  (This will change in T4 when syntax tables will be
;;; expunged anyway.)

(import t-implementation-env
  locale-walk
  locale-inferiors
  map-weak-set
  vcell-contents)

(define (apropos id . root-env)
  (let ((env (if (null? root-env)
                 standard-env
                 (enforce locale? (car root-env))))
        (substring (if (string? id)
                       (canonicalize-case id)
                       (symbol->string id)))
        (port (terminal-output)))
    (iterate label ((env env) (depth 0))
      (write-spaces port depth)
      (print env port)
      (newline port)
      (apropos-1 substring env
                 (let ((depth (fx+ depth 4)))
                   (lambda (id vcell)
                     (write-spaces port depth)
                     (display id port)
                     (set (hpos port) 29)
                     (space port)
                     (print (vcell-contents vcell) port)
                     (newline port)
                     (force-output port))))
      (walk-weak-set (let ((depth (fx+ depth 2)))
                       (lambda (inferior)
                         (label inferior depth)))
                     (locale-inferiors env))))
  repl-wont-print)

(define (apropos-list id . root-env)
  (let ((root-env (if (null? root-env)
                      standard-env
                      (enforce locale? (car root-env))))
        (substring (if (string? id)
                       (canonicalize-case id)
                       (symbol->string id))))
    (iterate recur ((env root-env))
      (cons env
            (cons (map-weak-set recur (locale-inferiors env))
                  (let ((matches '()))
                    (apropos-1 substring env
                               (lambda (id vcell)
                                 (push matches (cons id vcell))))
                    matches))))))

(define (apropos-1 substring env proc)
  (locale-walk env
               (lambda (id vcell)
                 (if (string-contains?
                      ;; The identifier may not be a symbol.
                      (if (symbol? id)  ;+++
                          (symbol->string id)
                          (display-to-string id))
                      substring)
                     (proc id vcell)))))

(define canonicalize-case
        (if (char= (string-elt (symbol->string 't)
                               0)
                   #\T)
            string-upcase
            string-downcase))

(define (display-to-string obj)
  (let ((iob (get-buffer)))
    (display obj iob)
    (let ((string (buffer->string iob)))
      (release-buffer iob)
      string)))

(define (string-contains? larger smaller)
  (let ((larger-len (string-length larger))
        (smaller-len (string-length smaller)))
    (xcond ((fx< larger-len smaller-len)
            '#f)
           ((fx= larger-len smaller-len)
            (string-equal? larger smaller))
           ((fx> larger-len smaller-len)
            (iterate loop ((i 0))
              (cond ((fx> (fx+ i smaller-len)
                          larger-len)
                     '#f)
                    ((string-equal? (string-slice larger i smaller-len)
                                    smaller)
                     '#t)
                    (else
                     (loop (fx+ i 1)))))))))