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

(module apropos-api

(;export
  check-apropos-number-base
  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
  apropos-default-base apropos-interning apropos-default-options
  ;
  apropos apropos-list apropos-information-list)

(import scheme
  (chicken base)
  (chicken foreign)
  (chicken syntax)
  (chicken keyword)
  (chicken fixnum)
  (chicken sort)
  (chicken type)
  (only (srfi 1) reverse! append! last-pair)
  (only (srfi 13)
    string-join
    string-trim-both
    string-contains string-contains-ci)
  (only (chicken irregex)
    sre->irregex
    irregex irregex?
    irregex-num-submatches
    irregex-search irregex-match
    irregex-match-data? irregex-match-num-submatches
    irregex-replace)
  (only memoized-string make-string+)
  (only symbol-name-utils
    symbol->keyword
    symbol-printname=? symbol-printname<?
    symbol-printname-length max-symbol-printname-length)
  (only type-checks check-fixnum define-check+error-type)
  (only type-errors define-error-type error-argument-type)
  symbol-environment-access
  symbol-access)

;;; Support

;;

(define (any? x)
  #t )

;;

(define *tab-width* 2)

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

;; irregex extensions

(define (irregex-submatches? mt #!optional ire)
  (and
    (irregex-match-data? mt)
    (or
      (not ire)
      (fx=
        (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) )

;; Symbols

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

#; ;UNUSED
(define (symbol-exact-match? sym patt)
  (string-exact-match? (symbol->string sym) patt) )

#; ;UNUSED
(define (symbol-ci-match? sym patt)
  (string-ci-match? (symbol->string sym) patt) )

;; Types

;;

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

;;

(define (apropos-sort-key? obj)
  (or
    (not obj)
    (eq? #:name obj)
    (eq? #:module 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")

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

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

;; Number Base

(define (number-base? obj)
  (and (fixnum? obj) (fx<= 2 obj) (<= obj CHICKEN-MAXIMUM-BASE)) )

(define *number-base-error-message*
  (string-append "fixnum in 2.." (number->string CHICKEN-MAXIMUM-BASE)))

(define apropos-default-base (make-parameter 10 (lambda (x)
  (if (number-base? x)
    x
    (begin
      (warning 'apropos-default-base (string-append "not a " *number-base-error-message*) x)
      (apropos-default-base))))))

(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-split-component loc obj #!optional (var 'split))
  (case obj
    ((#f)
      obj )
    ((#:module #:name)
      obj )
    (else
      (error-argument-type loc obj *number-base-error-message* var)) ) )

;;

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

;; Environment Search

(define (*apropos-list/macro-environment loc matcher macenv)
  (search-macro-environment-symbols macenv matcher) )

(define (*apropos-list/environment loc matcher env)
  (search-system-environment-symbols env
    (lambda (sym)
      (and
        (global-symbol-bound? sym)
        (matcher sym)))) )

;;

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

;; Argument List Parsing

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

(define-constant ANY-SYMBOL '_)

(define (make-apropos-matcher loc patt
            #!optional
              (case-insensitive? #f)
              (split #f)
              (force-regexp? #f)
              (internal? #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 irx)
    (cond
      ((not split)
        (lambda (sym)
          (let ((symstr (symbol->string sym)))
            (and
              (or internal? (not (internal-module-name? symstr)))
              (string-match? symstr irx) ) ) ) )
      ((eq? #:module split)
        (lambda (sym)
          (let-values (
            ((mod nam) (split-prefixed-symbol sym)) )
            (and
              (or internal? (not (internal-module-name? mod)))
              (string-match? mod irx) ) ) ) )
      ((eq? #:name split)
        (lambda (sym)
          (let-values (
            ((mod nam) (split-prefixed-symbol sym)) )
            (and
              (or internal? (not (internal-module-name? mod)))
              (string-match? nam irx) ) ) ) ) ) )
  ;
  (define (gen-string-matcher str)
    (let (
      (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
      (cond
        ((not split)
          (lambda (sym)
            (let ((symstr (symbol->string sym)))
              (and
                (or internal? (not (internal-module-name? symstr)))
                (matcher symstr str) ) ) ) )
        ((eq? #:module split)
          (lambda (sym)
            (let-values (
              ((mod nam) (split-prefixed-symbol sym)) )
              (and
                (or internal? (not (internal-module-name? mod)))
                (matcher mod str) ) ) ) )
        ((eq? #:name split)
          (lambda (sym)
            (let-values (
              ((mod nam) (split-prefixed-symbol sym)) )
              (and
                (or internal? (not (internal-module-name? mod)))
                (matcher nam str) ) ) ) ) ) ) )
  ;
  (cond
    ((symbol? patt)
      (make-apropos-matcher loc
        (symbol->string patt)
        case-insensitive? split force-regexp? internal?) )
    ((string? patt)
      (if force-regexp?
        (gen-irregex-matcher (gen-irregex patt))
        (gen-string-matcher patt)) )
    ((irregex? patt)
      (gen-irregex-matcher patt) )
    ((pair? patt)
      (if (not (eq? 'quote (car patt)))
        ;then assume an irregex
        (gen-irregex-matcher (gen-irregex patt))
        ;else some form of pattern
        (let ((quoted (cadr patt)))
          ;'(___ . <atom>)
          (if (pair? quoted)
            ;then could be a split (name|module) pattern
            (cond
              ;elaborate match any
              ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
                (make-apropos-matcher loc '(: (* any)) #f #f #t internal?) )
              ;name split?
              ((eq? ANY-SYMBOL (car quoted))
                (make-apropos-matcher loc
                  (cdr quoted)
                  case-insensitive? #:name force-regexp? internal?) )
              ;module split?
              ((eq? ANY-SYMBOL (cdr quoted))
                (make-apropos-matcher loc
                  (car quoted)
                  case-insensitive? #:module force-regexp? internal?) )
              ;both name & module
              (else
                (let (
                  (modr
                    (make-apropos-matcher loc
                      (car quoted)
                      case-insensitive? #:module force-regexp? internal?))
                  (namr
                    (make-apropos-matcher loc
                      (cdr quoted)
                      case-insensitive? #:name force-regexp? internal?)) )
                  (lambda (sym)
                    (and (modr sym) (namr sym)) ) ) ) )
            ;else interpretation of stripped
            (make-apropos-matcher loc
              quoted
              case-insensitive? split #t internal?) ) ) ) )
    (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-apropos-sort-key loc sort-key #:sort) args) ) )

;;

;#!optional (env (default-environment)) macenv #!key macros? internal? base (split #: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? split internal?) (parse-rest-arguments loc iargs)))
    (let* (
      (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
      (force-regexp? #f)
      (matcher (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
      (als (*apropos-list loc matcher env macenv)) )
      (values als macenv raw?) ) ) )
;;

;=> (values env macenv base raw? split internal?)
;
(define (parse-rest-arguments loc iargs)
  (let (
    (env #f)        ;(default-environment)
    (macenv #f)
    (internal? #f)
    (raw? #f)
    (case-insensitive? #f)
    (split #f)
    (base (apropos-default-base))
    (1st-arg? #t) )
    ;
    (let loop ((args iargs))
      (if (null? args)
        ;seen 'em all
        (values env macenv case-insensitive? base raw? split internal?)
        ;process potential arg
        (let ((arg (car args)))
          ;keyword argument?
          (cond
            ;
            ((eq? #:split arg)
              (set! split (check-split-component loc (cadr args)))
              (loop (cddr args)) )
            ;
            ((eq? #:internal? arg)
              (set! internal? (cadr args))
              (loop (cddr args)) )
            ;
            ((eq? #:raw? arg)
              (set! raw? (cadr args))
              (loop (cddr args)) )
            ;
            ((eq? #:base arg)
              (when (cadr args)
                (set! base (check-apropos-number-base loc (cadr args))) )
              (loop (cddr args)) )
            ;
            ((eq? #:macros? arg)
              ;only flag supported
              (when (cadr args)
                (set! macenv (default-macro-environment)) )
              (loop (cddr args)) )
            ;
            ((eq? #:case-insensitive? arg)
              (set! case-insensitive? (cadr args))
              (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 #!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 ) ) )

#| ;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)
  (if (boolean? x)
    x
    (begin
      (warning 'apropos-interning "not a boolean: " x)
      (apropos-interning))))))

(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)'

(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+ 1 idx))) )
    ;
    (cond
      ((not idx)
        sym )
      ((fx< (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?)
  (cond
    (raw?
      (cons *toplevel-module-symbol* sym) )
    (else
      (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?)) ) ) ) )

; => 'macro | 'keyword | 'variable | <procedure-details>
;
(define (identifier-type-details sym #!optional macenv raw?)
  (cond
    ((macro-symbol-in-environment? sym macenv)
      'macro )
    ((keyword? sym)
      'keyword )
    (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) )

(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)
          (cut information<? <> <> #:name) )
        (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 (fxmin maxsymlen len) ) )
    (fx+ bias (fx- maxsymlen maxlen)) ) )

;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))) )
      ;<mod><tab>
      (let* (
        (mod (information-module info) )
        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
        ;
        (if (eq? *toplevel-module-symbol* mod)
          (display (make-string+ (fx+ *tab-width* mod-padlen)))
          (begin
            (display mod)
            (display (make-string+ (fx+ *tab-width* mod-padlen))) ) ) )
      ;<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-constant KRL-OPTIONS '(
  #:sort #:module #:case-insensitive? #t #:macros? #t))

(define apropos-default-options (make-parameter '() (lambda (x)
  (cond
    ((boolean? x)
      (or
        (and x KRL-OPTIONS)
        '() ) )
    ;FIXME actually check for proper options
    ((list? x)
      x )
    (else
      (warning 'apropos-default-options "not a list of options" x)
      (apropos-default-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?) (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?) (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?) (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+ 1 i))
          (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)) )
|#