#lang scheme/base
(require "file.ss" 
         "port.ss")
(provide compile-file)

(define compile-file
  (case-lambda
    [(src)
     (let-values ([(base name _) (split-path src)])
       (let ([cdir (build-path
                    (if (symbol? base)
                        'same
                        base)
                    "compiled")])
         (make-directory* cdir)
         (compile-file src (build-path cdir (path-add-suffix name #".zo")))))]
    [(src dest) (compile-file src dest values)]
    [(src dest filter)
     (let ([in (open-input-file src)])
       (dynamic-wind
        void
        (lambda ()
          (port-count-lines! in)
          (let ([dir (let-values ([(base name dir?) (split-path src)])
                       (if (eq? base 'relative)
                           (current-directory)
                           (path->complete-path base (current-directory))))])
            (let ([temp-filename (make-temporary-file "tmp~a" #f dir)])
              (with-handlers ([void
                               (lambda (exn)
                                 (with-handlers ([void void])
                                   (delete-file temp-filename))
                                 (raise exn))])
                (let ([out (open-output-file temp-filename #:exists 'truncate/replace)]
                      [ok? #f])
                  (parameterize ([current-load-relative-directory dir]
                                 [current-write-relative-directory dir])
                    (dynamic-wind
                     void
                     (lambda ()
                       (let loop ()
                         (let ([r (read-syntax src in)])
                           (unless (eof-object? r)
                             (write (compile-syntax (filter (namespace-syntax-introduce r))) out)
                             (loop))))
                       (set! ok? #t))
                     (lambda () 
                       (close-output-port out)
                       (if ok?
                           (rename-file-or-directory temp-filename dest)
                           (with-handlers ([void void])
                             (delete-file temp-filename)))))))))))
        (lambda () (close-input-port in))))
     dest]))