;;;; 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 ...) '(?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 ?id) (dynamic-import (?id) (?md)) ) ;w/ default ((dynamic-import (?md0 ?md1 ...) ?id ?df) (dynamic-import (?md0 ?md1 ...) (?id) ?df) ) ;w/ default & single module ((dynamic-import ?id ?md ?df) (dynamic-import (?id) (?md) ?df) ) ) ) ) ;module dynamic-import