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

;; Issues
;;
;; - Use of '%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.
;;
;; - Could 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 chicken)

(import
  foreign
  (only csi
    toplevel-command))

(import
  (only srfi-1
    fold
    reverse! append!
    last-pair)
  (only srfi-13
    string-trim-both string-contains string-contains-ci)
  (only irregex
    irregex irregex? irregex-search)
  (only data-structures
    sort! any?
    alist-ref alist-update!
    butlast)
  (only ports
    with-input-from-string)
  (only extras
    read-file read-line)
  miscmacros
  (only memoized-string
    make-string*)
  (only symbol-utils
    symbol->keyword
    symbol-printname=? symbol-printname<?
    symbol-printname-length max-symbol-printname-length )
  (only type-checks
    define-check+error-type)
  (only type-errors
    define-error-type error-argument-type))
(require-library
  srfi-1 srfi-13
  irregex data-structures ports extras
  symbol-utils miscmacros memoized-string
  type-checks type-errors)

(declare
  (bound-to-procedure
    ##sys#symbol-has-toplevel-binding?
    ##sys#qualified-symbol?
    ##sys#macro-environment
    ##sys#current-environment
    ##sys#macro?))

;;; Support

;;

(define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
(define-inline (%global-ref sym) (##sys#slot sym 0))

;;

#>
#define ROOT_SYMBOL_TABLE_NAME "."

/* from runtime.c */
C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
{
  int i;
  C_word
    sym,
    bucket = C_u_i_car(pos);

  if(!C_truep(bucket)) return C_SCHEME_FALSE; /* end already reached */
  else i = C_unfix(bucket);

  bucket = C_u_i_cdr(pos);

  while(bucket == C_SCHEME_END_OF_LIST) {
    if(++i >= stable->size) {
      C_set_block_item(pos, 0, C_SCHEME_FALSE);	/* no more buckets */
      return C_SCHEME_FALSE;
    }
    else bucket = stable->table[ i ];
  }

  sym = C_block_item(bucket, 0);
  C_set_block_item(pos, 0, C_fix(i));
  C_mutate(&C_u_i_cdr(pos), C_block_item(bucket, 1));
  return sym;
}

static C_word
enumerate_root_symbol_table(C_word pos)
{
  static C_SYMBOL_TABLE *root_symbol_table = NULL;
  if (!root_symbol_table)
    root_symbol_table = C_find_symbol_table(ROOT_SYMBOL_TABLE_NAME);

  return C_enumerate_symbols(root_symbol_table, pos);
}
<#

(define enumerate-root-symbol-table
  (foreign-lambda scheme-object "enumerate_root_symbol_table" scheme-object))

(define (initial-enumerate-symbol-table-cursor)
  (cons -1 '()) )

(define (search-interaction-environment-symbols env pred)
  (let ((cursor (initial-enumerate-symbol-table-cursor)))
    (let loop ((syms '()))
      (let ((sym (enumerate-root-symbol-table cursor)))
        (if (not sym)
          syms
          (loop (if (pred sym) (cons sym syms) syms)) ) ) ) ) )

;;

(define (search-list-environment-symbols env pred)
  (fold
    (lambda (cell syms)
      (let ((sym (car cell)))
        (if (pred sym)
          (cons sym syms)
          syms ) ) )
    '()
    env) )

;;

(define (search-macro-environment-symbols env pred)
  (search-list-environment-symbols env pred) )

(define (search-system-environment-symbols env pred)
    (if env
      (search-list-environment-symbols env pred)
      (search-interaction-environment-symbols env pred) ) )

;;

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

;; Types

(define (search-pattern? obj)
  (or (keyword? obj) (symbol? obj) (string? obj) (irregex? obj) (pair? 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/irregex/irregex-sre/quoted-symbol/keyword/string")
(define-check+error-type sort-key sort-key? "#:name, #:type or #f")
#; ;UNSUPPORTED
(define-check+error-type environment system-environment?)

;; Symbols

(define (symbol-irregex-match? sym patt)
  (irregex-search patt (symbol->string sym)) )

(define (symbol-exact-match? sym patt)
  (string-contains (symbol->string sym) patt) )

(define (symbol-ci-match? sym patt)
  (string-contains-ci (symbol->string sym) patt) )

;; Environment Search

(define (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
  (let ((pred
          (if qualified?
            any?
            (lambda (x) (not (##sys#qualified-symbol? x))))))
    (search-macro-environment-symbols macenv
      (lambda (sym)
        (and (symbol-match? sym)
             (pred sym)))) ) )

(define (*apropos-list/environment loc symbol-match? env qualified?)
  (let ((pred
          (if qualified?
            %global-bound?
            (lambda (x) (and (not (##sys#qualified-symbol? x)) (%global-bound? x))))))
    (search-system-environment-symbols env
      (lambda (sym)
        (and (symbol-match? sym)
             (pred sym)))) ) )

;;

; => (envsyms . macenvsyms)
(define (*apropos-list loc symbol-match? env macenv qualified?)
  (append
    (*apropos-list/environment loc symbol-match? env qualified?)
    (if macenv
      (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
      '())) )

;; Argument List Parsing

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

(define (make-apropos-matcher loc patt #!optional (case-insensitive? #f) (force-regexp? #f))

  (define (gen-irregex-options-list)
    (if case-insensitive? '(case-insensitive) '()) )

  (define (gen-irregex patt)
    (apply irregex patt (gen-irregex-options-list)) )

  (define (gen-irregex-matcher patt)
     (cut symbol-irregex-match? <> (gen-irregex patt)) )

  (cond
    ((symbol? patt)
      (make-apropos-matcher loc (symbol->string patt) case-insensitive? force-regexp?) )
    ((string? patt)
      (if force-regexp?
        (gen-irregex-matcher patt)
        (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> patt) ) )
    ((pair? patt)
      (if (eq? 'quote (car patt))
        (make-apropos-matcher loc (cadr patt) case-insensitive? #t)
        (gen-irregex-matcher patt) ) )
    ((irregex? patt)
      (cut symbol-irregex-match? <> patt) )
    (else
      (error loc "invalid apropos pattern form" 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 qualified?)

(define (parse-arguments loc patt args)

  ; => (values env macenv qualified?)
  (define (parse-rest-arguments)
    (let ((env #f #;(default-environment))
          (macenv #f)
          (qualified? #f)
          (case-insensitive? #f)
          (1st-arg? #t))
      (let loop ((args args))
        (if (null? args)
          (values env macenv qualified? case-insensitive?)
          (let ((arg (car args)))
            (cond
               ;keyword argument?
              ((eq? #:macros? arg)
                ;only flag supported
                (when (cadr args) (set! macenv (default-macro-environment)))
                (loop (cddr args)) )
              ((eq? #:qualified? arg)
                (when (cadr args) (set! qualified? #t))
                (loop (cddr args)) )
              ((eq? #:case-insensitive? arg)
                (when (cadr args) (set! case-insensitive? #t))
                (loop (cddr args)) )
              ;environment argument?
              (1st-arg?
                ;FIXME need real 'environment?' predicate
                (unless (list? 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? case-insensitive?) (parse-rest-arguments)
    (values
      (*apropos-list loc
        (make-apropos-matcher loc patt case-insensitive?) env macenv qualified?)
      macenv) ) )

#| ;UNSUPPORTED ;FIXME case-insensitive support

;;

(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-matcher loc patt) env macenv qualified?)
      macenv) ) )

;;

; #!key qualified?
;
; => (... (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 arg envs)) ) ) ) ) ) ) )

  (check-search-pattern loc patt 'pattern)
  (receive (envs qualified?) (parse-rest-arguments)
    (let ((regexp (make-apropos-matcher loc 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 (*make-sorted-information-list syms macenv sort-key)
  (let ((lessp
          (case sort-key
            ((#:name) information-name<? )
            ((#:type) information<? )
            (else     #f ) ) )
        (ails (*make-information-list syms macenv)))
    (if lessp
      (sort! ails lessp)
      ails) ) )

(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-length syms)))

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

    (for-each
      display-symbol-information
      (*make-sorted-information-list syms macenv sort-key)) ) )

;;; API

;; Original

(define (apropos patt . args)
  (let*-values (((sort-key args) (parse-sort-key-argument 'apropos args) )
                ((syms macenv) (parse-arguments 'apropos patt args) ) )
    (display-apropos syms macenv sort-key) ) )

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

(define (apropos-information-list patt . args)
  (let*-values (((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
                ((syms macenv) (parse-arguments 'apropos-information-list patt args) ) )
    (*make-sorted-information-list syms macenv sort-key) ) )

;; Crispy

#| ;UNSUPPORTED ;FIXME case-insensitive support

==== 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)
  (let-values (((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 mac)
            (loop (cdr args) (cons #t (cons #:macros? oargs))) )
          ((qualified qual)
            (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
          ((case-insensitive ci)
            (loop (cdr args) (cons #t (cons #:case-insensitive? 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|mac, qualified|qual, sort [name|type|#f], case-insensitve|ci") )

) ;module apropos