;;;;
;;;; module.stk -- Module stuff
;;;;
;;;; Copyright © 2000-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@unice.fr]
;;;;    Creation date:  1-Jun-2000 12:26 (eg)
;;;;

;;=============================================================================
;;
;;                              MODULE-SYMBOLS*
;;
;;=============================================================================
#|
<doc EXT module-symbols*
 * (module-symbols+++*+++ module)
 *
 * Returns the the list of symbols acessible in |module| (that is the symbols
 * defined in |module| and the one defined in the |STklos| module if module
 * is not a R7RS library.
doc>
|#
(define (module-symbols* module)
  (append (module-symbols module)
          (if (library? module)
              '()
              (module-symbols (find-module 'STklos)))))

;;=============================================================================
;;
;;                              MODULE-EXPORTS
;;
;;=============================================================================
#|
<doc EXT module-exports
 * (module-exports module)
 *
 * Returns the list of symbols exported by |module|. Note that this function
 * returns the list of symbols given in the module |export| clause and that
 * some of these symbols can be not yet defined.
 *
 * @lisp
 * (define-module M
 *   (export a b (rename c M-c))
 *   (display (module-exports (current-module))))
 *                          @print{} (a b M-c)
 * @end lisp
doc>
|#
(define (module-exports mod)
  (let ((module (if (module? mod) mod (find-module mod))))
    (map cdr (%module-exports module))))



;;=============================================================================
;;
;;                              SELECT-MODULE
;;
;;=============================================================================
#|
<doc EXT-SYNTAX select-module
 * (select-module <name>)
 *
 * Changes the value of the current module to the module with the given |name|.
 * The expressions evaluated after |select-module| will take place in
 * module |name| environment.  Module |name| must have been created
 * previously by a |define-module|. The result of |select-module| is
 * *_void_*.
 *
 * |Select-module| is particularly useful when debugging since it
 * allows to place toplevel evaluation in a particular module. The
 * following transcript shows an usage of |select-module|.
 * footnote:[This transcript uses the default toplevel loop
 *             which displays the name of the current module in the evaluator
 *             prompt.]):
 * @lisp
 * stklos> (define foo 1)
 * stklos> (define-module bar (define foo 2))
 * stklos> foo
 * 1
 * stklos> (select-module bar)
 * bar> foo
 * 2
 * bar> (select-module stklos)
 * stklos>
 * @end lisp
doc>
|#
(define-macro (select-module name)
  ;; HACK: try to register the symbols definined in chosen module to make
  ;; them known to the compiler (and avoid messages about undefined)
  (let* ((compfile (in-module STKLOS-COMPILER *compiling-file*))
         (mod      (find-module name #f))
         (newmod   (or mod (if compfile
                               (%module-create name)
                               (error 'select-module "module ~s does not exists" name)))))
    (when (and mod (not (eq? name 'STklos)))
      (register-new-globals! (module-symbols mod)))

  ;; The real expansion of the select-module
  `(begin
     (%%set-current-module (find-module ',name))
     (when-compile (compiler-current-module ,newmod)))))
;;=============================================================================
;;
;;                              DEFINE-MODULE
;;
;;=============================================================================
#|
<doc EXT-SYNTAX define-module
 * (define-module <name> <expr1> <expr2> ...)
 *
 * |Define-module| evaluates the expressions |<expr1>|, |<expr2>| ... which
 * constitute the body of the module |<name>| in the environment of that module.
 * |Name| must be a valid symbol or a list constitued of symbols or positive integers.
 * If |name| has not already been used to define a module, a new module, named |name|,
 * is created.  Otherwise, the expressions |<expr1>|, |<expr2>| ... are evaluated in
 * the environment of the (old) module `|<name>|`footnote:[In fact
 * |define-module| on a given name defines a new module
 * only the first time it is invoked on this name. By this way, interactively
 * reloading a module does not define a new entity, and the other modules
 * which use it are not altered.]
 *
 * Definitions done in a module are local to the module and do not interact with
 * the definitions in other modules. Consider the following definitions,
 * @lisp
 * (define-module M1
 *    (define a 1))
 *
 * (define-module M2
 *   (define a 2)
 *   (define b (* 2 x)))
 *
 * (define-module (M2 m)
 *   (define a 100)
 *   (define x 200))
 * @end lisp
 *
 * Here, three modules are defined and they all bind the symbol |a| to a
 * value. However, since |a| has been defined in distinct modules
 * they denote three different locations.
 *
 * The |STklos| module, which is predefined, is a special module which
 * contains all the *global bindings* of a {{rseven}} program.  A symbol
 * defined in the |STklos| module, if not hidden by a local definition, is
 * always visible from inside a module. So, in the previous exemple, the
 * |x| symbol refers the |x| symbol defined in the |STklos| module, which is
 * of course different of the one defined in the module |(M2 m)|.
 *
 * The result of |define-module| is *_void_*.
 *
 * NOTE: Internally, modules name are always represented by a symbol. If the module
 * name is given as a list, the internal name is built by appending all the components
 * of the list, separated by a `'/'` symbol. So the third module can be referenced with the
 * name |(M2 m)| of |M2/m|.
doc>
|#
(define-macro (define-module name . body)
  (let ((oldmod (compiler-current-module))
        (newmod (or (find-module name #f) (%module-create name))))
  `(with-handler
      %module-handler
      (%%set-current-module (%module-create ',name))
      (%%when-compile (compiler-current-module ,newmod))
      ,@body
      (%%when-compile (compiler-current-module ,oldmod))
      (%%set-current-module ( (%%in-scheme '%module-restore) ))
      (values (void) ',name))))

;;=============================================================================
;;
;;                              IMPORT
;;
;;=============================================================================
#|
<doc EXT-SYNTAX import
 * (import <import set1> <import set2> ...)
 *
 * An import declaration provides a way to import identifiers
 * exported by a module.  Each |<import set>| names a set of bindings
 * from a module and possibly specifies local names for the
 * imported bindings. It takes one of the following forms:
 *
 * * |<module name>|
 * * |(only <import set> <identifier> ...)|
 * * |(except <import set> <identifier> ...)|
 * * |(prefix <import set> <identifier>)|
 * * |(rename <import set> (<identifier1> <identifier2>) ...)|
 *
 * In the first form, all of the identifiers in the named
 * module's export clauses are imported with the same names
 * (or the exported names if exported with |rename|).
 *
 * The additional |import set| forms modify this set as follows:
 *
 * * |only| produces a subset of the given <import set>} including
 *   only the listed identifiers (after any renaming).  It is an
 *   error if any of the listed identifiers are not found in the
 *   original set.
 *
 * * |except| produces a subset of the given |<import set>|, excluding
 *   the listed identifiers (after any renaming). It is an error if
 *   any of the listed identifiers are not found in the original set.
 *
 * * |rename| modifies the given |<import set>|, replacing each
 *   instance of |<identifier1>| with |<identifier2>|. It is an
 *   error if any of the listed |<identifiers>| are not found in
 *   the original set.
 *
 * * |prefix| automatically renames all identifiers in the given
 *   |<import set>|, prefixing each with the specified |<identifier>|.
 *
 * @lisp
 * (define-module M1
 *   (export a b)
 *   (define a 'M1-a)
 *   (define b 'M1-b))
 *
 * (define-module M2
 *   (export b c d)
 *   (define b 'M2-b)
 *   (define c 'M2-c)
 *   (define d 'M2-d))
 *
 * (define-module M3
 *   (import M1 M2)
 *   (display (list a b c d)))  @print{} (M1-a M2-b M2-c M2-d)
 *
 * (define-module M4
 *   (import M2 M1)
 *   (display (list a b c d)))  @print{} (M1-a M1-b M2-c M2-d)
 * @end lisp
 *
 * @lisp
 * (define-module M1
 *   (export a b c d)
 *   (define a 1)
 *   (define b 2)
 *   (define c 3)
 *   (define d 4))
 *
 * (define-module M2
 *   (import (prefix (rename (except M1 a)
 *                           (b bb) (c cc))
 *                   M1-))
 *   (display (module-symbols (current-module))))
 *                              @print{} (M1-bb M1-cc M1-d)
 * @end lisp
 *
 * Here, |M1| module exports the symbols |a|, |b|, |c| and |d|. In the
 * |M2| module, the |except| rule permits to import only |b|, |c| and
 * |d|. With |rename|, identifiers |b| and |c| of |M1| are renamed |bb|
 * and |cc|. Finally, with |prefix| alls identifier names are prefixed
 * by |M1-|.
 *
 * NOTE: the |import| form in {{stklos}} modules is compatible with the
 * |import| clause in {{rseven}} libraries.
 *
 * NOTE: The module |STklos|, which contains the _global variables_
 * is always implicitly imported from a module. Furthermore,
 * this module is always placed at the end of the list of imported
 * modules.
 *
 * Note that importing a module will try to load a file if the module
 * is not already defined. For instance,
 * @lisp
 * (define-module M
 *    (import (srfi 1) (foo bar baz))
 *     ...)
 * @end lisp
 * will load the file |srfi/1| and |foo/bar/baz| modules (or libraries) if
 * they are not yet defined (habitual rules on the load paths and the load
 * suffixes applies to find  those files).
doc>
|#
(define (%parse-imports imports)

  (define (parse import-set)
    ;; Build a key-list of the import-set. If the import-set is
    ;;       (prefix (only (a b) x y z) foo-),
    ;; it returns a list of the form
    ;;       (a/b #:only (x y z) #:prefix foo-)
    (cond
     ((list? import-set)
      (let ((key (car import-set)))
        (case key

          ((only)
           (if (>= (length import-set) 3)
               (let ((ids (cddr import-set)))
                 (unless (every symbol? ids)
                   (error 'import "bad list of symbols ~s in only clause"
                          ids key))
                 `(,@(parse (cadr import-set)) #:only ,ids))
               (error 'import "bad only clause ~s" import-set)))

          ((except)
           (if (>= (length import-set) 3)
               (let ((ids (cddr import-set)))
                 (unless (every symbol? ids)
                   (error 'import "bad list of symbols ~s in except clause" ids))
                 `(,@(parse (cadr import-set)) #:except ,ids))
               (error 'import "bad except clause ~s" import-set)))

          ((prefix)
           (if (and (= (length import-set) 3)
                    (symbol? (caddr import-set)))
               `(,@(parse (cadr import-set)) #:prefix ,(caddr import-set))
               (error 'import "bad prefix clause ~s" import-set)))

          ((rename)
           (if (>= (length import-set) 3)
               (let ((assocs (cddr import-set)))
                 ;; Verify that all the assocs are well formed
                 (unless (every (lambda (x)
                                  (and (list? x) (= (length x) 2)
                                       (symbol? (car x)) (symbol? (cadr x))))
                                assocs)
                   (error 'import "bad list of associations ~s in rename clause"
                          assocs))
                 `(,@(parse (cadr import-set)) #:rename ,assocs))
               (error 'import "bad rename clause ~s" import-set)))

          (else
           (list (%normalize-library-name import-set))))))

     ((symbol? import-set)
      ;; a "legacy" STklos module
      (list import-set))

     (else
      (error 'import "bad import set ~s" import-set))))
  ;;
  ;; Return a list of parsed imports
  ;;
  (map parse imports))


(define (%do-imports lib clauses only-syntax)

  (define (eventually-load-library name)
    (let ((module (find-module name #f))
          (x      (%find-instanciated-module name)))
      (when (and module (not x))
        ;; FIXME FIXME
        ;;(%debug "On a trouvé le module ~S non instancié (~S)" module only-syntax)
        (unless only-syntax
          ;;(%debug "Bon ben je vais provoquer son chargement")
          (set! module #f)))
      (or module
          ;; Try to load a file which could define this module
          (begin
            (require/provide (symbol->string name))

            ;; Verify that the module was correctly defined in this file
            (let ((mod (find-module name #f)))
              (unless mod
                (error 'import "module/library ~s does not exist"
                       (%symbol->library-name name)))
              mod)))))

  (define (not-in-import-set clause symbol)
    ;; Signal an error only if we are not just importing for syntax.
    ;; Teh problem comes from the fact that we must do compute the import
    ;; clause two times (with only-syntax set to #t and #f).
    ;; In any case, the real import will always signal error, if some symbol
    ;; is not properly defined.
    (unless only-syntax
      (error clause "symbol ~s is not in the import set" symbol)))

  (define (build-import-list lib lst imported)
    (if (null? lst)
        imported
        (let ((key  (car lst))
              (val  (cadr lst))
              (rest (cddr lst)))
          (case key
            ((#:only)
             (let ((public (map cdr imported)))
               (for-each (lambda (symb)
                           (unless (memq symb public)
                             (not-in-import-set 'only symb)))
                         val))
             (set! imported (filter! (lambda (x) (memq (cdr x) val)) imported)))

            ((#:except)
             (let ((public (map cdr imported)))
               (for-each (lambda (symb)
                           (if (memq symb public)
                               (set! imported (remove (lambda (x) (eq? (cdr x) symb)) imported))
                               (not-in-import-set 'except symb)))
                         val)))
            ((#:rename)
             (for-each (lambda (pair)
                         (let ((original (car pair))
                               (new      (cadr pair)))
                           (let Loop ((lst imported))
                             (if (null? lst)
                                 (not-in-import-set 'rename original)
                                 (if (eq? (cdar lst) original)
                                     (set-cdr! (car lst) new)
                                     (Loop (cdr lst)))))))
                       val))
            ((#:prefix)
             (for-each (lambda (pair)
                         (set-cdr! pair (symbol-append val (cdr pair))))
                       imported)))
          ;; Loop with the rest of lst
          (build-import-list lib rest imported))))


  (define (import-symbols importer name keylist)
    (let* ((mod       (eventually-load-library name))
           (imported  (build-import-list mod
                                         keylist
                                         (list-copy (%module-exports mod)))))
      ;; Make aliases for all symbols in imported list
      (if only-syntax
          (for-each (lambda (pair)
                      (let ((val (symbol-value* (car pair) mod 'absent)))
                        (when (%syntax? val)
                          (%symbol-link (cdr pair) (car pair) lib mod))
                        (register-new-global! (cdr pair))))
                      imported)
          (for-each (lambda (pair)
                      (%symbol-link (cdr pair) (car pair) lib mod)
                      (register-new-global! (cdr pair)))
                    imported))))

  (define (add-imports lst imports)
    ;; add all the modules of lst in the import list (if not yet present)
    (let Loop ((lst (reverse lst)) ; to keep original order
               (names (map module-name imports)))
      (cond
       ((null? lst)             (map find-module names))
       ((memq (caar lst) names) (Loop (cdr lst) names))
       (else                    (Loop (cdr lst)
                                      (cons (list (caar lst)) names))))))

  ;; Call import-symbols for each import spec
  (for-each (lambda (imp)
              (let ((name     (car imp))
                    (keylist  (cdr imp)))
                (import-symbols lib name keylist)))
            clauses)

  ;; Retain the import list (for module-imports)
  (%module-imports-set! lib (add-imports clauses (module-imports lib))))

;;;;
;;;; IMPORT
;;;;
(define-macro (import . modules)
  (let ((imp (%parse-imports modules)))
    ;; Since imported modules can define macros. We need to grab them
    ;; in case we are just compiling a file to produce a '.ostk' file
    (for-each (lambda (x)
                (%grab-file-information (symbol->string (car x))))
              imp)
    ;; Do importation at compile time AND at execution time
    (%do-imports (compiler-current-module) (list-copy imp) #t)

    ;; Run time expansion
    `(%do-imports (current-module) (list-copy ',imp) #f)))

(define (%%import lib modules)
  (let ((imp (%parse-imports modules)))
    ;; Since imported modules can define macros. We need to grab them
    ;; in case we are just compiling a file to produce a '.ostk' file
    (for-each (lambda (x)
                (%grab-file-information (symbol->string (car x))))
              imp)
    ;; Do importation at compile time AND at execution time
    ;(%do-imports  (compiler-current-module) (list-copy imp) #t)
    (%do-imports lib (list-copy imp) #f)))


;;=============================================================================
;;
;;                              EXPORT
;;
;;=============================================================================
#|
<doc EXT-SYNTAX export
 * (export <export spec1> <export spec2> ...)
 *
 * Specifies the symbols which are exported (i.e. *visible* outside
 * the current module). By default, symbols defined in a module are not
 * visible outside this module, excepted if they appear in an |export|
 * clause.
 *
 * An |<export spec>| takes one of the following forms:
 *
 * * |<identifier>|
 * * |(rename <identifier1> <identifier2>)|
 *
 * In the first form, |<identifier>| names a single binding defined within or
 * imported into the module, where the external name for the export is the same
 * as the name of the binding  within the module.
 *
 * In the second form,  the binding defined within or imported into the module and
 * named by |<identifier1>| in each |(<identifier1> <identifier2>)| pairing,
 * using |<identifier2>| as the external name.
 *
 * The result of |export| is *_void_*.
 *
 * NOTE: the |export| form in {{stklos}} modules is compatible with the |export|
 * clause in {{rseven}} libraries.
 *
doc>
|#
(define (%parse-exports symbols)
  ;; Used at compile-time: returns a list of pairs ((name . exported-name) ... )

  (let Loop ((l symbols) (res '()))
    (cond
     ((null? l)
          (let ((res (reverse! res)))
            ;; HACK: register exported symbols to avoid furteher useless
            ;; compilation messages.
            (register-new-globals!  (map car res))

            ;; HACK: do the exportations in compiler-current-module to permit
            ;; the syntax publication in header of `.ostk` files. It means
            ;; that exportations are done two times when compiling (but only
            ;; once when loding a file)
            (%do-exports (compiler-current-module) res)
            res))

     ((symbol? (car l))
          ;; export a single identifier
          (let ((s (car l)))
            (Loop (cdr l)
                  (cons (cons s s)
                        res))))

     ((and (pair? (car l)) (eq? (caar l) 'rename))
          ;; export with renaming: (rename old new)
          (let ((symbs (cdar l)))
            (unless (and (= (length symbs) 2)
                         (symbol? (car symbs))
                         (symbol? (cadr symbs)))
              (error 'export "bad renaming clause ~S" (car l)))
            (Loop (cdr l)
                  (cons (cons (car symbs) (cadr symbs))
                        res))))

     (else
          (error 'export "bad exportation `~S'" (car l))))))


(define (%do-exports lib symbols)

  (define (add-symbol name rename lst)
    (let ((old (assq name lst)))
      (if old
          (let ((old-rename (cdr old)))
            (unless (or (eq? name old-rename)
                        (eq? old-rename rename))
              (error 'export "exported symbol ~s was previously renamed as ~S"
                     name old-rename))
            (set-cdr! old rename)
            lst)
          (cons (cons name rename) lst))))

  (let Loop ((l symbols) (res (%module-exports lib)))
    (cond
     ((null? l) (%module-exports-set! lib res))
     (else
          (let ((symbs (car l)))
            (Loop (cdr l)
                  (add-symbol (car symbs) (cdr symbs) res)))))))


;;;;
;;;; EXPORT
;;;;
(define-macro (export . symbols)
  (let ((s (%parse-exports symbols)))
    `(%do-exports (current-module) ',s)))

;;//;; FIXME: For compatibility (should be deleted soon)
;;//(define (%module-export module . symbols)
;;//  (%do-exports module symbols))


;;; FIXME:
(define-macro (export-syntax . arg)
  ;; This is only an approximation. Must be rewritten
  `(%%publish-syntax ,@arg))

;;=============================================================================
;;
;;                              IN-MODULE
;;
;;=============================================================================
#|
<doc EXT-SYNTAX in-module
 * (in-module mod s)
 * (in-module mod s default)
 *
 * This form returns the value of symbol with name |s| in the module with name
 * |mod|. If this symbol is not bound,  an error is signaled if no |default| is
 * provided, otherwise |in-module| returns |default|. Note that the value of |s|
 * is searched in |mod| and all the modules it imports.
 *
 * This form is in fact a shortcut. In effect,
 * @lisp
 * (in-module my-module foo)
 * @end lisp
 *
 * is equivalent to
 * @lisp
 * (symbol-value* 'foo (find-module 'my-module))
 * @end lisp
doc>
|#
(define-macro (in-module mod symb . default)
  ;; If mod is the symbol SCHEME we know the user wants the SCHEME module.
  ;; This is because:
  ;;
  ;; 1. That module cannot be renamed.
  ;; 2. This is a macro, and we don't need to (and cannot!) evaluate its
  ;;    arguments.
  ;;
  ;; So, in that case we can call the `%%in-scheme` primitive, which is
  ;; much faster than using apply and symbol-value*.
  ;; however, if the user wanted a default value, we revert to applying
  ;; symbol-value*, because we'd need a handler around %%in-scheme, which
  ;; becomes terribly slow.
  (if (and (eq? mod 'SCHEME)
           (null? default))
      `(%%in-scheme ',symb)
      `(apply symbol-value* ',symb (find-module ',mod) ',default)))


;;=============================================================================
;;
;;                              MODULE-LIST
;;
;;=============================================================================
#|
<doc EXT module-list
 * (module-list)
 *
 *  Returns the list of all the living modules.
doc>
|#
(define (module-list)
  (filter (lambda (x) (not (library? x)))
          (all-modules)))
