;;;; 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 any 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))

;;;

;; Module apropos

(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
          (only chicken unless when optional keyword? feature?
                        sub1 procedure-information receive fxmax
                        string->keyword error)
          ;(only srfi-23 error)
          (only srfi-13 string-trim-both)
          (only regex regexp? regexp-escape regexp string-search)
          (only lolevel global-ref global-bound?)
          (only data-structures sort any?)
          (only ports with-input-from-string)
          (only extras read-file read-line)
          (only csi toplevel-command)
          (only type-checks define-check+error-type)
          (only type-errors define-error-type error-argument-type))

  (require-library srfi-13 regex lolevel data-structures ports extras type-checks type-errors)

;;; Support

;; Types

(define (search-pattern? obj) (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj)))
(define (sort-key? obj) (or (not obj) (eq? #:name obj) (eq? #:kind obj)))

;; Errors

#; ;UNUSED
(define-error-type environment)

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

;; Argument Checking

(define-check+error-type search-pattern search-pattern? "symbol/keyword/string/regexp")
(define-check+error-type sort-key sort-key? "#:name, #:kind or #f")

#; ;UNUSED
(define (checked-environment loc obj argnam)
  (cond ((##sys#environment? obj) #f)
        ((##sys#syntactic-environment? obj) obj)
        (else
          (error-environment loc obj argnam) ) ) )

;; Symbols

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

(define (symbol=? x y)
  (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)
  (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)
  (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)
  (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 sort-key args)
(define (parse-sort-key-argument loc args)
  (receive (sort-key args) (keyword-argument args #:sort #:kind)
    (check-sort-key loc sort-key #:sort)
    (values sort-key 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-argument loc arg) )
                      (set! 1st-arg? #f)
                      (set! env arg)
                      (loop (cdr args)) )
                    ;unkown argument
                    (else
                      (error-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 (checked-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-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 (checked-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))) ) ) )

; => 'syntax | 'keyword | 'variable | <procedure-information>
(define (apropos-information sym macenv)
  (cond ((and macenv (##sys#macro? sym macenv)) 'syntax)
        ((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 sort-key)
  (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 sort-key
                   ((#: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 (sort-key args) (parse-sort-key-argument 'apropos args)
    (receive (syms macenv) (parse-arguments 'apropos patt args)
      (display-apropos syms macenv sort-key) ) ) )

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

(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 (sort-key args) (parse-sort-key-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-key) )
        (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