;;; r6rs-libraries.scm --- Support for R6RS `library' and `import' forms

;;      Copyright (C) 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
^L

(define-module (ice-9 r6rs-libraries)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-11)
  #:export-syntax (library import))

(define (name-and-version lst)
  (let-values (((head tail) (split-at lst (- (length lst) 1))))
    (if (pair? (car tail)) (values head (car tail)) (values lst '()))))
(define srfi-regex (make-regexp "^\\:([0-9]+)$"))

(define* (process-import args #:optional import-map)
  (define (flatten im)
    (define (load-library library-ref)
      (define (transform-library-name name)
	(define (make-srfi m)
	  (cons 'srfi (list (string->symbol 
			     (string-append "srfi-" (match:substring m 1))))))
	(or (and (>= (length name) 2)
		 (eq? (car name) 'srfi)
		 (and=> (regexp-exec srfi-regex (symbol->string (cadr name)))
			make-srfi))
	    name))
      (let-values (((name version) (name-and-version library-ref)))
        (resolve-interface (transform-library-name name) #:version version)))
    (define (exeq? x y) (if (list? y) (eq? x (cadr y)) (eq? x y)))
    (if (or (not (list? im))) (error))
    (let* ((op (car im))
	   (l (case op 
		((only except prefix rename) (flatten (cadr im)))
		((library) (load-library (cadr im)))
		(else (load-library im)))))
      (case op
	((library) (cons l (module-map (lambda (sym var) sym) l)))
	((only) (cons (car l) (lset-intersection exeq? (cdr l) (cddr im))))
	((except) (cons (car l) (lset-difference exeq? (cdr l) (cddr im))))
	((prefix) (let ((p (symbol-prefix-proc (caddr im))))
		    (cons (car l) (map (lambda (x) 
					 (if (list? x) 
					     (cons (car x) (p (cadr x))) 
					     (cons x (p x))))
				       (cdr l)))))
	((rename) (let ((f (lambda (y) 
			     (eq? (car y) (if (list? x) (car x) x)))))
		    (cons (car l) 
			  (map (lambda (x) 
				 (let ((r (find f (cddr im))))
				   (if r (cons (if (list? x) (car x) x) 
					       (cadr x)) x)))
			       (cdr l)))))
	(else (cons l (module-map (lambda (sym var) sym) l))))))
  
  (let* ((unwrapped-import-spec (if (eq? (car args) 'for) (cadr args) args))
	 (ilist (flatten unwrapped-import-spec))
	 (public-interface (car ilist)))
    (if import-map (for-each (lambda (x) (hashq-set! import-map x #t))
			     (map (lambda (x) (if (pair? x) (cdr x) x)) 
				  (cdr ilist))))
    (append (list (module-name public-interface))
	    (if (module-version public-interface)
		(list #:version (module-version public-interface))
		(list))
	    (if (null? (cdr ilist)) '() (list #:select (cdr ilist))))))

(define (process-library args)  
  (define (resolve-export-spec export-specs imports)
    (define (imported? sym) (hashq-ref imports sym))
    (define (flatten-renames export-spec)
      (if (list? export-spec)
	  (map (lambda (x) (cons (car x) (cadr x))) (cdr export-spec))
	  (list export-spec)))
    (partition imported? (apply append (map flatten-renames export-specs))))
  (let ((import-map (make-hash-table)))
    (let-values
     (((library-name version) (name-and-version (car args)))
      ((imports) 
       (apply append (map (lambda (x) 
			    (list #:use-module (process-import x import-map)))
			  (cdaddr args))))
      ((re-exports exports) (resolve-export-spec (cdadr args) import-map)))
     `(define-module ,library-name
        ,@(if (null? version) '() (cons #:version version))
	,@imports
	,@(if (null? exports) '() (list #:export exports))		
	,@(if (null? re-exports) '() (list #:re-export re-exports))))))

(defmacro library args
  (let ((transformed-args (process-library args)))
    `(begin
       ,transformed-args
       ,@(cdddr args))))

(defmacro import args
  (let ((transformed-args (map process-import args)))
    `(use-modules ,@transformed-args)))

;;; r6rs-libraries.scm ends here