#lang racket/base

(require racket/gui/base
         racket/class
         racket/file
         racket/pretty
         srfi/8)

(define (make-status)
  (define frame (new frame% (label "Status") (width 600) (height 60)))
  (define dir-m (new message% (parent frame) (label "...") (stretchable-width #t)))
  (define path-m (new message% (parent frame) (label "...") (stretchable-width #t)))
  (send frame show #t)
  (λ (dir s)
    (send dir-m set-label (path->string dir))
    (send path-m set-label (path->string s))))

(define (undo-scheme-module form)
  (let loop ((form form))
    (let ((datum (syntax-e form)))
      (cond
        ((list? datum)
         (datum->syntax form (map loop datum)))
        ((symbol? datum)
         (let* ((name (symbol->string datum))
                (match (regexp-match #rx"^scheme/(.*)" name)))
           (if (not match)
               form
               (datum->syntax form (string->symbol (string-append "racket/" (cadr match))) form))))
        (else form)))))

(define (write-syntax form)
  (let ((datum (syntax->datum form)))
    (if (list? datum) ; pretty-print adds a ' in front of all lists :/
        (let ((format (pretty-format datum)))
          (if (eq? (string-ref format 0) #\') ; ... or does it? :(
              (write-string (substring format 1))
              (write-string format)))
        (pretty-print datum)))
  (newline))

(define (convert-to-racket)
  (let/ec bail-out
    (let loop ()
      (let ((line (read-line)))
        (when (eof-object? line)
          (bail-out))
        (let ((lang (regexp-match #rx"^#(lang scheme)?(.*)" line)))
          (when lang
            (if (not (cadr lang))
                (begin
                  (write-string line)
                  (newline)
                  (loop))
                (begin
                  (write-string (string-append "#lang racket" (caddr lang)))
                  (newline)(newline)))))))
    (let loop ()
      (let ((form (read-syntax)))
        (when (eof-object? form)
          (bail-out))
        (write-syntax
         (let ((datum (syntax-e form)))
           (if (and (list? datum)
                    (eq? (syntax->datum (car datum)) 'require))
               (datum->syntax form (cons (car datum) (map undo-scheme-module (cdr (syntax-e form)))) form)
               form))))
      (newline)
      (loop))))

(define (with-temp-file head proc)
  (define holder #f)
  (dynamic-wind
   (λ () (set! holder (make-temporary-file "mztmp~a.rkt" #f head)))
   (λ () (proc holder))
   (λ () (when (and holder (file-exists? holder))
           (delete-file holder)))))

(define (run)
  (define status (make-status))
  (fold-files
   (λ (path type result)
     (when (eq? type 'file)
       (receive (head name is-dir?) (split-path path)
         (status head name)
         (when (regexp-match #rx"\\.ss$" (path->string name))
           (let ((dest (path-replace-suffix path ".rkt")))
             (when (not (file-exists? dest))
               (with-temp-file
                head
                (λ (holder)
                  (with-output-to-file holder #:exists 'replace
                    (λ ()
                      (with-input-from-file path
                        (λ ()
                          (convert-to-racket)))))
                  (rename-file-or-directory holder dest)))))))))
   (void)
   "."))

(define (main)
  (yield (thread run))
  (exit))

(provide main)

