;;;;
;;;;
;;;; apropos.stk         -- apropos function (and its variants)
;;;;
;;;; Copyright © 2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@stklos.net]
;;;;    Creation date:  4-Dec-2023 15:39
;;;;


#|
<doc EXT apropos/alist apropos/pp apropos
 * (apropos obj)
 * (apropos/alist obj)
 * (apropos/pp obj)
 * (apropos obj module ...)
 * (apropos/alist obj module ...)
 * (apropos/pp obj module ...)
 *
 * These procedures return the symbols whose print name contains the characters
 * of |obj| as a substring, in the specified modules.  The given |obj| can be
 * a string or symbol, and each module argument can be a symbol, a string, or
 * the module itself.
 *
 * - If no |module| is provided, the current module is used.
 * - If modules are given, then these modules are searched.
 * - If only a single `#t` argument is given for a |module|, then all matching
 *   symbols from all loaded modules will be searched.
 *
 * The |apropos| command returns the symbols that can be used in a given module,
 * that is:
 *
 * - it returns the symbols defined or imported if the module is the current
 *   module.
 * - it returns the symbols exported by the module, if this module it is not
 *   the current one.
 *
 * The three variants of |apropos| are:
 *
 * - |apropos| returns a flat list of symbols, and no information about the
 *   modules where they are defined.
 * - |apropos/alist| returns an association list where the key is a module name
 *   (as a symbol) and the data is a list of matched symbols which can be accessed
 *   from the given module.
 * - |apropos/pp| does not have a return value, but prints the symbols on the
 *   screen, categorized by module.
 *
 * Note that using `#t` will bring the same symbols in several different modules,
 * since modules (as opposed to libraries) inherit all bindings in the |STklos|
 * module.
 *
 * @lisp
 * (define-library (A)
 *   (export zeta-one zeta-two zeta-three)
 *   (begin (define zeta-one 1)
 *          (define zeta-two 2)
 *          (define theta-three 3)))
 * (define-library (B)
 *   (export zeta-two zeta-three theta-four) ; but not zed
 *   (begin (define zeta-two 2)
 *          (define zeta-three 3)
 *          (define theta-four 4)
 *          (define zed 5)))
 * (define-library (C)
 *   (export zee)
 *   (import (B))
 *   (begin (define zee -1)))
 *
 * (apropos/alist 'zeta
 *                'A                      ; a symbol (module name)
 *                (find-module 'B))       ; and a module
 *          => ( (A (zeta-one zeta-three zeta-two))
 *               (B (zeta-three zeta-two)) )
 *
 * (apropos/pp 'zeta
 *                "A"                     ; a string (module name)
 *                'B)                     ; a symbol (module name)
 *          => void
 * And outputs, to the current output port, the following:
 * Module A:
 *    zeta-one
 *    zeta-three
 *    zeta-two
 * Module B:
 *    zeta-three
 *    zeta-two
 *
 * (apropos "x" (find-module 'A))         ; obj is a string
 *          => ()                         ; no symbol found
 *
 * (apropos 'o '(B))                      ; module name can be a list
 *          => (theta-four zeta-two)      ; simple list returned by apropos
 *
 * (apropos/alist 'a #t)
 *          => <all symbols with "a" in their names exported by all modules>
 * @end lisp
doc>
|#

(define-module (scheme apropos)
  (export apropos apropos/pp apropos/alist)

  ;; list->set is a simple procedure to eliminate duplicates
  (define (list->set lst res)
    (cond
     ((null? lst) res)
     ((memq (car lst) res) (list->set (cdr lst) res))
     (else (list->set (cdr lst) (cons (car lst) res)))))

  ;; set-diff computes the set difference A \ B
  (define (set-diff A B)
    (let ((tmp A))
      (for-each (lambda (x) (set! tmp (delete x tmp eq?))) B)
      tmp))

  (define (symbol<? s1 s2)
    (string<? (symbol->string s1) (symbol->string s2)))

  (define (check-module m)
    (cond ((module? m) m)
          ((symbol? m) (find-module m))
          ((list? m)   (find-module m)) ; module name can be a list...
          ((string? m) (find-module (string->symbol m)))
          (else (error 'apropos "bad module ~S" m))))

  (define (apropos-get-modules module-list)
    ;; Just gets all modules from module-list:
    (cond
     ((null? module-list)         (list (current-module)))
     ((equal? module-list '(#t))  (all-modules))
     (else                        (map check-module module-list))))

  ;; grab-symbols returns symbols (containing "str") which can be used
  ;; That is:
  ;;   - the symbols defined or imported if module is current-module
  ;;   - the exported symbols of given module otherwise
  (define (grab-symbols str module)
    (let ((s        (if (symbol? str) (symbol->string str) str))
          (symbols  (if (eq? module (current-module))
                        (let ((external (if (library? module)
                                            '()
                                            (module-symbols 'STklos)))
                              (internal (module-symbols module)))
                          (list->set (append internal external) '()))
                        (module-exports module))))
      (let Loop ((symbs symbols)
                 (res   '()))
        (cond
         ((null? symbs)
          (and (not (null? res)) (sort res symbol<?)))
         ((string-find? s (symbol->string (car symbs)))
          (Loop (cdr symbs) (cons (car symbs) res)))
         (else
          (Loop (cdr symbs) res))))))

  ;;
  ;; ---- apropos/alist
  ;;
  (define (apropos/alist str . modules)
    (let ((modules (apropos-get-modules modules)))
      (filter (lambda (x) (cadr x)) ;; don't include modules that don't have any
              ;; matching symbols
              ;; the result will be an alist, ( (module1 [list-of-symbols])
              ;;                                (module2 [list-of-symbols])
              ;;                                ... )
              (map (lambda (m) (list (module-name m)
                                (grab-symbols str m)))
                   modules))))

  ;;
  ;; apropos
  ;;
  (define (apropos str . module-list)

    (define (flatten lst)
      (let loop ((L lst) (A '()))
        (cond
         ((null? L) A)
         ((pair? L) (loop (car L)
                          (loop (cdr L) A)))
         (else (cons L A)))))

    (sort (list->set ; because the same symbol could be in more than one module
           (flatten (map cadr
                         (apply apropos/alist (cons str module-list))))
           '())
          symbol<?))
  ;;
  ;; apropos/pp
  ;;
  (define (apropos/pp str . module-list)
    (let ((a (apply apropos/alist (cons str module-list))))
      (for-each (lambda (module+sylbols)
                  (let ((m    (car module+sylbols))
                        (syms (cadr module+sylbols)))
                    ;; m is certainly a symbol, so we can use
                    ;; find-module on it!
                    (printf "~a ~a:~%" (if (library? (find-module m))
                                           "Library"
                                           "Module")
                            m)
                    (for-each (lambda (s) (format #t "   ~a~%" s)) syms)))
                a)))

) ;; end of module (stklos apropos)

;; Make the apropos functions available in STklos as soon as this file is loaded.
(select-module STklos)
(import (scheme apropos))

(provide "stklos/apropos")
