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

(import chicken foreign (only csi toplevel-command))

(import
  (only data-structures
    sort! any?
    alist-ref alist-update!
    butlast)
  (only ports
    with-input-from-string)
  (only extras
    read-file read-line))
(require-library
  data-structures
  ports
  extras)

(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))
(require-library
  srfi-1
  srfi-13
  irregex)

(import
  (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
  memoized-string
  symbol-utils
  type-checks
  type-errors)

(require-extension miscmacros)

(declare  ;yes, i know not module-minded
  (bound-to-procedure
    ##sys#symbol-has-toplevel-binding?
    ##sys#qualified-symbol?
    ##sys#macro-environment
    ##sys#current-environment
    ##sys#macro? ) )

;;; Support

;; raw access renames

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

(define-inline (%global-ref sym)
  (##sys#slot sym 0) )

;; special stuff from the runtime & scheme API

#>
#define ROOT_SYMBOL_TABLE_NAME  "."

#define raw_symbol_table_size( stable )         ((stable)->size)
#define raw_symbol_table_element( stable, i )   ((stable)->table[ i ])

#define raw_bucket_element( bucket, i )   (C_block_item( (bucket), (i) ))
#define raw_bucket_symbol( bucket )       (raw_bucket_element( (bucket), 0 ))
#define raw_bucket_link( bucket )         (raw_bucket_element( (bucket), 1 ))

static C_regparm C_SYMBOL_TABLE *
find_root_symbol_table()
{
  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
}

static C_regparm C_SYMBOL_TABLE *
remember_root_symbol_table()
{
  static C_SYMBOL_TABLE *root_symbol_table = NULL;
  if(!root_symbol_table) {
    root_symbol_table = find_root_symbol_table();
  }

  return root_symbol_table;
}

//FIXME root_symbol_table re-allocated?
//#define use_root_symbol_table   find_root_symbol_table
#define use_root_symbol_table    remember_root_symbol_table
<#

(define root-symbol-table-size
  (foreign-lambda* int ()
    "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )

(define root-symbol-table-element
  (foreign-lambda* scheme-object ((int i))
    "C_return( raw_symbol_table_element( use_root_symbol_table(), i ) );") )

(define bucket-symbol
  (foreign-lambda* scheme-object ((scheme-object bucket))
    "C_return( raw_bucket_symbol( bucket ) );"))

(define bucket-link
  (foreign-lambda* scheme-object ((scheme-object bucket))
    "C_return( raw_bucket_link( bucket ) );"))

;;

(define make-symbol-table-cursor cons)

(define symbol-table-cursor? pair?)

(define symbol-table-cursor-index car)
(define set-symbol-table-cursor-index! set-car!)

(define symbol-table-cursor-bucket cdr)
(define set-symbol-table-cursor-bucket! set-cdr!)

(define (symbol-table-cursor)
  (make-symbol-table-cursor -1 '()) )

#; ;UNUSED
(define (clear-symbol-table-cursor! cursor)
  (set-symbol-table-cursor-index! cursor -1)
  (set-symbol-table-cursor-bucket! cursor '())
  cursor )

;;

;(functional version would take cursor @ currpos, not nextpos, so
;(: cursor-bucket-symbol <cursor> -> (or boolean symbol)) would work)
;
;(root-symbol-table re-alloc an issue no matter what!)
;
(define (enumerate-root-symbols! cursor)
  ;which slot are we on ?
  (let ((idx (symbol-table-cursor-index cursor)))
    (and
      ;could already be dead
      idx
      ;get the next
      (let loop ((bkt (symbol-table-cursor-bucket cursor)) (idx idx))
        ;no bucket ?
        (if (null? bkt)
          ;try next hash-root slot
          (let ((idx (add1 idx)))
            ;no more hash-root-vector slots ?
            (if (>= idx (root-symbol-table-size))
              ;no where else to go, were done
              (begin
                (set-symbol-table-cursor-index! cursor #f)
                #f )
              ;next slot
              (loop (root-symbol-table-element idx) idx) ) )
          ;found something
          (begin
            ;where we are
            (set-symbol-table-cursor-index! cursor idx)
            ;where to go next
            (set-symbol-table-cursor-bucket! cursor (bucket-link bkt))
            ;what we want
            (bucket-symbol bkt) ) ) ) ) ) )

(define (search-interaction-environment-symbols env accept?)
  (let ((cursor (symbol-table-cursor)))
    (let loop ((syms '()))
      (let ((sym (enumerate-root-symbols! cursor)))
        (if sym
          (loop (if (accept? sym) (cons sym syms) syms))
          syms ) ) ) ) )

;;

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

;;

(define (search-macro-environment-symbols env accept?)
  (search-list-environment-symbols env accept?) )

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

;;

#; ;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 (
    (accept?
      (if qualified?
        any?
        (lambda (x)
          (not (##sys#qualified-symbol? x))))))
    (search-macro-environment-symbols macenv
      (lambda (sym)
        (and
          (symbol-match? sym)
          (accept? sym)))) ) )

(define (*apropos-list/environment loc symbol-match? env qualified?)
  (let (
    (accept?
      (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)
          (accept? 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)
    (values (check-sort-key loc sort-key #:sort) 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 iargs)
  (let (
    (patt
      (check-search-pattern loc (fixup-pattern-argument patt) 'pattern)))
    (receive (env macenv qualified? case-insensitive?) (parse-rest-arguments loc iargs)
      (values
        (*apropos-list loc
          (make-apropos-matcher loc patt case-insensitive?) env macenv qualified?)
        macenv) ) ) )
;;

;=> (values env macenv qualified?)
(define (parse-rest-arguments loc iargs)
  (let ((env #f)        ;(default-environment)
        (macenv #f)
        (qualified? #f)
        (case-insensitive? #f)
        (1st-arg? #t))
    (let loop ((args iargs))
      (if (null? args)
        ;seen 'em all
        (values env macenv qualified? case-insensitive?)
        ;process potential arg
        (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) ) ) ) ) ) ) )

;;

(define (fixup-pattern-argument patt)
  (cond
    ((boolean? patt)
      (if patt '|#t| '|#f|) )
    ((char? patt)
      (string patt) )
    ((number? patt)
      (number->string patt) )
    ;? pair vector ... ->string , struct use tag as patt ?
    (else
      patt ) ) )

#| ;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)) ) ) ) ) ) ) )
  ;
  (let ((patt (fixup-pattern-argument patt)))
    (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)) )
|#

;;;
;;; REPL Integeration
;;;

(define (parse-csi-apropos-arguments iargs)
  (let loop ((args iargs) (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 ()
      (let (
        (args (parse-csi-apropos-arguments
                (with-input-from-string
                  (string-trim-both (read-line))
                  read-file))))
        (unless (null? args)
          (apply apropos args) ) ) )
    ",a PATT ARG...    Apropos of PATT with ARG from macros|mac, qualified|qual, sort [name|type|#f], case-insensitve|ci") )

) ;module apropos