And now I noticed that my hackish '|'| eliminator sometimes eliminates
the first ( because there is no ' on the expression for reasons I don't
understand. So I made a work around! :D
Someone who actually knows this stuff I'd really appreciate seeing
something like this. ^.^; Not so much to attempt a mass automatic
conversion, but just so I can understand how such things are done.
#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)
_________________________________________________
For list-related administrative tasks:
http://lists.racket-lang.org/listinfo/users
