;;; r6rs-libraries.scm --- Support for R6RS libraries

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

;;; Author: Julian Graham <address@hidden>
;;; Date: 2009-03-05

;;; Commentary:

(define-module (ice-9 r6rs-libraries)
  :use-module (ice-9 optargs)
  :use-module (ice-9 receive)
  :use-module (ice-9 syncase)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-2)
  :use-module (srfi srfi-9)
  :use-module (srfi srfi-11)

  :export (import 
	   register-library
	   register-from-path))

(define (library-name library) (list-ref library 1))
(define (library-exports library) (cdr (list-ref library 2)))
(define (library-imports library) (cdr (list-ref library 3)))
(define (library-body library) (cddddr library))

(define library-registry (make-hash-table))
(define interface-registry (make-hash-table))

(define-record-type r6rs-library-type
  (make-r6rs-library name)
  r6rs-library?
  (name r6rs-library-name)
  (exports r6rs-library-exports set-r6rs-library-exports!)
  (module r6rs-library-module set-r6rs-library-module!)
  (interface r6rs-library-interface set-r6rs-library-interface!)
  (parent r6rs-library-parent set-r6rs-library-parent!))

(define* (create-empty-module #:optional name)
  (define module (make-module))
  (set-module-name! module (or name (list (gensym))))
  (let ((interface (make-module)))
    (set-module-name! interface (module-name module))
    (set-module-kind! interface 'interface)
    (set-module-public-interface! module interface))
  module)

(define* (create-module-interface module exports #:optional name)
  (let ((i (make-module)))
    (set-module-name! i (or name (list (gensym))))
    (set-module-kind! i 'custom-interface)
    (for-each 
     (lambda (import)
       (if (pair? import)
	   (module-add! i (cadr import) (module-variable module (car import)))
	   (module-add! i import (module-variable module import))))
     exports)
    i))

(define* (create-library-interface lib exports #:optional name)
  (let* ((name (or name (list (gensym))))
	 (l (make-r6rs-library name)))
    (set-r6rs-library-interface! 
     l (create-module-interface (r6rs-library-interface lib) exports name))
    (set-r6rs-library-exports! 
     l (map (lambda (x) (if (pair? x) (cadr x) x)) exports))
    (set-r6rs-library-parent! l lib)
    l))

(define (instantiate-library lib-expr)
  (define name (library-name lib-expr))
  (define imports (library-imports lib-expr))
  (define exports 
    (fold (lambda (x lst) (append lst (if (pair? x) (cdr x) (list x))))
	  '()
	  (library-exports lib-expr)))

  (define library (make-r6rs-library (library-name lib-expr)))
  (define module (create-empty-module))

  (define (binding-name binding) (if (list? binding) (car binding) binding))

  (define local-definitions (list 'exports))

  (define phase-library-cache (make-hash-table))
  (define (inject-bindings-for-phase! m phase)
    (and=> (hashv-ref phase-library-cache phase)
	   (lambda (ifaces) (for-each (lambda (i) (module-use! m i))
				      (map r6rs-library-interface ifaces)))))

  (define (expand expr m p)
    (if (pair? expr)
	(let ((ce (car expr)))
	  (cond ((eq? ce 'define) 
		 (eval (cons* ce (cadr expr) (expand (cddr expr) m p)) m))
		((eq? ce 'define-syntax)
		 (let ((m+ (create-empty-module))
		       (p (+ p 1)))
		   (inject-bindings-for-phase! m+ p)
		   (let ((rhs (eval (expand (caddr expr) m+ p) m+)))
		     (let ((e `(define-syntax ,(cadr expr) ,rhs)))
		       (eval e m)))))
		(else (map (lambda (x) (expand x m p)) expr))))
	expr))
    
  (define (hashv-append! h k v)
    (or (and=> (hashv-ref h k) (lambda (ov) (hashv-set! h k (append ov `(,v)))))
	(hashv-set! h k `(,v))))

  (for-each 
   (lambda (import) 
     (let* ((import-set (if (eq? (car import) 'for) (cadr import) import))
	    (interface (import-library import-set)))
       (if (equal? (r6rs-library-name interface) '(rnrs (6)))
	   (begin (hashv-append! phase-library-cache 0 interface)
		  (hashv-append! phase-library-cache 1 interface)))
       (if (eq? (car import) 'for)
	   (for-each
	    (lambda (phase)
	      (cond ((eq? phase 'run)
		     (hashv-append! phase-library-cache 0 interface))
		    ((eq? phase 'expand)
		     (hashv-append! phase-library-cache 1 interface))
		    ((and (list? phase) (eq? (car phase 'meta)))
		     (hashv-append! phase-library-cache (cadr phase) interface))
		    (else (error "Invalid import level specification"))))
	    (cddr import))
	   (hashv-append! phase-library-cache 0 interface))))
   imports)

  (inject-bindings-for-phase! module 0)
  (for-each (lambda (expr)
	      (if (and (list? expr) (memq (car expr) '(define define-syntax)))
		  (begin (expand expr module 0)
			 (append! local-definitions 
				  (list (binding-name (cadr expr)))))
		  (eval expr module)))
	    (library-body lib-expr))

  (let ((locals (cdr local-definitions)))
    (receive 
      (export-vars export-names)
      (let f ((vars (list)) (names (list)) (lst exports))
	(cond ((null? lst) (values vars names))
	      ((pair? (car lst))
	       (f (cons (caar lst) vars) (cons (cadar lst) names) (cdr lst)))
	      (else (f (cons (car lst) vars)
		       (cons (car lst) names)
		       (cdr lst)))))
      (if (not (null? locals))
	  (module-export! module locals))
      (module-re-export! module (lset-difference eq? export-vars locals))
      (let ((module-interface (create-module-interface module exports name)))
	(set-module-public-interface! module module-interface)
	(set-r6rs-library-module! library module)
	(set-r6rs-library-interface! library module-interface)
	(set-r6rs-library-exports! library export-names))))
  (hash-set! interface-registry name library))

(define (version-matches? version-ref target)
  (define (sub-versions-match? v-refs t)
    (define (sub-version-matches? v-ref t)
      (define (curried-sub-version-matches? v) (sub-version-matches? v t))
      (cond ((number? v-ref) (eqv? v-ref t))
	    ((list? v-ref)
	     (let ((cv (car v-ref)))
	       (cond ((eq? cv '>=) (>= t (cadr v-ref)))
		     ((eq? cv '<=) (<= t (cadr v-ref)))
		     ((eq? cv 'and) 
		      (every curried-sub-version-matches? (cdr v-ref)))
		     ((eq? cv 'or)
		      (any curried-sub-version-matches? (cdr v-ref)))
		     ((eq? cv 'not) (not (sub-version-matches? (cadr v-ref) t)))
		     (else (error "Incompatible sub-version reference" cv)))))
	    (else (error "Incompatible sub-version reference" v-ref))))
    (or (null? v-refs)
	(and (not (null? t))
	     (sub-version-matches? (car v-refs) (car t))
	     (sub-versions-match? (cdr v-refs) (cdr t)))))
  (define (curried-version-matches? v) (version-matches? v target))
  (or (null? version-ref)
      (let ((cv (car version-ref)))
	(cond ((eq? cv 'and) (every curried-version-matches? (cdr version-ref)))
	      ((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
	      ((eq? cv 'not) (not version-matches? (cadr version-ref) target))
	      (else (sub-versions-match? version-ref target))))))

(define (import-library import-spec)
  (define (wrap-guile-module module)
    (let ((li (make-r6rs-library (module-name module))))
      (set-r6rs-library-module! li module)
      (set-r6rs-library-interface! li module)
      (set-r6rs-library-exports! 
       li (hash-map->list (lambda (x y) x) (module-obarray module)))
      li))

  (define (locate-library library-reference)
    (receive
      (name version)
      (partition symbol? library-reference)
      (let ((interface (false-if-exception (resolve-interface name))))
	(or (hash-ref interface-registry library-reference)
	    (and-let* ((version-table (hash-ref library-registry name))
		       (cversion (if (null? version) version (car version))))
	      (or (and=> (assoc cversion version-table version-matches?)
			 (lambda (x) (instantiate-library (cdr x))))
		  (error "No version of library found to match version-ref"
			 name
			 cversion
			 version-table)))
            (and interface (hash-set! interface-registry 
				      library-reference 
				      (wrap-guile-module interface)))
	    (error "Unable to resolve interface for library" 
		   library-reference)))))

  (define (resolve-library-interface import)
    (let ((ci (car import)))
      (cond 
       ((eq? ci 'library) (locate-library (cadr import)))
       ((or (eq? ci 'only) (eq? ci 'rename))
	(create-library-interface (resolve-library-interface (cadr import))
				  (cddr import)))
       ((eq? ci 'except) 
	(let ((i (resolve-library-interface (cadr import))))
	  (create-library-interface 
	   i (lset-difference eq? (r6rs-library-exports i) (cddr import)))))
       ((eq? ci 'prefix)
	(let* ((i (resolve-library-interface (cadr import)))
	       (prefix-str (symbol->string (caddr import))))
	  (create-library-interface
	   i (map (lambda (x) 
		    (cons x (list (string->symbol 
				   (string-append prefix-str 
						  (symbol->string x))))))
		  (r6rs-library-exports i)))))
       (else (locate-library import)))))
  (resolve-library-interface import-spec))

(define (import import-spec)
  (let ((lib (import-library import-spec)))
    (or lib (error "Unable to import library for import spec " import-spec))
    (module-use! (current-module) (r6rs-library-interface lib))))

(define (register-library library-expr)
  (define (version-less? x y)
    (cond ((null? x) #f)
	  ((null? y) #t)
	  (else (let ((cx (car x))
		      (cy (car y)))
		  (cond ((< cx cy) #t)
			((> cx cy) #f)
			(else (version-less? (cdr x) (cdr y))))))))
  (receive 
    (name version)
    (partition symbol? (library-name library-expr))
    (let ((cversion (if (null? version) version (car version))))
      (or (and=> (hash-ref library-registry name)
		 (lambda (version-table)
		   (merge! version-table 
			   `(,(cons cversion library-expr))
			   version-less?)))
	  (hash-set! library-registry name `(,(cons cversion library-expr)))))))

(define (register-from-path filename)
  (define (quoting-read port)
    (let ((library-expr (read port)))
      (if (eof-object? library-expr)
	  library-expr
	  (begin (register-library library-expr) *unspecified*))))
  (with-fluids ((current-reader quoting-read)) (load-from-path filename)))