(define-module (r6rs-libraries)
  #:export-syntax (library))

(use-modules (ice-9 receive))
(use-modules (srfi srfi-1))

(define-syntax quasisyntax
  (lambda (e)
    
    ;; Expand returns a list of the form
    ;;    [template[t/e, ...] (replacement ...)]
    ;; Here template[t/e ...] denotes the original template
    ;; with unquoted expressions e replaced by fresh
    ;; variables t, followed by the appropriate ellipses
    ;; if e is also spliced.
    ;; The second part of the return value is the list of
    ;; replacements, each of the form (t e) if e is just
    ;; unquoted, or ((t ...) e) if e is also spliced.
    ;; This will be the list of bindings of the resulting
    ;; with-syntax expression.
    
    (define (expand x level)
      (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
        ((quasisyntax e)
         (with-syntax (((k _)     x) ;; original identifier must be copied
                       ((e* reps) (expand (syntax e) (+ level 1))))
           (syntax ((k e*) reps))))                                  
        ((unsyntax e)
         (= level 0)
         (with-syntax (((t) (generate-temporaries '(t))))
           (syntax (t ((t e))))))
        (((unsyntax e ...) . r)
         (= level 0)
         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
                       ((t ...)        (generate-temporaries (syntax (e ...)))))
           (syntax ((t ... . r*)
                    ((t e) ... rep ...)))))
        (((unsyntax-splicing e ...) . r)
         (= level 0)
         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
                       ((t ...)        (generate-temporaries (syntax (e ...)))))
           (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
             (syntax ((t ... ... . r*)
                      (((t ...) e) ... rep ...))))))
        ((k . r)
         (and (> level 0)
              (identifier? (syntax k))
              (or (free-identifier=? (syntax k) (syntax unsyntax))
                  (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
         (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
           (syntax ((k . r*) reps))))
        ((h . t)
         (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
                       ((t* (rep2 ...)) (expand (syntax t) level)))
           (syntax ((h* . t*)
                    (rep1 ... rep2 ...)))))
        (#(e ...)                                                               
         (with-syntax ((((e* ...) reps)
                        (expand (vector->list (syntax #(e ...))) level)))
           (syntax (#(e* ...) reps))))
        (other
         (syntax (other ())))))
    
    (syntax-case e ()
      ((_ template)
       (with-syntax (((template* replacements) (expand (syntax template) 0)))
         (syntax
          (with-syntax replacements (syntax template*))))))))

(define-syntax unsyntax
  (lambda (e)
    (syntax-violation 'unsyntax "Invalid expression" e)))

(define-syntax unsyntax-splicing
  (lambda (e)
    (syntax-violation 'unsyntax "Invalid expression" e)))

(define (flatten-import-spec import-spec phase-map import-map)
  (define (flatten-inner import-set)
    (define (load-library library-ref)
      (let* ((v (car (last-pair library-ref))))
	(if (pair? v)
	    (resolve-interface 
	     (drop-right library-ref 1) #:version v)
	    (resolve-interface library-ref #:version '()))))
    (define (export-eq? x y) 
      (if (list? y) (eq? x (cadr y)) (eq? x y)))
    (if (or (not (list? import-set)))
	(error))
    (case (car import-set)
      ((library) 
       (let ((l (load-library (cadr import-set))))
	 (cons l (module-map (lambda (sym var) sym) l)))) 
      ((only) 
       (let ((l (flatten-inner (cadr import-set))))
	 (cons (car l) (lset-intersection 
			export-eq? (cdr l) (cddr import-set)))))
      ((except) 
       (let ((l (flatten-inner (cadr import-set))))
	 (cons (car l) (lset-difference 
			export-eq? (cdr l) (cddr import-set)))))
      ((prefix) 
       (let ((l (flatten-inner (cadr import-set)))
	     (p (symbol-prefix-proc (caddr import-set))))
	 (cons (car l) 
	       (map (lambda (x)
		      (if (list? x) 
			  (cons (car x) (p (cadr x)))
			  (cons x (p x))))
		    (cdr l)))))
      ((rename) 
       (let ((l (flatten-inner (cadr import-set))))
	 (cons (car l) 
	       (map (lambda (x)
		      (let ((r (find (lambda (y)
				       (eq? (car y) 
					    (if (list? x) 
						(car x) x)))
				     (cddr import-set))))
			(if r (cons (if (list? x) (car x) x) 
				    (cadr x)) x)))
		    (cdr l)))))
      (else (let ((l (load-library import-set)))
	      (cons l (module-map (lambda (sym var) sym) l))))))

  (let* ((phase (and (eq? (car import-spec) 'for)
		     (let ((p (list-ref import-spec 2)))
		       (case p ((run) 0) ((expand) 1) (else (cadr p))))))
	 (unwrapped-import-spec (if phase (cadr import-spec) import-spec))
	 (ilist (flatten-inner unwrapped-import-spec))
	 (public-interface (car ilist))
	 (interface
	  (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))))))
    (for-each (lambda (x) (hashq-set! import-map x #t))
	      (map (lambda (x) (if (pair? x) (cdr x) x)) (cdr ilist)))
    (let* ((phase (or phase 0))
	   (phased-imports (hashv-ref phase-map phase)))
      (if phased-imports
	  (hashv-set! phase-map phase (append phased-imports (list interface)))
	  (hashv-set! phase-map phase (list interface))))))

(define (resolve-export-spec export-specs import-map)
  (define (imported? sym) (hashq-ref import-map (if (pair? sym) (car sym) 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))))

(define-syntax library 
  (lambda (x)
  (syntax-case x (export import)
    ((_ library-name
	(export . export-specs)
	(import . import-specs)
	. library-body)
     (let* ((imports (syntax->datum (syntax import-specs)))
	    (import-map (make-hash-table))
	    (phase-map (make-hash-table))
	    (ln-datum (syntax->datum (syntax library-name)))
	    (version (let ((v (car (last-pair ln-datum)))) (and (list? v) v)))
	    (name (if version (drop-right ln-datum 1) ln-datum))
	    (exports (syntax->datum (syntax export-specs)))
	    (body-exprs (syntax->datum (syntax library-body))))

       (for-each (lambda (x) (flatten-import-spec x phase-map import-map))
		 imports)

       (let ((runtime-imports (hashv-ref phase-map 0))
	     (@@-import '(((guile) #:select (@@ quote)))))
	 (if runtime-imports
	     (hashv-set! phase-map 0 (append runtime-imports @@-import))))

       (receive
	(re-exports exports)
	(resolve-export-spec exports import-map)
	(with-syntax
	 ((name (datum->syntax #'library-name name))	  
	  (all-imports (if (not (null? imports))
			   (datum->syntax 
			    #'import-specs
			    (apply append '()
				   (map (lambda (x) (list #:use-module x))
					(apply append '()
					       (hash-map->list (lambda (k v) v)
							       phase-map)))))
			   '()))
	  (body-exprs (if (not (null? body-exprs))
			  (datum->syntax #'library-body body-exprs)
			  '())))

	 #`(begin
	     (define-module name
	       #,@(if version (list #:version version) '())
	       #:pure
	       #,@(syntax all-imports)
	       #,@(if (not (null? re-exports))
		      (datum->syntax #'export-specs `(#:re-export ,re-exports))
		      '())

	       #,@(if (not (null? exports))
		      (datum->syntax #'export-specs `(#:export ,exports))
		      '()))

	     #,@(syntax body-exprs)))))))))