;;;; 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))

;FIXME sloppy, # only after srfi, which must be 1st
(define-type module-name (or symbol (list symbol fixnum) (list-of (or symbol number))))

(define-type module-names (list-of module-name))
(define-type import-names (list-of symbol))

(: dynamic-import-warning (#!optional 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 (module-name-element? x) (or (symbol? x) (fixnum? x)))

(define (module-name-element->string m)
  (cond ((symbol? m) (symbol->string m))
        ((number? m) (number->string m))) )

(define (reverse-module-name-elements->string l)
 (string->symbol (reverse-string-append (intersperse  l "."))) )

(define (srfi-module? mdl)
  (and (eq? 'srfi (car mdl))
       (pair? (cdr mdl))
       (number? (cadr mdl))) )

(define (canonicalize-srfi-name n)
  (string-append "srfi" "-" (number->string n)) )

(define (canonicalize-module-name x)
  (cond ((symbol? x)
          x )
        ((and (pair? x) (every module-name-element? x))
          (let loop ((mdl x) (l '()))
            (cond ((null? mdl)
                    (reverse-module-name-elements->string l))
                  ((and (null? l) ;1st time
                        (srfi-module? mdl))
                    (let ((md (canonicalize-srfi-name (cadr mdl))))
                      (loop (cddr mdl) (cons md l))) )
                  (else
                    (let ((md (module-name-element->string (car mdl))))
                      (loop (cdr mdl) (cons 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)
        ;convert extended module syntax to internal form
  (let ((mds (map canonicalize-module-name mds))
        ;unchanging
        (idvals `(list ,@ids)) )
    ;default, using canonicalized mds
    (define (dfs)
      ((dynamic-import-warning) 'dynamic-import "no module could be imported" mds ids)
      (if (procedure? df) (df ids)
          df ) )
    ;try eval import ids from each module until it works, or defaults
    (let loop ((mds mds))
                         ;this is so non-portable
      (let ((import-expr `(let () (import (only ,(car mds) ,@ids)) ,idvals)))
        (if (null? (cdr mds))
            ;then last module
            (if (not df)  ;w/o default?
                ;then system-error on failure
                (eval import-expr)
                ;else defaults on failure
                (condition-case (eval import-expr)
                  ((exn syntax) (dfs))
                  ;"unbound variable": module exists but not import
                  ((exn runtime) (dfs))
                  (exn () (abort exn)) ) )
            ;else try next module on failure
            (condition-case (eval import-expr)
                            ;hum, exp in a exp
              ((exn syntax) (loop (cdr mds)))
              ;"unbound variable": module exists but not import
              ((exn runtime) (loop (cdr mds)))
              (exn () (abort exn)) ) ) ) ) ) )

;;; Public

;;

(define dynamic-import-warning
  (make-parameter warning
    (lambda (x)
      (assert (procedure? x) 'dynamic-import-warning "bad argument type - not a procedure" x)
      x)))

;;

(define-syntax dynamic-import
  (syntax-rules (default)

    ;List Module & Identifier

    ;w/o default
    ;
    ((dynamic-import (?md0 ...) (?id0 ...))
      (define-values (?id0 ...)
                     (apply values
                            (dynamic-importer '(?md0 ...) '(?id0 ...)))) )

    ;w/ literal default
    ;
    ((dynamic-import (?md0 ...) (?id0 ...) (default ?df0 ...))
      (dynamic-import (?md0 ...) (?id0 ...) (list ?df0 ...)) )

    ;w/ default
    ;
    ((dynamic-import (?md0 ...) (?id0 ...) ?df)
      (define-values (?id0 ...)
                     (apply values
                            (dynamic-importer '(?md0 ...) '(?id0 ...) ?df))) )

    ;Atom/List Module & Identifier => List

    ;w/o default

    ((dynamic-import (?md0 ...) ?id)
      (dynamic-import (?md0 ...) (?id)) )

    ((dynamic-import ?md ?id)
      (dynamic-import (?md) (?id)) )

    ;w/ literal default
    ;
    ((dynamic-import ?md0 ?md1 ... (?id0 ...) (default ?df0 ...))
      (dynamic-import (?md0 ?md1 ...) (?id0 ...) (list ?df0 ...)) )

    ;w/ default

    ((dynamic-import (?md0 ...) ?id0 ?id1 ... ?df)
      (dynamic-import (?md0 ...) (?id0 ?id1 ...) ?df) )

    ((dynamic-import ?md0 ?md1 ... (?id0 ...) ?df)
      (dynamic-import (?md0 ?md1 ...) (?id0 ...) ?df) )

    ((dynamic-import ?md ?id0 ?id1 ... ?df)
      (dynamic-import (?md) (?id0 ?id1 ...) ?df) )

    #; ;NO, will be confused w/ a func form
    ((dynamic-import ?md0 ?md1 ... (?id0 ...))
      (dynamic-import (?md0 ?md1 ...) (?id0 ...)) ) ) )

) ;module dynamic-import