On 06/10/2010 09:34 PM, Stephen Chang wrote:
> This doesn't seem to do the replacement when the language is just #lang
> scheme.
Oh, yeah it wouldn't. Well it's an easy fix. But seriously, don't use
this on anything you care about. As I said it deletes line-based
comments. It also reformats the whitespace, though that's less of a
concern thanks to racket/pretty. I only wrote this because I don't know
of any other automated tool in progress, and I hope someone else can
benefit from my errors, when they later actually make something that works.
The way I read #lang is wrong of course, but (read-language) is another
one of those crazy procedures I don't understand either. Somehow it
magically pulls a procedure named "get-info" from some global context I
don't know, which it then calls to get a procedure that you call to get
information about the syntax. None of which will tell you what's
supposed to go after "#lang" when writing the .rkt file.
#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)
_________________________________________________
For list-related administrative tasks:
http://lists.racket-lang.org/listinfo/users
