;;; To compile .java files you need:

;;; src-base the root directory of your .java sources.
;;; class-base the root directory where you want .class files to go.

;;; (compile-class class-base src-base "package.Class") - compile's a class.

;;; (recompile class-base src-base package recurse?) - recompile all
;;; the files in a package, decending into subpackages if recurse? is true.

;;; There are also (javac), (jar), and (rmic).
;;; See build/update.scm for example usage.

(import "java.io.File")
(import "java.io.FileInputStream")
(import "java.io.FileOutputStream")
(import "java.lang.Double")
(import "java.lang.String")
(import "java.lang.System")
(import "java.net.URL")
(import "java.net.URLConnection")
' (import "silk.SchemeClassLoader")

;;; String cracking and construction.  
;;; KRA 02SEP99: Probably better to use StringBuffers.
(define (dot? x) (eqv? x #\.))
(define (file-separator? x) (or (eqv? x #\/) (eqv? x #\\)))

(define (string-position string start end p?)
  (if (< start end)
      (if (p? (string-ref string start)) start
	  (string-position string (+ start 1) end p?))
      -1))

(define (crack separator string)
  ;; (crack dot? "foo.bar.baz") -> (foo bar baz)
  (define (crack0 separator string start end so-far)
    (if (>= start end) (reverse so-far)
	(let ((pos (string-position string start (string-length string) 
				    separator)))
	  (if (= pos -1) (reverse (cons (substring# string start end) 
				       so-far))
	      (crack0 separator string (+ pos 1) end 
		      (cons (substring# string start pos) so-far))))))
  (crack0 separator string 0 (length# string) '()))

(define file-separator (System.getProperty "file.separator"))

(define (separate by items)
  ;; (separate "," '(1 2 3)) -> (1 "," 2 "," 3)
  (define (separate0 head tail)
    (if (null? tail) (list head)
	(cons head (cons by (separate0 (car tail) (cdr tail))))))
  (if (null? items) items
      (separate0 (car items) (cdr items))))

(define (class->file name)
  ;; (class->file "foo.bar.baz") -> "foo/bar/baz.java".
  (apply string-append
	 (append (separate file-separator
			   (crack dot? name))
		 (list ".java"))))

(define (package->file base package)
  (set! *base* base)
  (set! *package* package)
  (string-append (File base (apply string-append (separate file-separator (crack dot? package))))))

(define (file->class name)
  ;; (file->class "foo\\bar.java") -> "foo.bar"
  (or (and (endsWith name ".java")
	   (apply string-append
		  (separate "."
			    (crack file-separator?
				   (substring name 0 
					      (- (string-length name) 
						 (string-length ".java")))))))
      (error name "doesn't end with \".java\"")))

(define javac
  (let ((Main (constructor "sun.tools.javac.Main" "java.io.OutputStream" "java.lang.String"))
	(compile (method "compile" "sun.tools.javac.Main" "java.lang.String[]")))
    (lambda args
      (compile (Main System.out 'silk-javac)
	       (apply java-vector String.class args)))))

(define (remote? c)
  ;; is c a class that needs to be rmic'd?
  ;; It is if it or one of its interfaces is java.rmi.Remote.
  (define (any p xs)
    ;; Does any element of xs satisfy (p x)?
    (and (not (null? xs)) (or (p (car xs)) (any p (cdr xs)))))
  (define (remote0? c)
    (or (eq? c (class "java.rmi.Remote"))
	(any remote0? (vector->list (getInterfaces c)))))
  (and (not (isInterface c)) (remote0? c)))

(define (compile-class class-base src-base name)
  (and (compile-file class-base src-base (class->file name))
       (let ((c (class name)))
	 ;; Sometimes a java file can have the wrong package defined
	 (if (not c) (print (list "Can't find class" name)))
	 (if (and c (remote? c))
	     (begin
	       (display "rmicing ") (display name) (newline)
	       (rmic "-classpath" (System.getProperty "java.class.path")
		     "-d" class-base
		     "-sourcepath" src-base
		     name))
	     #t))))

(define (compile-file class-base src-base file)
  ;; Compile the *.java file, file using the current CLASSPATH.
  (let* ((separator (System.getProperty "path.separator")))
    (javac
     "-g" "-deprecation" "-classpath"
     (string-append (System.getProperty "java.class.path") separator
		    class-base)
     "-d" class-base
     "-sourcepath" src-base
     (toString (make-src-file src-base file)))))

(define jar
  (let ((Main (constructor "sun.tools.jar.Main" "java.io.PrintStream"
			   "java.io.PrintStream" "java.lang.String"))
	(run (method "run" "sun.tools.jar.Main" "java.lang.String[]")))
    (lambda args
      (run (Main System.out System.err "silk-jar")
	   (apply java-vector String.class args)))))

(define rmic
  (let ((Main (constructor "sun.rmi.rmic.Main" "java.io.OutputStream"
			   "java.lang.String"))
	(compile (method "compile" "sun.rmi.rmic.Main" "java.lang.String[]")))
    (lambda args
      (compile (Main System.out "silk-rmic")
	       (apply java-vector String.class args)))))

(define (file->package base file)
  (apply string-append
	 (separate
	  "."
	  (crack file-separator?
		 (symbol->string
		  (substring# (symbol->string (toString file))
			      (string-length (symbol->string (toString base)))))))))

(define (relativize-file base file)
  ;; (relativize-file "/frog/prince/ "/frog/prince/bar.java")
  ;; -> bar.java.
  (let* ((string (symbol->string (toString base)))
	 (L (string-length string))
	 (c (string-ref string (- L 1))))
    (File (substring# (symbol->string (toString file))
		      (if (file-separator? c) L (+ L 1))))))

(define (make-class-file class-base java-file)
  (let ((name (symbol->string (getName java-file))))
    (File  class-base 
	   (string-append
	    (getParent java-file)
	    File.separator 
	    (substring name 0 (- (string-length name) 
				 (string-length ".java")))
	    ".class"))))

(define (make-src-file src-base java-file)
  (File src-base (toString java-file)))


(define (last-modified file)
  ;; KRA 05AUG99: We need this kludge because SILK does not deal with Longs.
  (Double (toString (lastModified file))))

(define (needs-recompile class-file java-file)
  (if (not (exists java-file)) (error java-file " does not exist!"))
  (or (not (exists class-file))
      (> (last-modified java-file) (last-modified class-file))))

(define-method file-type? ((file java.io.File) suffix)
  (endsWith (getName file) suffix))

(define-method file-type? ((file java.lang.String) suffix)
  (endsWith file suffix))

(define (java-file? file) (file-type? file ".java"))
(define (class-file? file) (file-type? file ".class"))

(define (file-walk file how so-far)
  (if (isDirectory file)
      (foldL (lambda (f so-far) (file-walk f how so-far))
	     (how file so-far)
	     (listFiles file))
      (how file so-far)))

(define (collect-files file test)
  (file-walk file 
	     (lambda (f so-far) (if (test f) (cons f so-far) so-far))
	     '()))


(define-method delete-class-files ((directory java.lang.String))
  (delete-class-files (File directory)))

(define-method delete-class-files ((directory java.io.File))
  (file-walk directory 
	     (lambda (f result) (if (class-file? f) (delete f)))
	     ()))

(define (recompile class-base src-base package recurse?)
  ;; Recompile an entire package, and subpackages if recurse? is #t.
  (display "Recompiling package ") (display package)
  (if recurse? (display " recursively"))
  (newline)
  ;; Make the class directory if necessary.
  (mkdirs (File (package->file class-base package)))
  (let ((directory (File (package->file src-base package))))
    (recompile-files class-base src-base (java-files directory))
       (if recurse?
	   (map* (lambda (f)
		   (recompile class-base src-base 
			      (file->package src-base f)
			      recurse?))
		 (directories directory)))))

(define (recompile-files class-base src-base jfs)
  (if (null? jfs) #t
      (let* ((it (relativize-file src-base (first jfs)))
	     (jfs (cdr jfs))
	     (java-file (make-src-file src-base it))
	     (bin-file (make-class-file class-base it)))
	;; A *.java file needs to be recompiled if it is younger than
	;; its *.class file or if it's class is (remote?) so rmic can be
	;; run.  

	;; +++ We could test if the stub and skeleton files are upto
	;; date.
	(if (or (needs-recompile bin-file java-file)
		(let ((c (class (file->class (symbol->string (toString it))))))
		  (and c (remote? c))))
	    (begin
	      (display "Compiling ")
	      (display java-file) (newline)
	      (compile-class class-base src-base 
			     (file->class (symbol->string (toString it))))))
	(recompile-files class-base src-base jfs))))

(define (directories directory) (filter-in isDirectory (listFiles directory)))

(define (java-files directory) (filter-in java-file? (listFiles directory)))

(define (recompile-class class-base src-base name)
  (let* ((it (File (class->file name)))
	 (java-file (make-src-file src-base it))
	 (bin-file (make-class-file class-base it)))
    ;; A *.java file needs to be recompiled if it is younger than
    ;; its *.class file or if it's class is (remote?) so rmic can be
    ;; run.  

    ;; +++ We could test if the stub and skeleton files are upto
    ;; date.
    (if (or (needs-recompile bin-file java-file)
	    (let ((c (class name)))
	      (and c (remote? c))))
	(begin
	  (display "Compiling ")
	  (display java-file) (newline)
	  (compile-class class-base src-base 
			 (file->class (symbol->string (toString it))))))
    bin-file))

;;; KRA 23SEP99: The prototype of build.CompilingClassLoader.
'(define (compilingClassLoader class-base src-base parent)
  (SchemeClassLoader
   parent
   (lambda (name)
     (SchemeClassLoader.toBytes
      (recompile-class class-base
		       src-base
		       (symbol->string (toString name)))))))

(define-method copyBytes ((in java.lang.Object) (out java.lang.Object))
  ;; Provide default N = 1001.
  (copyBytes in out 1001))

(define-method copyBytes ((in java.io.InputStream) 
			  (out java.io.OutputStream) 
			  N)
  (let ((bs (make-java-vector (class "byte") N)))
    (let loop ((i (read# in bs 0 N)))
      (if (not (= i -1))
	  (begin
	    (write# out bs 0 i)
	    (loop (read# in bs 0 N)))))))

(define-method copyBytes ((in java.io.File) (out java.io.File) N)
  (copyBytes (FileInputStream in) (FileOutputStream out) N))

(define (do-files from-directory to-directory predicate act)
  (assert (and (isDirectory from-directory) (isDirectory to-directory)))
  (file-walk from-directory
	     (lambda (f so-far) 
	       (if (predicate f) 
		   (act f (swing-file from-directory to-directory f))))
	     '()))

(define (swing-file from to file)
  (let ((sfile (toString file))
	(sfrom (toString from)))
    (assert (= (indexOf sfile sfrom) 0))
       (let ((relative (substring# sfile (+ (length# sfrom) 1))))
	 (File to relative))))
  
(define (copy-files from to predicate)
  (assert (not (eq? from to)))
  (mkdirs to)
  (do-files from to predicate 
	    (lambda (f1 f2)
	      ;; (print `(copy ,f1 ,f2))
	      (mkdirs (getParentFile f2))
	      (copyBytes f1 f2))))