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

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

;; Issues
;;

(module dynamic-import

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

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

(define-type module-names (list-of (or symbol (list symbol fixnum) (list-of (or symbol number)))))
(define-type import-names (list-of symbol))

(: dynamic-import-warning (#!optional (or boolean procedure) -> procedure))

(: dynamic-importer (module-names import-names #!optional (or list procedure) -> *))

;;; Private

;; No Dependencies

;srfi-1
(define (every p l)
  (let loop ((l l))
    (or (null? l)
        (and (p (car l))
             (loop (cdr l)))) ) )

;FIXME handle (...) style module names

;FIXME sloppy, # only after srfi, which must be 1st
(define (modnam-cmpnt? x) (or (symbol? x) (fixnum? x)))

(define (modnam-cmpnt->string m)
  (cond ((symbol? m) (symbol->string m))
        ((number? m) (number->string m))) )

(define (reverse-modnam-cmpnts->string l)
 (string->symbol (reverse-string-append (intersperse  l "."))) )

(define (canonicalize-module-name x)
  (cond ((symbol? x)
          x )
        ((and (pair? x) (every modnam-cmpnt? x))
          (let loop ((mdl x) (l '()))
            (if (null? mdl)
                (reverse-modnam-cmpnts->string l)
                (let ((md (car mdl)))
                  (cond ((and (null? l) ;1st time
                              (eq? 'srfi md)
                              (fx= 2 (length mdl)) (number? (cadr mdl)))
                          (let ((md (string-append "srfi" "-" (number->string (cadr mdl)))))
                            (loop (cddr mdl) (cons md l))) )
                        (else
                          (loop (cdr mdl) (cons (modnam-cmpnt->string md) l))) ) ) ) ) )
        (else
          (error 'canonicalize-module-name "invalid module name") ) ) )

(define (dynamic-importer mds ids #!optional df)
  ;error early
  (assert (or (not df) (pair? df) (procedure? df))
          'dynamic-importer
          "bad argument type - invalid default, not a procedure or list" df)
  ;
  (let ((mds (map canonicalize-module-name mds))
        (idvals `(list ,@ids)) )
    ;report w/ transformed mds
    (define (dfs)
      ((dynamic-import-warning) 'dynamic-import "no module could be imported" mds ids)
      (if (procedure? df) (df ids)
          df ) )
    ;
    (let loop ((mds mds))
      (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)) ;hum, exp in a exp
             (eval expr)) ) ) ) ) )

;;; Public

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

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

) ;module dynamic-import