;;;;
;;;; load.stk   -- Extended load function
;;;;
;;;; Copyright © 2000-2024 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: 17-May-2000 14:55 (eg)
;;;;

(export build-path-from-shell-variable install-path
        load-path load-suffixes load-verbose current-loading-file
        try-load load
        find-path
        require provide provided? require/provide
        warning-when-not-provided
        require-library require-for-syntax
        include include-ci include-file
        autoload

        ;; FIXME
        %guess-pathname
        %stklos-conf-dir
        %stklos-conf-file
        %try-load-conditions
        %do-include
        %%require)


(define *path-separator*        (if (eqv? (running-os) 'windows) ";" ":"))
(define *load-suffixes*         (list (%shared-suffix) "ostk" "stk" "sld" "scm"))
(define *load-verbose*          #f)
(define *load-path*             '()) ;; initialized  later


;;
;; stklos-conf-file: returns an absolute name for the given configuration file
;;
(define-parameter %stklos-conf-dir
  (let ((old-path (make-path (getenv "HOME") ".stklos"))
        (xdg-conf (getenv "XDG_CONFIG_HOME")))
    (or (getenv "STKLOS_CONFDIR")
        (if (file-exists? old-path)
            old-path
            (make-path (or xdg-conf "~/.config")
                       "stklos"))))
  expand-file-name)

(define (%stklos-conf-file name)
  (make-path (%stklos-conf-dir) name))

#|
<doc EXT build-path-from-shell-variable
 * (build-path-from-shell-variable var)
 * (build-path-from-shell-variable var sep)
 *
 * Builds a path as a list of strings (which is the way STklos represents
 * paths) from the environment variable |var|, given the separator characters
 * given in |sep| (which defaults to `":"`, the standrad Unix path separator).
 * If the |var| is not definied in the environment,
 * |build-path-from-shell-variable| returns the empty list.
 *
 * If the shell variable `MYPATH` is "/bin:/sbin:/usr/bin"`, then
 * @lisp
 * (build-path-from-shell-variable "MYPATH")       => ("/bin" "/sbin" "/usr/bin")
 * (build-path-from-shell-variable "MYPATH" "/:")  => ("bin" "sbin" "usr" "bin")
 * @end lisp
doc>
|#
(define (build-path-from-shell-variable var :optional (sep *path-separator*))
  (let ((path (getenv var)))
    (if path
        (string-split path sep)
        '())))

;======================================================================
;
; *load-path* construction
;
;======================================================================
(set! *load-path*
      (let ((user-path (build-path-from-shell-variable "STKLOS_LOAD_PATH")))
        (if (null? user-path)
            (list "." (%library-prefix 'lib) (%library-prefix 'data))
            user-path)))

#|
<doc EXT load-path
 * (load-path)
 * (load-path value)
 *
 * |load-path| is a parameter object. It
 * returns the current load path. The load path is a list of strings
 * which correspond to the directories in which a file must be searched for
 * loading. Directories of the load path are ,(emph "prepended") (in
 * their apparition
 * order) to the file name given to |load| or |try-load| until the file
 * can be loaded.
 * @l
 * The initial value of the current load path can be set from the shell, by
 * setting the |STKLOS_LOAD_PATH| shell variable.
 * @l
 * Giving a |value| to the parameter |load-path| permits to change the
 * current list of paths.
doc>
|#
(define-parameter load-path *load-path*
  (lambda (new-path)
    ;; Sanity check
    (unless (list? new-path)
      (error 'load-path "bad list of path names ~S" new-path))
    (for-each (lambda (x)
                (unless (string? x)
                  (error 'load-path "bad path name ~S" x)))
              new-path)
    ;; Set the load path
    (set! *load-path* new-path)
    new-path))

#|
<doc EXT load-suffixes
 * (load-suffixes)
 * (load-suffixes value)
 *
 * |load-suffixes| is a parameter object. It
 * returns the list of possible suffixes for a Scheme file. Each suffix,
 * must be a string. Suffixes are appended (in their apparition order)
 * to a file name  is appended to a file name given to |load| or |try-load|
 * until the file can be loaded.
doc>
|#
(define-parameter load-suffixes *load-suffixes*
  (lambda (new)
    ;; Sanity check
    (unless (list? new)
      (error 'load-path "bad list of suffixes ~S" new))
    (for-each (lambda (x)
                (unless (string? x)
                  (error 'load-path "bad path name ~S" x)))
              new)
    ;; Set the load suffixes
    (set! *load-suffixes* new)
    new))

#|
<doc EXT load-verbose
 * (load-verbose)
 * (load-verbose value)
 *
 * |load-verbose| is a parameter object. It permits to display the
 * path name of the files which are loaded by |load| or |try-load| on
 * the current error port, when set to a true value. If |load-verbose|
 * is set to `#f`, no message is printed.
doc>
|#
(define-parameter load-verbose *load-verbose*
  (lambda (x) (set! *load-verbose* (and x #t)) *load-verbose*))


#|
<doc EXT current-loading-file
 * (current-loading-file)
 *
 * Returns the path of the file that is currently being loaded.
doc>
|#
(define-parameter current-loading-file #f)



#|
<doc EXT install-path
 * (install-path)
 * (install-path key)
 *
 * Returns the list of the installation directories chosen when {{stklos}} was
 * configured. Without parameter, |install-path| returns the path of all
 * configured directories. When |key| is provided, only the corresponding path is
 * returned. |Key| can be:
 *
 * - `#:libdir`  (directory for architecture specific installed files)
 * - `#:datadir` (directory for portable installed files)
 * - `#:docdir`  (directory for installed documentation)
 * - `#:htmldir` (directory for installed HTML documentation)
 * - `#:pdfdir`  (directory for installed PDF documentation)
doc>
|#
;; NOTE: placed here because other returnning path functions are here, but this
;; function is not really related to load.
(define (install-path :optional key)
  (let ((dirs (key-get (%stklos-configure) #:dirs #f)))
    (unless dirs
      (error 'install-path "cannot find configuration description"))
    (if key
        (begin
          (unless (keyword? key)
            (error 'install-path "bad keyword ~S" key))
          (let ((val (key-get dirs key #f)))
            (unless val
              (error 'install-path "cannot find directory for key ~S" key))
            val))
        dirs)))


;=============================================================================
;
;                               GUESS-PATHNAME
;
; Try to guess the full pathname of a scheme file using *load-path* and
; *load-suffix*
;=============================================================================

(define (%guess-pathname fn paths suffixes)

  (define (try f)
    (when (>= (stklos-debug-level) 2)
      (eprintf "%guess-pathname: trying ~S\n" f))
    (and (file-exists? f)
         (file-is-readable? f)
         (not (file-is-directory? f))
         f))

  (define (try-load-with-suffixes name suffixes)
    (let Loop ((s suffixes))
      (if (null? s)
          #f
          (or (try (string-append name "." (car s)))
              (Loop (cdr s))))))

  (define (try-load-from-path name paths suffixes)
    (let Loop ((dir paths))
      (if (null? dir)
          #f
          (let ((fn (string-append (car dir) "/" name)))
            (or (try fn)
                (try-load-with-suffixes fn suffixes)
                (Loop (cdr dir)))))))

  (unless (string? fn)
    (error '%guess-pathname "path must be a string (it was ~s)" fn))

  (if (regexp-match "\.?\.?/" fn)
      (or ;; First try to load file as given by user
          (try fn)
          ;; try to load file with suffix
          (try-load-with-suffixes fn suffixes)
          ;; try to load file in path
          (try-load-from-path fn paths suffixes))
      ;; Not a file which starts with './' '../' or '/'. Use the path
      (try-load-from-path fn paths suffixes)))

;=============================================================================
;
;  Rewriting of the TRY-LOAD primitive
;
;=============================================================================
(define %primitive-try-load try-load)


;; When %try-load handler restore the calling module, we lost the current environment
;; In fact we have a habdler which is
;;   (lambda (c)
;;      <some code>
;;      (%%set-current-module mod)
;;      ;; <== now c is lost
;;      (raise c))
;; As a consequence we use the global parameter object %try-load-conditions as a stack
;; to save/restore the current condition
(define %try-load-conditions
  (make-parameter '() (lambda (v) v)))      ;; will be used as a stack

(define (%try-load fn load-path load-suffixes env)
  (let ((path (%guess-pathname fn load-path load-suffixes))
        (oldp (current-loading-file))
        (res  #f)
        (out  (current-error-port))
        (mod  (current-module)))
    (when (and path (not (file-is-directory? path)))
      (current-loading-file path)
      (with-handler (lambda (c)
                      (%try-load-conditions (cons c (%try-load-conditions)))
                      (current-loading-file oldp)
                      (%%set-current-module mod)
                      ;; We have lost current environment, an then the value of c :-<
                      (let ((c (car (%try-load-conditions))))
                        (%try-load-conditions (cdr (%try-load-conditions)))
                        (raise c)))

          (when *load-verbose* (format out ";; Loading file ~S.\n" path))
          ;; Do not *always* call %primitive-try-load with 2 parameters here.
          (set! res (if env
                        (%primitive-try-load path env)
                        (%primitive-try-load path)))
          (when *load-verbose* (format out ";; File ~S loaded.\n" path))
          ;; Restore current-load-path
          (current-loading-file oldp)
          ;; Restore the module we had when entering
          (%%set-current-module mod)))
    res))

;;
;; Overload the function try-load primitive with a version which uses
;; load-path and load-suffixes
;;
(set! try-load (lambda (fn :optional env)
                 #:try-load
                 (%try-load fn (load-path) (load-suffixes) env)))

;=============================================================================
;
;  Rewriting of the LOAD primitive
;
;=============================================================================
(define (%cannot-load fn)
  (raise (make-condition &i/o-filename-error
                           'location 'load
                           'message  (format "cannot load file ~S" fn)
                           'backtrace (%vm-backtrace)
                           'filename fn
                           'r7rs-msg "cannot load file"
                           'r7rs-irritants (list fn))))

(define (%load fn load-path load-suffixes env)
  (if (%try-load fn load-path load-suffixes env)
    (values (void)) ;; To be sure to have only 1 value (for repl printing defines)
    (%cannot-load fn)))

(define (load fn :optional env)
  (%load fn (load-path) (load-suffixes) env))


#|
<doc EXT find-path
 * (find-path str)
 * (find-path str path)
 * (find-path str path suffixes)
 *
 * In its first form, |find-path| returns the path name of the file
 * that should be loaded by the procedure  |load| given the name |str|.
 * The string returned depends of the current  load path and of the
 * currently accepted suffixes.
 * @l
 * The other forms of |find-path| are more general and allow to give a path
 * list (a list of strings representing supposed directories) and a set
 * of suffixes (given as a list of strings too) to try for finding a file.
 * If no file is found, |find-path| returns `#f`.
 * @l
 * For instance, on a "classical" Unix box:
 * @lisp
 * (find-path "passwd" '("/bin" "/etc" "/tmp"))
 *             => "/etc/passwd"
 * (find-path "stdio" '("/usr" "/usr/include") '("c" "h" "stk"))
 *             => "/usr/include/stdio.h"
 * @end lisp
doc>
|#
(define (find-path fn :optional (path *load-path*) (suffixes *load-suffixes*))
  (%guess-pathname fn path suffixes))


;=============================================================================
;
; REQUIRE/PROVIDE stuff
;
;=============================================================================

#|
<doc EXT require provide require/provide provided?
 * (require string)
 * (provide string)
 * (require/provide string)
 * (provided? string)
 *
 * |Require| loads the file whose name is |string| if it was not
 * previously "_provided_". |Provide| permits to store |string| in
 * the list of already provided files. Providing a file permits to avoid
 * subsequent loads of this file. |Require/provide| is more or less equivalent to
 * a |require| followed by a |provide|. |Provided?| returns `#t` if
 * |string| was already provided; it returns `#f` otherwise.
doc>
|#
(define %%require       #f)
(define require         #f)
(define provide         #f)
(define provided?       #f)
(define require/provide #f)

(define-parameter warning-when-not-provided #t)  ;; FIXME: document it


#| HACK: FIXME:
 This version of require is a hacked one that transforms calls such
 as (require "srfi-N") in the sequence
  (begin
    (define-module STklos (import (srfi N)))
    (provide "srfi-N"))
 It is temporary and should be changed when require will no more be used
 for using SRFIs (and the documentation adapted)
|#
(define (%rewrite-require-spec spec path suff)
  (let ((match (regexp-match"^srfi-([1-9][0-9]*)$" spec)))  ;; Not srfi-0
    (if match
        ;; We required "srfi-N", try to transform it in "srfi/N"
        ;; We don't try first with "srfi-N", because we could find
        ;; old installed versions lying around
        (let* ((new (format "srfi/~a" (cadr match)))
               (lib  (string->symbol new))
               (file (find-path new path suff)))
          (if file
              (cons file lib)
              (let ((file (find-path spec path suff)))
                (and file
                     (cons file #f)))))
        ;; Non-SRFI require
        (let ((file (find-path spec path suff)))
          (and file
               (cons file #f))))))

;; ----------------------------------------
(let ((provided '())
      (stklos-building? (getenv "STKLOS_BUILDING")))


  (set! %%require
    (lambda (what lib-only?)
      (when stklos-building?
        ;; When building STklos, require-library ==  require.
        ;; Otherwise, we need an already installed  STklos
        (set! lib-only? #f))

      (unless (member what provided)
        (let* ((path (if lib-only?
                         (list (%library-prefix 'data))
                         (load-path)))
               (suff (load-suffixes))
               (file (%rewrite-require-spec what path suff)))
          (if file
              (let ((file     (car file))
                    (lib-name (cdr file)))
                (%load file '() '() #f)  ;; '() => no path & no suffixes
                (when lib-name
                  (%do-imports (find-module 'STklos)
                               (list (list lib-name))
                               #f)
                  (provide what)))
              (%cannot-load what))))

      (when (and (warning-when-not-provided)
                 (not (member what provided)))
        (format (current-error-port) "WARNING: ~S was not provided~%" what))
      what))


  (set! require
    (lambda (what)
      #:require
      (%%require what (load-path))))


  (set! require/provide
    (lambda (what)
      #:require/provide
      (unless (member what provided)
        (%load what (load-path) (load-suffixes) #f))
      (provide what)))


  (set! provide
    (lambda (what)
      #:provide
      (unless (member what provided)
        (set! provided (cons what provided)))
      what))


  (set! provided?
    (lambda (what)
      #:provided
      (and (member what provided) #t))))


;; Overload require with a macro to let the compiler deal with globals
(define-macro (require what)
  (if (string? what)
      (let ((spec (%rewrite-require-spec what (load-path) (load-suffixes))))
        (if (and spec (cdr spec))
            ;; spec is of the form ("name of file to load" lib-name)
            `(begin
               (define-module STklos (import ,(cdr spec)))
               (provide ,what))
            `(%%require ,what #f)))
      `(%%require ,what #f)))


(define-macro (require-library what)
  `(%%require ,what #t))

#|
<doc EXT require-for-syntax
 * (require-for-syntax string)
 *
doc>
|#
#;(define-macro (require-for-syntax name)
  `(when-compile
      (require ,name)))


(define-macro (require-for-syntax file)
  `(%%require4syntax ,file))



;=============================================================================
;
; INCLUDE
;
;=============================================================================
(define-macro (%do-include kind files)
  (let ((inc (string->symbol (format "%%~a" kind))))
    (if (null? files)
        (error kind "at least one parameter must be provided")
        `(,inc ,@(map (lambda (x)
                        ;; return x if find-path is null to improve messages
                        (or (find-path x) x))
                      files)))))

(define-macro (include . files)
  `(%do-include include ,files))

(define-macro (include-ci . files)
  `(%do-include include-ci ,files))


(define-macro (include-file file) ;; Only one file no search in the load-path
  `(%%include ,file))

#|
<doc EXT autoload
 * (autoload file symbol ...)
 *
 * TODO
 *
doc>
|#
(define-macro (autoload file . symbols)
  (let ((args (gensym))
        (old  (gensym)))
    `(begin
       ,@(map (lambda (x)
                `(define ,x (lambda ,args
                              (let ((,old ,x))
                                (require ,file)
                                (if (eq? ,old ,x)
                                    (error 'autoload "~S has not been defined in ~S"
                                           ',x ,file)
                                    (apply ,x ,args))))))
              symbols))))

; LocalWords:  repl autoload prepended
