;;;; dynamic-import.scm  -*- Scheme -*-
;;;; Kon Lovett, Feb '22

;inspired by Feb 12 '22 #chicken irc - http-client & openssl eggs

(module dynamic-import

(;export
  dynamic-import-warning
  dynamic-importer
  dynamic-import)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (chicken syntax))
(import (chicken condition))

(: dynamic-import-warning (#!optional (or boolean procedure) -> procedure))
(: dynamic-importer ((list-of symbol) (list-of symbol) #!optional (or list procedure) -> *))

;;

;(srfi 1)
(define (make-list len elt) ;elt optional but here always provided
  (do ((i len (fx- i 1))
	     (ans '() (cons elt ans)))
	    ((fx<= i 0) ans)) )

(define (make-list/as df)
  (case-lambda
    (() df)
    ((n)
      (cond ((fixnum? n)
              (make-list n df))
            ((list? n)
              (make-list (length n) df))
            (else
              (error 'make-list/as
                     "invalid length specification" n df)) ) ) ) )

;;

(define dynamic-import-warning (make-parameter warning (lambda (x)
  (cond ((not x) void)
        ((procedure? x) x)
        ((boolean? x) warning)
        (else
          (warning 'dynamic-import-warning "not a boolean or procedure" x)
          (dynamic-import-warning))))))

(define-syntax dynamic-import
  (syntax-rules ()
    ;multiple identifier
    ;w/o default
    ((dynamic-import (?id0 ...) (?md0 ...))
      (define-values (?id0 ...)
                     (apply values
                      (dynamic-importer '(?id0 ...) '(?md0 ...)))) )
    ;w/ default default
    ((dynamic-import (?id0 ...) (?md0 ...) (default ?df))
      (define-values (?id0 ...)
                     (apply values
                      (dynamic-importer '(?id0 ...) '(?md0 ...)
                                        (make-list/as ?df)))) )
    ;w/ default
    ((dynamic-import (?id0 ...) (?md0 ...) ?df)
      (define-values (?id0 ...)
                     (apply values
                      (dynamic-importer '(?id0 ...) '(?md0 ...)
                                        ?df))) )
    ;single identifier
    ;w/o default
    ((dynamic-import ?id (?md0 ...))
      (dynamic-import (?id) (?md0 ...)) )
    ;w/o default
    ((dynamic-import ?id ?md)
      (dynamic-import (?id) (?md)) )
    ;w/ default
    ((dynamic-import ?id (?md0 ...) ?df)
      (dynamic-import (?id) (?md0 ...) ?df) )
    ;w/ default & single module
    ((dynamic-import ?id ?md ?df)
      (dynamic-import (?id) (?md) ?df) ) ) )

(define (dynamic-importer ids mds #!optional df)
  (define (dfs)
    ((dynamic-import-warning) 'dynamic-import "no module found" mds)
    (cond ((list? df) df)
          ((procedure? df) (df ids))
          (else
            (error 'dynamic-importer
                   "invalid default, not a procedure or list" df))))
  (let ((idvals `(list ,@ids)))
    (let loop ((mds mds))
      (if (null? mds)
          (error 'dynamic-importer "empty module list" ids mds df)
          (let ((expr `(let () (import (only ,(car mds) ,@ids)) ,idvals)))
            (if (null? (cdr mds))
                ;then last module
                ;w/o default then system-error on failure
                (if (not df) (eval expr)
                    ;else defaults on failure
                    (handle-exceptions
                     exn (dfs)
                     (eval expr)) )
                ;else try next module on failure
                (handle-exceptions
                 exn (loop (cdr mds))
                 (eval expr)) ) ) ) ) ) )

) ;module dynamic-import