;; meta.scm -- meta langauge for describing modules
;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modules

(define *this-module* '())

(define (make-module exports env meta) (vector exports env meta #f))
(define (%module-exports mod) (vector-ref mod 0))
(define (module-env mod) (vector-ref mod 1))
(define (module-env-set! mod env) (vector-set! mod 1 env))
(define (module-meta-data mod) (vector-ref mod 2))
(define (module-meta-data-set! mod x) (vector-set! mod 2 x))

(define (module-exports mod)
  (or (%module-exports mod) (env-exports (module-env mod))))

(define (module-name->strings ls res)
  (if (null? ls)
      res
      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
                       ((number? (car ls)) (number->string (car ls)))
                       ((string? (car ls)) (car ls))
                       (else (error "invalid module name" (car ls))))))
        (module-name->strings (cdr ls) (cons "/" (cons str res))))))

(define (module-name->file name)
  (string-concatenate
   (reverse (cons ".sld" (cdr (module-name->strings name '()))))))

(define (module-name-prefix name)
  (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))

(define load-module-definition
  (let ((meta-env (current-environment)))
    (lambda (name)
      (let* ((file (module-name->file name))
             (path (find-module-file file)))
        (if path (load path meta-env))))))

(define (find-module name)
  (cond
   ((assoc name *modules*) => cdr)
   (else
    (load-module-definition name)
    (cond ((assoc name *modules*) => cdr)
          (else #f)))))

(define (add-module! name module)
  (set! *modules* (cons (cons name module) *modules*)))

(define (delete-module! name)
  (let lp ((ls *modules*) (prev #f))
    (cond ((null? ls))
          ((equal? name (car (car ls)))
           (if prev
               (set-cdr! prev (cdr ls))
               (set! *modules* (cdr ls))))
          (else (lp (cdr ls) ls)))))

(define (symbol-append a b)
  (string->symbol (string-append (symbol->string a) (symbol->string b))))

(define (symbol-drop a b)
  (let ((as (symbol->string a))
        (bs (symbol->string b)))
    (if (and (> (string-length bs) (string-length as))
             (string=? as (substring bs 0 (string-length as))))
        (string->symbol (substring bs (string-length as)))
        b)))

(define (warn msg . args)
  (display msg (current-error-port))
  (display ":" (current-error-port))
  (for-each (lambda (a)
              (display " " (current-error-port))
              (write a (current-error-port)))
            args)
  (newline (current-error-port)))

(define (to-id id) (if (pair? id) (car id) id))
(define (from-id id) (if (pair? id) (cdr id) id))
(define (id-filter pred ls)
  (cond ((null? ls) '())
        ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
        (else (id-filter pred (cdr ls)))))

(define (resolve-import x)
  (cond
   ((not (and (pair? x) (list? x)))
    (error "invalid module syntax" x))
   ((and (memq (car x) '(prefix drop-prefix))
         (symbol? (car (cddr x))) (list? (cadr x)))
    (let ((mod-name+imports (resolve-import (cadr x))))
      (cons (car mod-name+imports)
            (map (lambda (i)
                   (cons ((if (eq? (car x) 'drop-prefix)
                              symbol-drop
                              symbol-append)
                          (car (cddr x))
                          (to-id i))
                         (from-id i)))
                 (or (cdr mod-name+imports)
                     (module-exports (find-module (car mod-name+imports))))))))
   ((and (pair? (cdr x)) (pair? (cadr x)))
    (if (memq (car x) '(only except rename))
        (let* ((mod-name+imports (resolve-import (cadr x)))
               (imp-ids (or (cdr mod-name+imports)
                            (and (not (eq? 'only (car x)))
                                 (module-exports
                                  (find-module (car mod-name+imports)))))))
          ;; (if (not (eq? 'only (car x)))
          ;;     (let ((unbound
          ;;            (id-filter (lambda (i) (not (memq i imp-ids))) (cddr x))))
          ;;       (if (pair? unbound)
          ;;           (warn "import excepting unbound identifiers" unbound))))
          (cons (car mod-name+imports)
                (case (car x)
                  ((only)
                   (cddr x))
                  ((except)
                   (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
                  ((rename)
                   (map (lambda (i)
                          (let ((rename (assq (to-id i) (cddr x))))
                            (if rename (cons (cadr rename) (from-id i)) i)))
                        imp-ids)))))
        (error "invalid import modifier" x)))
   ((find-module x)
    => (lambda (mod) (cons x (%module-exports mod))))
   (else
    (error "couldn't find import" x))))

(define (eval-module name mod . o)
  (let ((env (if (pair? o) (car o) (make-environment)))
        (meta (module-meta-data mod))
        (dir (module-name-prefix name)))
    (define (load-modules files extension fold?)
      (for-each
       (lambda (f)
         (let ((f (string-append dir f extension)))
           (cond
            ((find-module-file f)
             => (lambda (path)
                  (cond (fold?
                         (let ((in (open-input-file path)))
                           (set-port-fold-case! in #t)
                           (load in env)))
                        (else
                         (load path env)))))
            (else (error "couldn't find include" f)))))
       files))
    ;; catch cyclic references
    (cond
     ((procedure? meta)
      (meta env))
     (else
      (module-meta-data-set!
       mod
       `((error "module attempted to reference itself while loading" ,name)))
      (for-each
       (lambda (x)
         (case (and (pair? x) (car x))
           ((import import-immutable)
            (for-each
             (lambda (m)
               (let* ((mod2-name+imports (resolve-import m))
                      (mod2 (load-module (car mod2-name+imports))))
                 (%import env (module-env mod2) (cdr mod2-name+imports) #t)))
             (cdr x)))))
       meta)
      (protect
          (exn (else
                (module-meta-data-set! mod meta)
                (if (not (any (lambda (x)
                                (and (pair? x)
                                     (memq (car x) '(import import-immutable))))
                              meta))
                    (warn "WARNING: exception inside module with no imports - did you forget to (import (scheme base)) in" name))
                (raise-continuable exn)))
        (for-each
         (lambda (x)
           (case (and (pair? x) (car x))
             ((include)
              (load-modules (cdr x) "" #f))
             ((include-ci)
              (load-modules (cdr x) "" #t))
             ((include-shared)
              (load-modules (cdr x) *shared-object-extension* #f))
             ((body begin)
              (for-each (lambda (expr) (eval expr env)) (cdr x)))
             ((error)
              (apply error (cdr x)))))
         meta))
      (module-meta-data-set! mod meta)
      (warn-undefs env #f)
      env))))

(define (environment . ls)
  (let ((env (make-environment)))
    (for-each
     (lambda (m)
       (let* ((mod2-name+imports (resolve-import m))
              (mod2 (load-module (car mod2-name+imports))))
         (%import env (module-env mod2) (cdr mod2-name+imports) #t)))
     ls)
    env))

(define (load-module name)
  (let ((mod (find-module name)))
    (if (and mod (not (module-env mod)))
        (module-env-set! mod (eval-module name mod)))
    mod))

(define-syntax meta-begin begin)
(define-syntax meta-define define)

(define define-library-transformer
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((name (cadr expr))
           (body (cddr expr))
           (tmp (rename 'tmp))
           (this-module (rename '*this-module*))
           (add-module! (rename 'add-module!))
           (_define (rename 'meta-define))
           (_let (rename 'let))
           (_if (rename 'if))
           (_cond (rename 'cond))
           (_set! (rename 'set!)))
       ;; Check for suspicious defines.
       (for-each
        (lambda (x)
          (if (and (pair? x) (memq (strip-syntactic-closures (car x))
                                   '(define define-syntax)))
              (warn "suspicious use of define in library declarations - did you forget to wrap it in begin?" x)))
        (cdr expr))
       ;; Generate the library wrapper.
       `(,_let ((,tmp ,this-module))
          (,_define (rewrite-export x)
            (,_if (pair? x)
                (,_if (and (= 3 (length x))
                           (eq? 'rename (identifier->symbol (car x))))
                    (cons (car (cddr x)) (cadr x))
                    (error "invalid module export" x))
                x))
          (,_define (extract-exports)
            (,_cond
             ((assq 'export-all ,this-module)
              => (lambda (x)
                   (if (pair? (cdr x))
                       (error "export-all takes no parameters" x))
                   #f))
             (else
              (,_let lp ((ls ,this-module) (res '()))
                (,_cond
                 ((null? ls) res)
                 ((and (pair? (car ls)) (eq? 'export (caar ls)))
                  (lp (cdr ls) (append (map rewrite-export (cdar ls)) res)))
                 (else (lp (cdr ls) res)))))))
          (,_set! ,this-module '())
          ,@body
          (,_set! ,this-module (reverse ,this-module))
          (,add-module! ',name (make-module (extract-exports) #f ,this-module))
          (,_set! ,this-module ,tmp))))))

(define-syntax define-library define-library-transformer)
(define-syntax module define-library-transformer)

(define-syntax define-config-primitive
  (er-macro-transformer
   (lambda (expr rename compare)
     `(define-syntax ,(cadr expr)
        (er-macro-transformer
         (lambda (expr rename compare)
           (let ((this-module (rename '*this-module*)))
             `(set! ,this-module (cons ',expr ,this-module)))))))))

(define-config-primitive import)
(define-config-primitive import-immutable)
(define-config-primitive export)
(define-config-primitive export-all)
(define-config-primitive include)
(define-config-primitive include-ci)
(define-config-primitive include-shared)
(define-config-primitive body)
(define-config-primitive begin)

;; The `import' binding used by (chibi) and (scheme base), etc.
(define-syntax repl-import
  (er-macro-transformer
   (let ((meta-env (current-environment)))
     (lambda (expr rename compare)
       (let lp ((ls (cdr expr)) (res '()))
         (cond
          ((null? ls)
           (cons (rename 'meta-begin) (reverse res)))
          (else
           (let ((mod+imps (resolve-import (car ls))))
             (cond
              ((pair? mod+imps)
               (lp (cdr ls)
                   (cons `(,(rename '%import)
                           #f
                           (,(rename 'module-env)
                            (,(rename 'load-module)
                             (,(rename 'quote) ,(car mod+imps))))
                           (,(rename 'quote) ,(cdr mod+imps))
                           #f)
                         res)))
              (else
               (error "couldn't find module" (car ls))))))))))))

(define *modules*
  (list
   (cons '(chibi)
         (make-module #f (interaction-environment) '((include "init-7.scm"))))
   (cons '(chibi primitive)
         (make-module #f #f (lambda (env) (primitive-environment 7))))
   (cons '(scheme)
         (make-module #f (interaction-environment) '()))
   (cons '(meta)
         (make-module #f (current-environment) '()))
   (cons '(srfi 0)
         (make-module (list 'cond-expand)
                      (current-environment)
                      (list (list 'export 'cond-expand))))))