;;;; chicken-scheme.scm


(module chicken-scheme ()

(import scheme chicken matchable)
(use files posix ports extras utils regex)


(define-foreign-variable +csc-program+ c-string "C_CSC_PROGRAM")
(define-foreign-variable +csi-program+ c-string "C_CSI_PROGRAM")
(define-foreign-variable +binpath+ c-string "C_INSTALL_BIN_HOME")

(define *debug*
  (get-environment-variable "CHICKEN_SCHEME_DEBUG") )

(define *chicken-scheme-hook* 
  (and (not *debug*)
       (get-environment-variable "CHICKEN_SCHEME_HOOK") ))

(define *cache* 
  (make-pathname 
   (or (get-environment-variable "HOME") "/")
   ".chicken-scheme.cache") )

(define *options* 
  (or (get-environment-variable "CHICKEN_SCHEME_OPTIONS")
      (if *debug* "-v2" "-O2")) )

(define *csc* (make-pathname +binpath+ +csc-program+))
(define *csi* (make-pathname +binpath+ +csi-program+))

(define *exe* 
  (and (eq? 'windows (software-type))
       (not (eq? 'cygwin (build-platform)))
      "exe"))

(define +md5sum-regex+
  (regexp '(: bos (* space) (submatch (+ xdigit)) (* space))))

(define (usage code)
  (print "usage: chicken-scheme [-help] [-purge] [-list] [FILENAME ARGUMENT ...]")
  (exit code) )

(define (purge)
  (when *debug*
    (print "purging " *cache* " ..."))
  (when (directory-exists? *cache*)
    (for-each 
     (lambda (f) (delete-file* (make-pathname *cache* f))) 
     (directory *cache*))) )

(define (md5sum filename)
  (let ((qsource (qs (normalize-pathname filename))))
    (case (software-version)
      ((macosx) 
       (with-input-from-pipe (sprintf "md5 -q ~a" qsource) read-line) )
      (else
       (with-input-from-pipe 
	(sprintf "md5sum ~a" qsource)
	(lambda () (cadr (string-search +md5sum-regex+ (read-line)))))))))

(define (run fail fstr . args)
  (let ((cmd (apply sprintf fstr args)))
    (when *debug* (print "  " cmd))
    (let ((r (system cmd)))
      (cond ((zero? r))
	    (else
	     (when fail (fail))
	     (fprintf 
	      (current-error-port) 
	      "command failed with non-zero exit status ~a:~%~%  ~a~%" r cmd)
	     (exit 1))))) )

(define (compile-and-run prg args)
  (unless (directory-exists? *cache*)
    (when *debug* 
      (print "creating " *cache*) )
    (create-directory *cache*) )
  (let* ((hash (md5sum prg))
	 (cached (normalize-pathname (make-pathname *cache* hash *exe*))))
    (when (or (not (file-exists? cached))
	      (> (file-modification-time prg)
		 (file-modification-time cached) ) )
      (let* ((qcached (qs cached))
	    (qprg (qs prg))
	    (errfile (normalize-pathname (create-temporary-file "tmp")))
	    (qerrfile (qs errfile)))
	(when *chicken-scheme-hook*
	  (run #f "~a start ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
	(run (lambda ()
	       (if *chicken-scheme-hook*
		   (run #f "~a fail ~a ~a" *chicken-scheme-hook* qprg qerrfile)
		   (display (read-all errfile)) ) )
	     "~a ~a ~a -o ~a ~a"
	     *csc* *options* qprg qcached
	     (if *debug* "" (string-append "> " qerrfile)))
	(when *chicken-scheme-hook*
	  (run #f "~a end ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
	(delete-file errfile) ) )
    (process-execute cached args) ) )

(define (main args)
  (match args
    (()
     (process-execute *csi*) )
    (((or "-h" "-help" "--help") . _)
     (usage 0) )
    (("-purge")
     (purge) )
    (("-list")
     (for-each print (directory *cache*)))
    ((filename args ...)
     (compile-and-run filename args) )
    (_ (usage 1))))

(main (command-line-arguments))

)