apropos/apropos-api.scm

;;;; apropos-api.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Oct '17
;;;; Kon Lovett, Mar '09
;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662

;; Issues
;;;
;; - Use of 'global-symbol' 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.

(include-relative "symbol-environment-access")
(include-relative "symbol-access")

(module apropos-api

(;export
  ;apropos-toplevel-module-symbol ;needs excluded-modules treatment
  apropos-excluded-modules
  apropos-default-base
  apropos-interning
  apropos-default-options
  ;
  check-apropos-number-base
  apropos-find-key? check-apropos-find-key error-apropos-find-key
  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
  ;
  apropos apropos-list apropos-information-list)

(import scheme)
(import (scheme base))
(import (chicken base))
(import (chicken fixnum))
(import (chicken foreign))
(import (chicken syntax))
(import (chicken keyword))
(import (chicken sort))
(import (chicken type))
(import (only (chicken irregex)
  sre->irregex irregex irregex?
  irregex-num-submatches irregex-search irregex-match irregex-match-data?
  irregex-match-num-submatches irregex-replace))
(import (only (srfi 1) reverse! append! last-pair proper-list?))
(import (only srfi-13
  string-index string-join string-trim-both
  string-contains string-concatenate
  #; ;FIXME isn't CI!
  string-contains-ci
  string-downcase))
(import (only (check-errors basic)
  define-check+error-type define-error-type
  error-argument-type))
(import (only symbol-name-utils
  symbol->keyword symbol-printname=?
  symbol-printname<? symbol-printname-length max-symbol-printname-length
  module-printnames))
(import symbol-environment-access)
(import symbol-access)

(define-type irregex (struct regexp))

(define-type argument-name (or string symbol keyword))

(define-type find-key (or false keyword))
(define-type sort-key (or false keyword))
(define-type search-pattern (or keyword symbol string pair irregex))

(define-type module-name (or string symbol (list-of symbol) (list symbol integer)))

(: apropos-excluded-modules (#!optional (list-of module-name) -> (list-of string)))
(: apropos-default-base (#!optional integer -> integer))
(: apropos-interning (#!optional * -> boolean))
(: apropos-default-options (#!optional (or boolean list) -> list))

(: check-apropos-number-base (symbol * #!optional argument-name -> integer))

(: apropos-find-key? (* -> boolean : find-key))
(: check-apropos-find-key (symbol * #!optional argument-name -> find-key))
(: error-apropos-find-key (symbol * #!optional argument-name -> void))

(: apropos-sort-key? (* -> boolean : sort-key))
(: check-apropos-sort-key (symbol * #!optional argument-name -> sort-key))
(: error-apropos-sort-key (symbol * #!optional argument-name -> void))

(: apropos (search-pattern #!rest -> void))
(: apropos-list (search-pattern #!rest -> (list-of symbol)))
(: apropos-information-list (search-pattern #!rest -> (list-of list)))

;;from srfi-13

;FIXME actual one isn't CI!
(define (string-contains-ci str patt)
  ;this sucks
  (string-contains (string-downcase str) (string-downcase patt)) )

;;from list-utils

#; ;FIXME macro symbol dups? same name, different module?
(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
  ;(assert (sorted? ols eql?))
  (let loop ((ls ols))
    (let ((nxt (and (not (null? ls)) (cdr ls))))
      (if (or (not nxt) (null? nxt))
          ols
          (if (eql? ls nxt)
              (begin
                (set-cdr! ls (cdr nxt))
                (loop ls) )
              (loop nxt) ) ) ) ) )

;; irregex extensions

(define (irregex-submatches? mt #!optional ire)
  (and (irregex-match-data? mt)
       (or (not ire)
           (=  (irregex-match-num-submatches mt)
               (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )

;; String

(define (string-match? str patt) (irregex-search patt str))
(define (string-exact-match? str patt) (string-contains str patt))
(define (string-ci-match? str patt) (string-contains-ci str patt))

;; memoized-string

(define (index-key=? a b) (and (= (car a) (car b)) (char=? (cdr a) (cdr b))))

(define make-string+
  (let ((+strings+ (the list '())))
    (lambda (len fill) ;optional in original
      (let ((key `(,len . ,fill)))
        (or (alist-ref key +strings+ index-key=?)
            (let ((str (make-string len fill)))
              (set! +strings+ (alist-update! key str +strings+ index-key=?))
              str ) ) ) ) ) )

;; Symbols

#|
(define (symbol-match? sym patt)        (string-match? (symbol->string sym) patt))
(define (symbol-exact-match? sym patt)  (string-exact-match? (symbol->string sym) patt))
(define (symbol-ci-match? sym patt)     (string-ci-match? (symbol->string sym) patt))
|#

;; Constants

;NOTE invalid compile-time value for named constant `KRL-OPTIONS'
(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))

(define-constant TAB-WIDTH 2)

;for our purposes
(define-constant CHICKEN-MAXIMUM-BASE 16)

;; Types

(define (search-pattern? obj)
  (or (keyword? obj)
      (symbol? obj)
      (string? obj)
      (irregex? obj)
      (pair? obj)) )

(define (apropos-find-key? obj)
  (or (not obj)
      (eq? #:name obj)
      (eq? #:module obj)) )

(define (apropos-sort-key? obj)
  (or (not obj)
      (eq? #:name obj)
      (eq? #:module obj)
      (eq? #:type obj)) )

;; Errors

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

;; Argument Checking

(define-check+error-type search-pattern search-pattern?
  "symbol/keyword/string/irregex/irregex-sre/quoted")

(define-check+error-type apropos-find-key apropos-find-key? "#:name, #:module or #f")
(define-check+error-type apropos-sort-key apropos-sort-key? "#:name, #:module, #:type or #f")

#; ;UNSUPPORTED
(define-check+error-type environment system-environment?)

;;

;FIXME prefix matching is not implied by the name!

;NOTE all `##' are excluded. |##| is the ns-prefix.
(define INTERNAL-MODULE-EXCLUDES '("##" "chicken.internal"))

(define apropos-excluded-modules
  (make-parameter '()
    (lambda (obj)
      (or (module-printnames obj)
          (error-argument-type 'apropos-excluded-modules obj "list-of module-name")))))

;; Number Base

(define (number-base? obj)
  (and (exact-integer? obj) (<= 2 obj CHICKEN-MAXIMUM-BASE)) )

(define NUMBER-BASE-ERROR-MESSAGE
  (string-append "fixnum in 2.." (number->string CHICKEN-MAXIMUM-BASE)))

(define DEFAULT-BASE-ERROR-MESSAGE
  (string-append "" NUMBER-BASE-ERROR-MESSAGE))

(define apropos-default-base
  (make-parameter 10
    (lambda (x)
      (if (number-base? x) x
          (error-argument-type 'apropos-default-base x DEFAULT-BASE-ERROR-MESSAGE)))))

(define (check-apropos-number-base loc obj #!optional (var 'base))
  (unless (number-base? obj)
    (error-argument-type loc obj NUMBER-BASE-ERROR-MESSAGE var) )
  obj )

(define (check-find-component loc obj #!optional (var 'find))
  (case obj
    ((#f)
      obj)
    ((#:module #:name)
      obj)
    (else
      (error-argument-type loc obj "find option - nam, mod, #f" var)) ) )

;;

;
(define (system-current-symbol? sym)
  ;must check full identifier name, so cdr
  (not (null? (search-list-environment-symbols  (cut eq? sym <>)
                                                (system-current-environment)
                                                cdr))) )

;; Environment Search

;;

(define (*apropos-list/macro-environment loc match? macenv)
  #; ;FIXME macro symbol dups? same name, different module?
  (delete-duplicates!/sorted
    (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?)
    (lambda (a b) (eq? (car a) (car b))))
  (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?) )

(define (*apropos-list/environment loc match? env)
  (search-system-environment-symbols match? env) )

; => (envsyms . macenvsyms)
(define (*apropos-list loc match/env? env match/macenv? macenv)
  (let ((envls (*apropos-list/environment loc match/env? env)))
    (if (not macenv) envls
        (append! (*apropos-list/macro-environment loc match/macenv? macenv)
                 envls)) ) )

;; Argument List Parsing & Matcher Generation

;FIXME separate concerns

(define default-environment system-current-environment)
(define default-macro-environment system-macro-environment)

(define-constant ANY-SYMBOL '_)

(: make-apropos-matcher (symbol * #!optional * (or false keyword) *  * -> (symbol -> boolean)))

(define (make-apropos-matcher loc patt
            #!optional
            case-insensitive?
            find-split
            force-regexp?
            internal?)
  ;
  (define (error-patt) (error-argument-type loc patt "apropos pattern form"))
  ;
  (define (matcher-for pred? data)
    ;cache
    (define topstr (symbol->string (toplevel-module-symbol)))
    (define excld-mods (apropos-excluded-modules))
    ;
    ;match string form of nam or mod or ful
    ;the match predicate `pred?' will search the entire string
    (define (check-str? str) (pred? str data))    ;
    ;
    ;match string form of mod or ful
    (define (excluded-mod? str)
      (and (or internal? (not (*excluded-module-name? str INTERNAL-MODULE-EXCLUDES)))
           (not (*excluded-module-name? str excld-mods))) )
    (define (check-mod? str)
      (and (excluded-mod? str) (check-str? str)) )
    ;
    (cond ((not find-split)
            (lambda (sym)
              #; ;entire string searched so will include whatever element, nam or
              ;mod, that matches first so only do one call
              (let-values (((mod nam) (*split-prefixed-symbol sym topstr)))
                (or (check-mod? mod) (check-str? nam)) )
              (check-mod? (symbol->string sym))) )
          ((eq? #:module find-split)
            (lambda (sym)
              (let-values (((mod _) (*split-prefixed-symbol sym topstr)))
                (check-mod? mod))) )
          ((eq? #:name find-split)
            (lambda (sym)
              (let-values (((mod nam) (*split-prefixed-symbol sym topstr)))
                (and (excluded-mod? mod)
                     (check-str? nam)) ) ) )
          (else
            (error loc "unknown symbol find" find-split patt)) ) )
  ;
  (define (string-matcher str)
    (let ((pred? (if case-insensitive? string-ci-match? string-exact-match?)))
      (matcher-for pred? str) ) )
  ;
  (define (irregex-options-list)
    (if case-insensitive? '(case-insensitive) '()) )
  ;(or proper-list atom) -> regexp
  (define (sre-n-str-matcher patt)
    (apply irregex patt (irregex-options-list)) )
  ;
  (define (irregex-matcher irx)
    (matcher-for string-match? irx) )
  ;
  (cond ((symbol? patt)
          (make-apropos-matcher loc (symbol->string patt)
            case-insensitive? find-split force-regexp? internal?) )
        ;
        ((string? patt)
          (if force-regexp?
              (irregex-matcher (sre-n-str-matcher patt))
              (string-matcher patt)) )
        ;
        ((irregex? patt)
          (irregex-matcher patt) )
        ;
        ((pair? patt)
          (if (not (eq? 'quote (car patt)))
              ;then an irregex acceptable form
              (if (proper-list? patt)
                  (irregex-matcher (sre-n-str-matcher patt))
                  (error-patt))
              ;else some form of pattern
              (let ((quoted (cadr patt)))
                (define (name-matcher)
                  (make-apropos-matcher loc (cdr quoted)
                    case-insensitive? #:name force-regexp? internal?) )
                (define (module-matcher)
                  (make-apropos-matcher loc (car quoted)
                    case-insensitive? #:module force-regexp? internal?) )
                ;'(___ . <atom>)
                (if (pair? quoted)
                    ;then could be a find (name|module) pattern
                          ;elaborate match any
                    (cond ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
                            (make-apropos-matcher loc '(: (* any))
                              #f #f #t internal?) )
                          ;name find?
                          ((eq? ANY-SYMBOL (car quoted))
                            (name-matcher) )
                          ;module find?
                          ((eq? ANY-SYMBOL (cdr quoted))
                            (module-matcher) )
                          ;both name & module
                          (else
                            (let ((mod-match? (module-matcher))
                                  (nam-match? (name-matcher)) )
                              (lambda (sym)
                                (and (mod-match? sym) (nam-match? sym)) ) ) ) )
                    ;else interpretation of stripped
                    (make-apropos-matcher loc quoted
                      case-insensitive? find-split #t internal?) ) ) ) )
        ;
        (else
          (error-patt) ) ) )

;;

; => (values val args)
(define (keyword-argument args kwd #!optional val)
  (let loop ((args args) (oargs '()) (val val))
    (if (null? args)
        (values val (reverse! oargs))
        (let ((arg (car args)))
          (cond ((eq? kwd arg)
                  (loop (cddr args) oargs (cadr args)) )
                (else
                  (loop (cdr args) (cons arg oargs) val) ) ) ) ) ) )

; => (values sort-key args)
(define (parse-sort-key-argument loc args)
  (receive (sort-key args) (keyword-argument args #:sort #:type)
    (values (check-apropos-sort-key loc sort-key #:sort) args) ) )

;;

;=> (values env macenv base raw? find internal?)
;
(define (parse-rest-arguments loc iargs)
  (let ((env #f)        ;(default-environment) ;just the macros but looks ok in repl?
        (macenv #f)
        (internal? #f)
        (raw? #f)
        (case-insensitive? #f)
        (find-split #f)
        (base (apropos-default-base))
        (imported? #f)
        (1st-arg? #t) )
    (let loop ((args iargs))
      (if (null? args)
          ;seen 'em all
          (values env macenv case-insensitive? base raw? find-split internal? imported?)
          ;process potential arg
          (let ((arg (car args)))
            ;keyword argument?
            (case arg
              ((#:imported?)
                (set! imported? (cadr args))
                (loop (cddr args)) )
              ;
              ((#:find #:split)
                (set! find-split (check-find-component loc (cadr args)))
                (loop (cddr args)) )
              ;
              ((#:internal?)
                (set! internal? (cadr args))
                (loop (cddr args)) )
              ;
              ((#:raw?)
                (set! raw? (cadr args))
                (loop (cddr args)) )
              ;
              ((#:base)
                (when (cadr args) (set! base (check-apropos-number-base loc (cadr args))))
                (loop (cddr args)) )
              ;
              ((#:macros?)
                ;only flag supported
                (when (cadr args) (set! macenv (default-macro-environment)))
                (loop (cddr args)) )
              ;
              ((#:case-insensitive?)
                (set! case-insensitive? (cadr args))
                (loop (cddr args)) )
              ;environment argument?
              ;FIXME need real 'environment?' predicate
              (else
                (if (not (and 1st-arg? (list? arg)))
                    (error-argument loc arg)
                    (begin
                      (set! 1st-arg? #f)
                      (set! env arg)
                      (loop (cdr args)) ) ) ) ) ) ) ) ) )

(define (fixup-pattern-argument patt #!optional (base (apropos-default-base)))
      (cond ((boolean? patt)
              (if patt "#t" "#f"))
            ((char? patt)
              (string patt))
            ((number? patt)
              (number->string patt base))
            ;? pair vector ... ->string , struct use tag as patt ?
            (else
              patt) ) )

;;

;#!optional (env (default-environment)) macenv #!key macros? internal? base (find #:all)
;
;macenv is #t for default macro environment or a macro-environment object.
;
;=> (values apropos-ls macenv)

;
(define (parse-arguments-and-match loc patt iargs)
  (let-values (((env macenv case-insensitive? base raw? find-split internal? imported?)
                  (parse-rest-arguments loc iargs) ) )
    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
    (let ((include? (if imported? system-current-symbol? global-symbol-bound?)))
      (let* ((force-regexp? #f)
             (patt
              (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
             (match?
              (make-apropos-matcher loc patt case-insensitive? find-split force-regexp? internal?) )
             (als
              (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym)))
                                 env match? macenv) ) )
        (values als macenv raw? case-insensitive?) ) ) ) )

;;

#| ;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)
  (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)
            macenv) ) )

;;

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

(define (parse-arguments/environments loc patt args)
  ;
  (define (parse-rest-arguments)
    (let ((internal? #f))
      (let loop ((args args) (envs '()))
        (if (null? args)
            (values (reverse! envs) internal?)
            (let ((arg (car args)))
              ;keyword argument?
              (cond ((eq? #:internal? arg)
                      (when (cadr args) (set! internal? #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 internal?) (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)) ) ) )
                (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
|#

;; Display

(define apropos-interning (make-parameter #t (lambda (x) (and x #t))))

(define (string->display-symbol str)
  (let ((str2sym (if (apropos-interning) string->symbol string->uninterned-symbol)))
    (str2sym str) ) )

;;

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

(import (only (srfi 1) last-pair))

(define apropos-gensym-suffix-limit 1)

;When > limit need to keep leading digit

(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 (fx+ idx 1))) )
    ;
    (cond ((not idx)
            sym )
          ((< (fx- (string-length str) idx) limit)
            sym )
          (else
            (string->display-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)))) ) ) )
|#

(define (identifier-components sym raw?)
  (if raw? (cons (toplevel-module-symbol) sym)
      (let-values (((mod nam) (split-prefixed-symbol sym)))
        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) )

;FIXME make patt a param ?
(define GENSYM_SRE (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
(define GENSYM_DEL_SRE (sre->irregex '(: (* num) eos) 'utf8 'fast))

(define (canonical-identifier-name id raw?)
  (if raw? id
      (let* ((pname (symbol->string id))
             (mt (irregex-match GENSYM_SRE pname)) )
        (if (irregex-submatches? mt GENSYM_SRE)
            (string->display-symbol (irregex-replace GENSYM_DEL_SRE pname ""))
            id ) ) ) )

(define (canonicalize-identifier-names form raw?)
  (cond (raw?
          form )
        ((symbol? form)
          (canonical-identifier-name form raw?) )
        ((pair? form)
          (cons
            (canonicalize-identifier-names (car form) raw?)
            (canonicalize-identifier-names (cdr form) raw?)) )
        (else
          form ) ) )

; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
;
(define (procedure-details proc raw?)
  (let ((info (procedure-information proc)))
    (cond ((not info)
            'procedure )
          ((pair? info)
            `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
          (else
            ;was ,(symbol->string info) (? why)
            `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )

; <symbol>|<keyword> => <identifier>
; <identifier> => 'macro | 'keyword | 'variable | <procedure-details>
;
(define (identifier-type-details sym #!optional macenv raw?)
  (cond ((keyword? sym)
          'keyword )
        ((and macenv (macro-symbol-in-environment? sym macenv))
          'macro )
        (else
          (let ((val (global-symbol-ref sym)))
            (if (procedure? val)
                (procedure-details val raw?)
                'variable ) ) ) ) )

;;

(define (make-information sym macenv raw?)
  (cons (identifier-components sym raw?)
        (identifier-type-details sym macenv raw?)) )

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

(define (identifier-information-module ident-info)
  (car ident-info) )

(define (identifier-information-name ident-info)
  (cdr ident-info) )

(define (detail-information-kind dets-info)
  (car dets-info) )

(define (detail-information-arguments dets-info)
  (cdr dets-info) )

(define (information-identifiers info)
  (car info) )

(define (information-module info)
  (identifier-information-module (information-identifiers info)) )

(define (information-name info)
  (identifier-information-name (information-identifiers info)) )

(define (information-details info)
  (cdr info) )

;FIXME case-insensitive sort but 1) not documented 2) R7RS is case-sensitive

(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
  (receive  (field-1-ref field-2-ref)
            (if (eq? #:name sort-key)
                (values information-name information-module)
                (values information-module information-name) )
    (let ((sym-1-1 (field-1-ref info1) )
          (sym-1-2 (field-1-ref info2) ) )
      (if (not (symbol-printname=? sym-1-1 sym-1-2))
          (symbol-printname<? sym-1-1 sym-1-2)
          (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )

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

(define (information-kind=? info1 info2)
  (symbol-printname=? (information-kind info1) (information-kind info2)) )

(define (information-kind<? info1 info2)
  (symbol-printname<? (information-kind info1) (information-kind info2)) )

(define (information<? info1 info2 #!optional (sort-key #:name))
  (if (information-kind=? info1 info2)
      (information-identifier<? info1 info2 sort-key)
      (information-kind<? info1 info2) ) )

;;

(define (make-sorted-information-list syms macenv sort-key raw?)
  (let ((lessp
          (case sort-key
            ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
            ((#:type)           information<?)
            (else               #f )) )
        (ails
          (*make-information-list syms macenv raw?) ) )
    ;
    (if lessp
        (sort! ails lessp)
        ails ) ) )

(define (symbol-pad-length sym maxsymlen #!optional (bias 0))
  (let* ((len (symbol-printname-length sym))
         (maxlen (min maxsymlen len)) )
    (fx+ bias (fx- maxsymlen maxlen)) ) )

#; ;
(define (display/cols vals wids #!key (tab-width TAB-WIDTH))
  )

;FIXME need to know if ANY mods, then no mod pad needed (has +2)
(define (display-apropos isyms macenv sort-key raw?)
  ;
  (let* ((ails (make-sorted-information-list isyms macenv sort-key raw?))
         (mods (map information-module ails))
         (syms (map information-name ails))
         (maxmodlen (max-symbol-printname-length mods))
         (maxsymlen (max-symbol-printname-length syms)) )
    ;
    (define (display-symbol-information info)
      ;<sym><tab>
      (let* ((dets (information-details info))
             (kwd? (eq? 'keyword dets))
             (sym (information-name info) )
             (sym-padlen (symbol-pad-length sym maxsymlen)) )  ;(if kwd? -1 0)
        (display (if kwd? (symbol->keyword sym) sym))
        (display (make-string+ (fx+ TAB-WIDTH sym-padlen) #\space)) )
      ;<mod><tab>
      (let* ((mod (information-module info))
             (mod-padlen (symbol-pad-length mod maxmodlen))
             (mod-padstr (make-string+ (fx+ TAB-WIDTH mod-padlen) #\space)) )
        (if (eq? (toplevel-module-symbol) mod)
            (display mod-padstr)
            (begin
              (display mod)
              (display mod-padstr) ) ) )
      ;<details>
      (let ((dets (information-details info)))
        (cond ((symbol? dets)
                (display dets) )
              (else
                (display (detail-information-kind dets))
                (display #\space)
                (write (detail-information-arguments dets)) ) ) )
      ;d'oy
      (newline) )
    ;
    (for-each display-symbol-information ails) ) )

;; API

(define apropos-default-options
  (make-parameter '()
    (lambda (x)
      ;FIXME actually check for proper options
      (cond ((boolean? x)
              (if x KRL-OPTIONS '()) )
            ((list? x)
              x )
            (else
              (error-argument-type 'apropos-default-options x "list-of options"))))))

;; Original

(define (apropos patt . args)
  (let ((args (if (null? args) (apropos-default-options) args)))
    (let*-values (((sort-key args)
                    (parse-sort-key-argument 'apropos args) )
                  ((syms macenv raw? case-insensitive?)
                    (parse-arguments-and-match 'apropos patt args) ) )
      (display-apropos syms macenv sort-key raw?) ) ) )

(define (apropos-list patt . args)
  (let ((args (if (null? args) (apropos-default-options) args)))
    (let*-values (((sort-key args)
                    (parse-sort-key-argument 'apropos-list args) )
                  ((syms macenv raw? case-insensitive?)
                    (parse-arguments-and-match 'apropos-list patt args) ) )
      syms ) ) )

(define (apropos-information-list patt . args)
  (let ((args (if (null? args) (apropos-default-options) args)))
    (let*-values (((sort-key args)
                    (parse-sort-key-argument 'apropos-information-list args) )
                  ((syms macenv raw? case-insensitive?)
                    (parse-arguments-and-match 'apropos-information-list patt args) ) )
      (make-sorted-information-list syms macenv sort-key raw?) ) ) )

) ;module apropos-api

#| ;UNSUPPORTED ;FIXME case-insensitive support
(export
  ;Crispy
  apropos/environment apropos-list/environment apropos-information-list/environment
  ;Extra Crispy
  apropos/environments apropos-list/environments apropos-information-list/environments)

;; Crispy

==== apropos/environment

<procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#: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 (#:internal? INTERNAL?))</procedure>

Like {{apropos-list}}.

==== apropos-information-list/environment

<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>

Like {{apropos-information-list}}.

(define (apropos/environment patt env #!key internal? (sort #:name))
  (check-sort-key 'apropos/environment sort #:sort)
  (receive
    (syms macenv)
      (parse-arguments/environment 'apropos/environment patt env internal?)
    ;
    (newline)
    (display-apropos syms macenv sort-key) ) )

(define (apropos-list/environment patt env #!key internal?)
  (receive
    (syms macenv)
      (parse-arguments/environment 'apropos/environment patt env internal?)
    ;
    syms ) )

(define (apropos-information-list/environment patt env #!key internal?)
  (receive
    (syms macenv)
      (parse-arguments/environment 'apropos/environment patt env internal?)
    ;
    (*make-information-list syms macenv) ) )

;; Extra Crispy

==== apropos/environments

<procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#: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 (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>

Like {{apropos-list}}.

==== apropos-information-list/environments

<procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) 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 (fx+ i 1))
          (newline) (display "** Environment " i " **") (newline) (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)) )
|#