;;; Runtime module interfaces
;;; Copyright (C) 2026 David Thompson <dave@spritely.institute>
;;;
;;; 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:
;;;
;;; Library isets as runtime module interfaces.
;;;
;;; Code:

(library (hoot interfaces)
  (export parse-isets
          parse-isets/syntax
          import-interface!)
  (import (hoot assoc)
          (hoot errors)
          (hoot equal)
          (hoot eval)
          (hoot library)
          (hoot lists)
          (hoot modules)
          (hoot pairs)
          (hoot procedures)
          (hoot symbols)
          (hoot syntax)
          (hoot syntax-objects)
          (ice-9 match))

  (define (make-interface src)
    (make-empty-module #:name (module-name src) #:root (module-root src)))

  (define (iset-only->interface src select)
    (let ((dst (make-interface src)))
      (for-each (lambda (id)
                  (module-import! dst src id)
                  (module-export! dst id))
                select)
      dst))

  (define (iset-except->interface src hide)
    (let ((dst (make-interface src)))
      (for-each (lambda (id)
                  (unless (memq id hide)
                    (module-import! dst src id)
                    (module-export! dst id)))
                (module-exported-names src))
      dst))

  (define (iset-prefix->interface src prefix)
    (let ((dst (make-interface src)))
      (for-each (lambda (id)
                  (module-import! dst src id)
                  (module-export! dst (symbol-append prefix id) id))
                (module-exported-names src))
      dst))

  (define (iset-rename->interface src renamings)
    (let ((dst (make-interface src)))
      (for-each (lambda (id)
                  (module-import! dst src id)
                  (module-export! dst (or (assq-ref renamings id) id) id))
                (module-exported-names src))
      dst))

  (define (iset-rename-proc->interface src exp)
    (let* ((dst (make-interface src))
           (rename (eval exp dst)))
      (unless (procedure? rename)
        (error "renamer must be a procedure" exp))
      (for-each (lambda (id)
                  (module-import! dst src id)
                  (module-export! dst (rename id) id))
                (module-exported-names src))
      dst))

  (define (iset-library->interface modname version)
    (unless (null? version)
      (error "version references unsupported"))
    (when (equal? modname '(hoot primitives))
      (error "untrusted module cannot import primitives"))
    (resolve-module (the-root-module) modname #:load? #t))

  (define* (parse-isets isets #:key
                        (parse-only iset-only->interface)
                        (parse-except iset-except->interface)
                        (parse-prefix iset-prefix->interface)
                        (parse-rename iset-rename->interface)
                        (parse-rename-proc iset-rename-proc->interface)
                        (parse-library iset-library->interface))
    (define parse-iset
      (lambda (iset)
        (match iset
          (($ <iset-only> iset select)
           (parse-only (parse-iset iset) select))
          (($ <iset-except> iset hide)
           (parse-except (parse-iset iset) hide))
          (($ <iset-prefix> iset prefix)
           (parse-prefix (parse-iset iset) prefix))
          (($ <iset-rename> iset renamings)
           (parse-rename (parse-iset iset) renamings))
          (($ <iset-rename-proc> iset exp)
           (parse-rename-proc (parse-iset iset) exp))
          (($ <iset-library> modname version)
           (parse-library modname version)))))
    (map parse-iset isets))

  (define (parse-isets/syntax stx isets)
    (define (datums->syntax lst)
      (map (lambda (x) (datum->syntax stx x)) lst))
    (parse-isets
     isets
     #:parse-only
     (lambda (src select)
       #`(iset-only->interface #,src '(#,@(datums->syntax select))))
     #:parse-except
     (lambda (src hide)
       #`(iset-except->interface #,src '(#,@(datums->syntax hide))))
     #:parse-prefix
     (lambda (src prefix)
       #`(iset-prefix->interface #,src '#,(datum->syntax stx prefix)))
     #:parse-rename
     (lambda (src renamings)
       #`(iset-rename->interface #,src '(#,@(datums->syntax renamings))))
     #:parse-rename-proc
     (lambda (src exp)
       #`(iset-rename-proc->interface #,src (quote-syntax #,exp)))
     #:parse-library
     (lambda (modname version)
       #`(iset-library->interface '#,(datum->syntax stx modname)
                                  '#,(datum->syntax stx version)))))

  (define (import-interface! mod iface)
    (for-each (lambda (id) (module-import! mod iface id))
              (module-exported-names iface))))
