;;;; 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. And
;; how could it.
;;
;; - 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.

(module apropos

  (;export
    ; Extra Crispy
    ;apropos/environments apropos-list/environments apropos-information-list/environments
    ; Crispy
    ;apropos/environment apropos-list/environment apropos-information-list/environment
    ; Original
    apropos apropos-list apropos-information-list)

  (import
    scheme
    ; Just for grins (not a suggested style w/o a special reason)
    (only chicken
      unless when optional keyword? feature?
      sub1 procedure-information receive fxmax
      string->keyword error
      declare cut let-values)
    (only srfi-1
      reverse! append!
      last-pair)
    (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?
      alist-ref alist-update!
      butlast)
    (only ports
      with-input-from-string)
    (only extras
      read-file read-line)
    (only csi
      toplevel-command)
    miscmacros
    (only type-checks
      define-check+error-type)
    (only type-errors
      define-error-type error-argument-type))

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

  (declare
    (bound-to-procedure
      ##sys#make-string
      ##sys#qualified-symbol?
      ##sys#symbol->qualified-string
      ##sys#qualified-symbol-prefix
      ##sys#symbol->string
      ##sys#current-environment ##sys#macro-environment
      ##sys#macro?
      ##sys#signal-hook))

;;; Support

;;

(define make-string*
  (let ((+strings+ '()))
    (lambda (len #!optional (ch #\space))
      (if* (alist-ref ch +strings+)
        (or (alist-ref len it)
            (let ((str (##sys#make-string len ch)))
              (set-cdr! (assv ch +strings+) (alist-update! len str it))
              str ) )
        (begin
          (set! +strings+ (alist-update! ch '() +strings+))
          (make-string* len ch) ) ) ) ) )

;From Chicken 4.2.2 expand.scm

;;

; Workalike of '##sys#environment?' for syntactic environments
(define (##sys#macro-environment? obj)

  (define (simple-environment-entry? obj)
    (and (pair? obj)
         (symbol? (car obj))
         (symbol? (cdr obj)) ) )

  (define (macro-environment-entry? obj)
    (and (pair? obj) (= 3 (length obj))
         (symbol? (car obj))
         (list? (cadr obj))
         (procedure? (caddr obj))
         #; ;enough already
         (##sys#macro-environment? (cadr x)) ) )

  (define (environment-entry? obj pred)
    (or (null? obj)
        (and (pair? obj)
             (pred (car obj))
             #; ;enough already
             (call-with-current-continuation
               (lambda (return)
                 (##sys#for-each
                   (lambda (x)
                     (unless (pred x)
                       (return #f) ) )
                   (cdr obj))
                 #t ) ) ) ) )

  (define (simple-environment? obj)
    (environment-entry? obj simple-environment-entry?) )

  (define (macro-environment? obj)
    (environment-entry? obj macro-environment-entry?) )

  (or (simple-environment? obj)
      (macro-environment? obj) ) )

;;

; Workalike of '##sys#environment-symbols' for syntactic environments
(define (##sys#macro-environment-symbols env pred)

  (define (try-alias id)
    (or (##sys#get id '##core#real-name)
        (let ((alias (##sys#get id '##core#macro-alias)))
          (cond
            ((not alias)    id)
            ((pair? alias)  id)
            (else           alias) ) ) ) )

  (let ((syms '()))
    (##sys#for-each
      (lambda (cell)
        (let ((id (car cell)))
          (cond
            ((pred id)
              (set! syms (cons id syms)) )
            ((try-alias id) =>
              (lambda (name)
                (when (pred name) (set! syms (cons name syms))) ) ) ) ) )
      env)
    syms ) )

;;

(define (system-environment? obj)
  (or (##sys#environment? obj) (##sys#macro-environment? obj)) )

;; 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? #:type obj)) )

;; Errors

(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, #:type or #f")
(define-check+error-type environment system-environment?)

;; Symbols

;symbol->string drops namespace qualification!
;which means a keyword and a symbol of the same name have the same printname.

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

(define (symbol-printname-details sym)
  (let ((p (##sys#qualified-symbol-prefix sym)) )
    (values
      (##sys#symbol->string sym)
      (cond
        ((not p)                    "" )
        ((= #\x0 (string-ref p 0))  ":")
        (else                       (substring p 1) ) ) ) ) )

(define (symbol-printname=? x y)
  (define (qualified=? px sx py sy)
    (and (string=? px py) (string=? sx sy)) )
  (let-values (((sx px) (symbol-printname-details x))
               ((sy py) (symbol-printname-details y)) )
    (qualified=? px sx py sy) ) )

(define (symbol-printname<? x y)
  (define (qualified<? px sx py sy)
    (or (and (string=? px py) (string<? sx sy))
        (string<? px py)) )
  (let-values (((sx px) (symbol-printname-details x))
               ((sy py) (symbol-printname-details y)) )
    (qualified<? px sx py sy) ) )

(define (symbol-printname-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-printname-width syms)
  (apply max (map symbol-printname-length syms)) )

#; ;UNUSED
(define (^symbol-match? sym regexp)
  (string-match regexp (symbol->string sym)) )

(define (symbol-match? sym regexp)
  (string-search regexp (symbol->string sym)) )

;; Environment Search

(define (*apropos-list/environment loc regexp env macenv? qualified?)

  (define symbol-bound?
    (if qualified? global-bound?
      (lambda (x)
        (and (not (##sys#qualified-symbol? x)) (global-bound? x)))))

  (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 symbol-bound?) )

  (define (search-macro-environment)
    (search-environment/searcher
      ##sys#macro-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 #:type)
    (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 macro-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) ) )

;;

(define (macro-environment obj)
  (and (##sys#macro-environment? obj)
       obj) )

;;

; => (values envsyms macenv)

(define (parse-arguments/environment loc patt env qualified?)
  (check-search-pattern loc patt 'pattern)
  (let ((macenv (macro-environment (check-environment loc env 'environment))))
    (values
      (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?)
      macenv) ) )

;;

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

#; ;UNSUPPORTED
(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 arg 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 (macro-environment (check-environment loc env 'environment)))
                 (make-envsyms
                   (lambda ()
                     (cons
                       macenv
                       (*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
            (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )

;; Display

#| ;A Work In Progress

; UNDECIDEDABLE - given the data available from `procedure-information',
; serial nature of `gensym', and serial nature of argument coloring by
; compiler.

; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
; gensym identifiers can just be colored using a base of 1.

;best guess:
;
;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
;here `(foo a1 b2)'                       `(foo a1 b2)'
;here `(a380384 a379385)'                 `(arg1 arg2)'
;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'

(define apropos-gensym-suffix-limit 1)

When > limit need to keep leading digit

; un-qualified symbols only!
(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
  (let* ((str (symbol->string sym))
         (idx (string-skip-right str char-set:digit))
         (idx (and idx (add1 idx))) )
    (cond
      ((not idx)
        sym )
      ((< (- (string-length str) idx) limit)
        sym )
      (else
        (string->symbol (substring str 0 idx)) ) ) ) )

; arg-lst-template is-a pair!
(define (scrub-gensym-effect arg-lst-template)
  (let ((heads (butlast arg-lst-template))
        (tailing (last-pair arg-lst-template)) )
    (append!
      (map scrub-gensym-taste heads)
      (if (null? (cdr tailing)) (list (scrub-gensym-taste (car tailing)))
        (cons
          (scrub-gensym-taste (car tailing))
          (scrub-gensym-taste (cdr tailing)))) ) ) )
|#

; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
(define (procedure-details proc)
  (let ((info (procedure-information proc)))
    (cond
      ((not info)   'procedure)
      ((pair? info) `(procedure . ,(cdr info)))
      (else         `(procedure . ,(symbol->string info))) ) ) )

; => 'macro | 'keyword | 'variable | <procedure-details>
(define (type-details sym macenv)
  (cond
    ((and macenv (##sys#macro? sym macenv))
      'macro )
    ((keyword? sym)
      'keyword )
    (else
      (let ((val (global-ref sym)))
        (if (not (procedure? val)) 'variable
          (procedure-details val) ) ) ) ) )

(define (make-information sym macenv)
  (cons sym (type-details sym macenv)) )

(define (*make-information-list syms macenv)
  (map (cut make-information <> macenv) syms) )

(define (information-name api)
  (car api) )

(define (information-details api)
  (cdr api) )

(define (information-name<? api1 api2)
  (symbol-printname<?
    (information-name api1)
    (information-name api2)) )

(define (information-kind api)
  (let ((d (information-details api)))
    (if (symbol? d) d (car d)) ) )

(define (information-kind=? api1 api2)
  (symbol-printname=?
    (information-kind api1)
    (information-kind api2)) )

(define (information-kind<? api1 api2)
  (symbol-printname<?
    (information-kind api1)
    (information-kind api2)) )

(define (information<? api1 api2)
  (if (information-kind=? api1 api2)
    (information-name<? api1 api2)
    (information-kind<? api1 api2) ) )

(define (display-apropos syms macenv sort-key)
  (let ((maxsymlen (max-symbol-printname-width syms)))

    (define (display-symbol-information api)
      (let ((sym (information-name api)))
        (display sym)
        (display (make-string* (+ 2 (- maxsymlen (symbol-printname-length sym))))) )
      (let ((info (information-details api)))
        (cond
          ((symbol? info)
            (display info) )
          (else
            (display (car info)) (display #\space) (write (cdr info)) ) ) )
      (newline) )

    (let ((lessp
            (case sort-key
              ((#:name) information-name<? )
              ((#:type) information<? )
              (else     #f ) ) )
          (ails (*make-information-list syms macenv)))
      (for-each display-symbol-information (if lessp (sort! ails lessp) ails)) ) ) )

;;; 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)
    (*make-information-list syms macenv) ) )

;; Crispy

#| ;UNSUPPORTED
==== 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 {{macro-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?)
    (*make-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) (*make-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 ((next (cdr args)))
              (if (null? next) (loop '() (cons #:type (cons #:sort oargs)))
                (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 [sort {name type #f}]") )

) ;module apropos