#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 :/ (write-string (substring (pretty-format datum) 1)) (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)