#!/usr/bin/gsc-script -i
; vim: syntax=scheme

(r6rs)
;prefix is just the directory it's under. 
(define gambit-libraries-prefix "gambit")
(define srfi-libraries-prefix "srfi")
(define standard-libraries-prefix "rnrs")
(define misc-libraries-prefix "")
(define standard-library-name "r6rs-stdlib")
(define result-path "~/.r6gambit/lib/")

(define (debug arg) (pp arg) arg)

(define (display* . args)
  (for-each (lambda (x) (display x)) args)
  (newline))

(define (path-expand* dir . files)
   (map (lambda (x) (path-expand x dir)) files))


(define gambit-libraries 
   (path-expand* "libs/gambit/" "continuations.scm" "records.scm" "io.readtable.scm" "system.scm" "io.scm" "threads.scm" "time.scm" "hashing.scm" "will.scm" "table.scm" "exceptions.scm" "files.scm" "programs.scm" "extensions.scm" "bytevectors.scm" "debug.scm" "vectors.scm" "strings.scm" "ffi.scm"))

(define srfi-libraries
     (path-expand* "libs/srfi/" "srfi-0.scm" "srfi-2.scm" "srfi-21.scm" "srfi-18.scm" "srfi-23.scm" "srfi-26.scm" "srfi-27.scm" "srfi-39.scm" "srfi-4.scm" "srfi-6.scm" "srfi-66.scm" "srfi-69.scm" "srfi-8.scm" "srfi-88.scm" "srfi-89.scm" "srfi-99.scm" "srfi-9.scm" "srfi-14.scm" "srfi-13.scm"))

(define standard-libraries0 
  (path-expand* "libs/rnrs/" "conditions.scm" "exceptions.scm" "base.scm" "syntax-case.scm" "control.scm" "lists.scm" "eval.scm" "records.scm" "hashtables.scm" "enumerations.scm" "arithmetic.scm" "r5rs.scm" "mutable.scm"))
 
(define standard-libraries 
  (path-expand* "libs/rnrs/" "io.scm" "files.scm" "sorting.scm" "programs.scm" "rnrs.scm" "load.scm"))

(define bytevector-libraries
   (path-expand* "libs/rnrs/bytevectors" "bytevector-core.scm" "bytevector-proto.scm" "bytevector-ieee.scm" "bytevector-string.scm" "bytevector.scm"))
	
(define unicode-libraries
  (path-expand* "libs/rnrs/unicode/" "unicode0.scm" "unicode1.scm" "unicode2.scm" "unicode3.scm" "unicode4.scm" "unicode.scm"))

(define misc-libraries (path-expand* "libs/" "ieee.scm" "renaming.scm"))

(define (generate-catalog files)
   (define (name&version name)
	 (cond
	  ((and (symbol? (car name)) (pair? (cdr name)))
	   (call-with-values 
	    (lambda () (name&version (cdr name)))
	    (lambda (n v) (values (cons (car name) n) v))))
	  ((and (symbol? (car name)) (null? (cdr name))) (values name '()))
	  ((pair? (car name)) (values '() (car name)))))
   
   (define (libraries file)
	(reverse (with-input-from-file file (lambda ()
	    (let loop ((form (read))
		       (result '()))
		(cond
		   ((eq? #!eof form) result)
		   ((eq? 'library (car form)) (loop (read) (cons form result)))
		   (else (loop (read) result))))))))
			
   (define (process-file file)
	(define libs (libraries file))
	(define uri (make-uri 'file (path-expand file (current-directory)) #f #f))
	(define (make-catalog-library library-form multi?)
	   (call-with-values (lambda () (name&version (cadr library-form)))
		(lambda (name version)
			`(library ,name (versions (,version ,(uri->string (if multi? (make-uri (uri-scheme uri) (uri-body uri) #f (number->string multi?)) uri))))))))
  
	(if (and (pair? libs) (null? (cdr libs))) (list (make-catalog-library (car libs) #f))
	   (reverse (let loop ((libs libs)
		      (count 0)
		      (result '()))
		(if (null? libs) result
		   (loop (cdr libs) (+ 1 count) (cons (make-catalog-library (car libs) count) result)))))))
		
   `(catalog ,@(apply append (map process-file files))))
   

  

(display* "compiling libraries")
    (call-with-output-file "~/.r6gambit/catalog.scat" (lambda (port)
	(define bin (let ((result-path (path-expand result-path)))
		(if (not (file-exists? result-path)) (create-directory result-path))
		(make-uri 'file result-path))) 
	(define libraries (append gambit-libraries standard-libraries0 bytevector-libraries unicode-libraries standard-libraries srfi-libraries misc-libraries))
	(pretty-print (r6rs#compile-catalog (make-uri 'file (current-directory)) (generate-catalog libraries) bin options: '(debug)) port)))


(display* "done")