;;; Modules
;;; Copyright (C) 2024, 2025 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Run-time representation of module trees.
;;;
;;; Code:

(library (hoot hackable)
  (export boot-module-tree
          install-module-api!
          declare-module!
          load-module
          current-load-path
          load-path
          add-to-load-path!)
  (import (hoot assoc)
          (hoot core-syntax)
          (hoot core-syntax-helpers)
          (hoot errors)
          (hoot expander)
          (hoot eq)
          (hoot equal)
          (hoot eval)
          (hoot file)
          (hoot interfaces)
          (hoot library)
          (hoot lists)
          (hoot modules)
          (hoot pairs)
          (hoot parameters)
          (hoot ports)
          (hoot primitives-module)
          (hoot procedures)
          (hoot read)
          (hoot strings)
          (hoot symbols)
          (hoot syntax-objects)
          (hoot values)
          (ice-9 match))

  (define (boot-module-tree)
    (define root (make-empty-module))
    (the-root-module root)
    (current-module-loader load-module-from-file-system)
    (initialize-core-syntax! (submodule-define! root '(hoot core-syntax)))
    (initialize-primitives! (submodule-define! root '(hoot primitives)))
    root)

  (define (install-module-api!)
    (let* ((this-mod (current-module))
           (guile-mod (resolve-module this-mod '(guile))))
      (define (make-variable val)
        (case-lambda
          (() val)
          ((new-val) (set! val new-val))))
      (for-each (lambda (name)
                  (module-add! guile-mod name
                               (make-variable
                                (module-ref this-mod name #:private? #t))))
                '(define-module use-modules))))

  (define (declare-module! root modname imports def-names def-vars
                           exports)
    (let ((mod (submodule-define! root modname)))
      (for-each (match-lambda
                  ((import-modname import-names export-names)
                   (let ((import-mod (resolve-module root import-modname)))
                     (for-each
                      (lambda (import-name export-name)
                        (module-import! mod import-mod import-name export-name))
                      import-names export-names))))
                imports)
      (for-each (lambda (name var)
                  (module-add! mod name var))
                def-names def-vars)
      (for-each (match-lambda
                  ((local-name . exported-name)
                   ;; Guile modules may redundantly export the same
                   ;; symbol.
                   (module-export! mod exported-name local-name #:replace? #t)))
                exports)
      mod))

  (define base-hoot-features
    '(r7rs exact-closed ieee-float full-unicode ratios wasm hoot hoot-1.0))

  (define (define-module* modname ifaces exports)
    (let ((mod (resolve-module (the-root-module) modname #:define? #t)))
      (for-each (lambda (iface) (import-interface! mod iface)) ifaces)
      (for-each (match-lambda
                  ((local-name . exported-name)
                   (module-export! mod exported-name local-name #:replace? #t)))
                exports)
      mod))

  (define-syntax define-module
    (lambda (stx)
      (match (parse-guile-library stx #'() #f)
        (($ <library> src name version trusted? duplicates exports
                      replacements isets body)
         (with-syntax (((name ...) (datum->syntax stx name))
                       ((iface ...) (parse-isets/syntax stx isets))
                       ((export ...) (datum->syntax stx exports)))
           #'(define-module* '(name ...) (list iface ...) '(export ...)))))))

  (define-syntax use-modules
    (lambda (stx)
      (syntax-case stx ()
        ((use-modules import-spec ...)
         #`(let ((mod (current-module use-modules)))
             (for-each (lambda (iface) (import-interface! mod iface))
                       (list #,@(parse-isets/syntax
                                 stx
                                 (map parse-guile-import
                                      #'(import-spec ...))))))))))

  (define (load-module root exp)
    (let ((stx (if (syntax? exp) exp (datum->syntax #f exp))))
      (match (parse-library stx #f #:features base-hoot-features)
        (($ <library> src name version trusted? duplicates exports
                      replacements isets body)
         ;; Parse isets before defining the module so that the module
         ;; remains undefined if loading a dependency fails.
         (let* ((ifaces (parse-isets isets))
                (mod (submodule-define! root name)))
           (for-each (lambda (src)
                       (for-each (lambda (id) (module-import! mod src id))
                                 (module-exported-names src)))
                     ifaces)
           (for-each (lambda (exp) (eval exp mod)) body)
           (for-each (match-lambda
                       ((local-name . exported-name)
                        (module-export! mod exported-name local-name
                                        #:replace? #t)))
                     (append exports replacements))
           mod)))))

  (define local-load-path
    (let ((load-path '()))
      (case-lambda
        (() load-path)
        ((dir) (set! load-path (cons dir load-path))))))

  ;; Allow for different load path implementations so we can, for
  ;; example, have a server-hosted load path when using the REPL
  ;; inside a web browser.
  ;;
  ;; TODO: Support removing from load path.
  (define current-load-path (make-parameter local-load-path))
  (define (load-path)
    ((current-load-path)))
  (define (add-to-load-path! dir)
    ((current-load-path) dir))

  (define (load-module-from-file-system root modname)
    (define extensions '(".scm" ".sls"))
    (define base-file-name (string-join (map symbol->string modname) "/"))
    (define (try-extension base extension)
      (with-exception-handler (lambda (exn) #f)
        (lambda ()
          (open-input-file
           (string-append base extension)))
        #:unwind? #t))
    (define (try-load-path dir)
      (let ((base (string-append dir "/" base-file-name)))
        (or-map (lambda (ext) (try-extension base ext)) extensions)))
    (define (read-exps port)
      (match (read-syntax port)
        ((? eof-object?)
         (close-port port)
         '())
        (stx (cons stx (read-exps port)))))
    (define port (or-map try-load-path (load-path)))
    (and port
         (let ((exps (read-exps port)))
           (close-port port)
           (load-module root exps)))))
