(require (lib "list.ss")
(lib "stx.ss" "syntax"))
(define (find-all-renames s)
(cond
[(and (stx-pair? s)
(eq? 'unit/sig (syntax-e (stx-car s))))
(let ([l (stx->list s)])
(if (and l
((length l) . > . 3)
(stx-pair? (cadddr l))
(eq? 'rename (syntax-e (stx-car (cadddr l)))))
(find-all-renames (list-tail l 4))
(find-all-renames (stx-cdr s))))]
[(and (stx-pair? s)
(eq? 'rename (syntax-e (stx-car s))))
(let ([l (or (stx->list (stx-cdr s)) '(#f))])
(if (andmap (lambda (i)
(and (stx-pair? i)
(identifier? (stx-car i))
(stx-pair? (stx-cdr i))
(identifier? (stx-car (stx-cdr i)))
(stx-null? (stx-cdr (stx-cdr i)))))
l)
(list s)
null))]
[(syntax? s) (find-all-renames (syntax-e s))]
[(pair? s) (append
(find-all-renames (car s))
(find-all-renames (cdr s)))]
[else null]))
(define (find-all-uses s ids)
(cond
[(and (identifier? s)
(memq (syntax-e s) ids))
(list s)]
[(syntax? s) (find-all-uses (syntax-e s) ids)]
[(pair? s) (append
(find-all-uses (car s) ids)
(find-all-uses (cdr s) ids))]
[else null]))
(define (fixup f)
(fprintf (current-error-port) "Fixing ~a~n" (if (path? f)
(path->string f)
f))
(let ([s (with-input-from-file f read-syntax)])
(let* ([renames (find-all-renames s)]
[ids (filter
(lambda (sym)
(regexp-match #rx"super-" (symbol->string sym)))
(map syntax-e
(map stx-car
(apply
append
(stx->list (map stx-cdr renames))))))]
[uses (find-all-uses s ids)])
(let ([str (with-input-from-file f (lambda () (read-string (file-size f))))])
(for-each (lambda (use)
(let ([pos (syntax-position use)])
(when pos
(string-set! str (+ (sub1 pos) 5) #\space))))
uses)
(for-each (lambda (rename)
(let ([pos (syntax-position rename)]
[span (syntax-span rename)])
(when (and pos span)
(let ([line-start
(regexp-match-positions
#rx"[\t ]+$"
str
0
(sub1 pos))]
[line-end (regexp-match-positions
#rx"^ *(\r|\n|\r\n)"
str
(+ (sub1 pos) span))])
(set! str
(string-append
(substring str 0 (if line-start
(caar line-start)
(sub1 pos)))
(substring str (if line-end
(cdar line-end)
(+ (sub1 pos) span)))))))))
(reverse renames))
(let ([bak (format "~a.bak" (if (path? f)
(path->string f)
f))])
(unless (file-exists? bak)
(copy-file f bak)))
(with-output-to-file f (lambda ()
(display str))
'truncate)))))
(map fixup (vector->list (current-command-line-arguments)))