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

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

(module dynamic-import

(;export
  ;
  tabulated-list-of
  warning-on
  ;
  dynamic-import-warning
  dynamic-importer
  dynamic-import)

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

(: tabulated-list-of (* --> (#!optional (or integer list) -> (list-of *))))
(: warning-on (#!optional output-port -> procedure))

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

;;

(define (tabulated-list-of df)
  (case-lambda
    (() df)
    ((n)
      (import (only (srfi 1) make-list))
      (cond ((integer? n)
              (make-list n df))
            ((list? n)
              (make-list (length n) df))
            (else
              (error 'tabulated-list-of
                     "invalid length specification" n df)) ) ) ) )

;FIXME C5 warning system is inflexible
(define ((warning-on #!optional (port (current-output-port))) . rest)
  (import (only (chicken format) format) (only (chicken string) ->string))
  (display "Warning: " port)
  (unless (null? rest)
    (for-each (lambda (x) (write x port) (newline port)) rest)) )

;;

(define $warning (warning-on))

(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 ...)
                                        (tabulated-list-of ?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