345 lines
9.9 KiB
Scheme
345 lines
9.9 KiB
Scheme
|
|
(module helpers mzscheme
|
|
(require (lib "list.ss")
|
|
"uri.ss")
|
|
(require-for-template mzscheme)
|
|
|
|
(provide translate-import
|
|
translate-export
|
|
uri?)
|
|
|
|
(define (uri? s)
|
|
;; Need a proper test here!
|
|
#t)
|
|
|
|
(define ((check-identifier stx) id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
stx
|
|
id)))
|
|
|
|
(define (check-present orig-i what nested !not exceptions names)
|
|
(for-each (lambda (en)
|
|
(unless (!not (ormap (lambda (i) (bound-identifier=? (car en) i))
|
|
names))
|
|
(raise-syntax-error
|
|
#f
|
|
(format "~a in nested ~a" what nested)
|
|
orig-i
|
|
(car en))))
|
|
exceptions))
|
|
|
|
(define (add-prefix prefix id)
|
|
(if prefix
|
|
(datum->syntax-object id
|
|
(string->symbol
|
|
(format "~a~a" (syntax-e prefix) (syntax-e id)))
|
|
id)
|
|
id))
|
|
|
|
(define (locate-rename id renames)
|
|
(cond
|
|
[(null? renames) #f]
|
|
[(bound-identifier=? id (caar renames)) (cdar renames)]
|
|
[else (locate-rename id (cdr renames))]))
|
|
|
|
(define (apply-rename new-names old-names name-pairs)
|
|
(map (lambda (i)
|
|
(or (ormap (lambda (new old)
|
|
(and (bound-identifier=? (car i) new)
|
|
(cons old (cdr i))))
|
|
new-names old-names)
|
|
i))
|
|
name-pairs))
|
|
|
|
(define (remove-all-prefixes orig-i name-pairs form prefix)
|
|
(let ([s (symbol->string (syntax-e prefix))])
|
|
(map (lambda (i)
|
|
(let ([old (symbol->string (syntax-e (car i)))])
|
|
(unless (and ((string-length old) . >= . (string-length s))
|
|
(string=? s (substring old 0 (string-length s))))
|
|
(raise-syntax-error
|
|
#f
|
|
(format "~a does not have prefix ~s added by nested `prefix' form"
|
|
form
|
|
s)
|
|
orig-i
|
|
(car i)))
|
|
(cons (datum->syntax-object (car i)
|
|
(string->symbol (substring old (string-length s)))
|
|
(car i))
|
|
(cdr i))))
|
|
name-pairs)))
|
|
|
|
(define (check-unique-names orig-i what names)
|
|
(let ([dup (check-duplicate-identifier names)])
|
|
(when dup
|
|
(raise-syntax-error
|
|
#f
|
|
(format "duplicate ~a identifier" what)
|
|
orig-i
|
|
dup))))
|
|
|
|
(define (localize i stx)
|
|
(datum->syntax-object i (syntax-e stx)))
|
|
|
|
(define (translate-import i)
|
|
(define orig-i #`(import #,i))
|
|
(syntax-case* i (for run expand) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
|
[(for sub run expand)
|
|
(finish-translate-import orig-i #'sub #t #t)]
|
|
[(for sub expand run)
|
|
(finish-translate-import orig-i #'sub #t #t)]
|
|
[(for sub run)
|
|
(finish-translate-import orig-i #'sub #t #f)]
|
|
[(for sub expand)
|
|
(finish-translate-import orig-i #'sub #f #t)]
|
|
[(for . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad `for' form"
|
|
orig-i
|
|
i)]
|
|
[_else
|
|
(finish-translate-import orig-i i #t #f)]))
|
|
|
|
(define (finish-translate-import orig-i i run? expand?)
|
|
(define (mk-require l)
|
|
(cond
|
|
[(and run? expand?)
|
|
#`(begin (require #,@l) (require-for-syntax #,@l))]
|
|
[run?
|
|
#`(require #,@l)]
|
|
[expand?
|
|
#`(require-for-syntax #,@l)]))
|
|
(translate-impexp
|
|
i orig-i
|
|
(lambda (i exceptions onlys renames extra-prefix)
|
|
;; Found a base URI?
|
|
(unless (and (string? (syntax-e i))
|
|
(uri? (syntax-e i)))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a URI string or an `only', `except', `add-prefix', or `rename' form"
|
|
orig-i
|
|
i))
|
|
(let ([name (datum->syntax-object i (uri->module-path (syntax-e i)) i)])
|
|
(cond
|
|
[onlys
|
|
;; Onlys are implemented with `rename':
|
|
(mk-require (map (lambda (name-pair)
|
|
#`(rename #,name #,(cdr name-pair) #,(car name-pair)))
|
|
onlys))]
|
|
[(or exceptions (pair? renames))
|
|
;; First import non-renamed, then renamed:
|
|
(mk-require (cons
|
|
(localize i #`(#,(if extra-prefix #'prefix-all-except #'all-except)
|
|
#,@(if extra-prefix (list extra-prefix) null)
|
|
#,name
|
|
#,@(append (map car (or exceptions null))
|
|
(map car renames))))
|
|
(map (lambda (i)
|
|
#`(rename #,name #,(cdr i) #,(car i)))
|
|
renames)))]
|
|
[extra-prefix
|
|
(mk-require (list (localize i #`(prefix #,extra-prefix #,name))))]
|
|
[else
|
|
(mk-require (list name))])))))
|
|
|
|
(define (translate-export i)
|
|
(define orig-i #`(export #,i))
|
|
(translate-impexp
|
|
i orig-i
|
|
(lambda (i exceptions onlys renames extra-prefix)
|
|
(syntax-case* i (all-defined) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
|
[(all-defined)
|
|
(cond
|
|
[onlys
|
|
#`(provide #,@(map (lambda (name-pair)
|
|
#`(rename #,(car name-pair) #,(cdr name-pair)))
|
|
onlys))]
|
|
[(or exceptions (pair? renames))
|
|
;; First import non-renamed, then renamed:
|
|
#`(provide (#,(if extra-prefix #'prefix-all-defined-except #'all-defined-except)
|
|
#,@(if extra-prefix (list extra-prefix) null)
|
|
#,@(append (map car (or exceptions null))
|
|
(map car renames)))
|
|
#,@(map (lambda (i)
|
|
#`(rename #,(car i) #,(cdr i)))
|
|
renames))]
|
|
[extra-prefix
|
|
#`(provide (prefix-all-defined #,extra-prefix))]
|
|
[else
|
|
#`(provide (all-defined))])]
|
|
[(all-defined . _)
|
|
(raise-syntax-error #f "bad syntax" i)]
|
|
[_else
|
|
(begin
|
|
(unless (identifier? i)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier or an `all-defined', `only', `except', `add-prefix', or `rename' form"
|
|
orig-i
|
|
i))
|
|
(when exceptions
|
|
(check-present orig-i "except not" "identifier" values exceptions (list i)))
|
|
(when onlys
|
|
(check-present orig-i "only not" "identifier" values onlys (list i)))
|
|
(when renames
|
|
(check-present orig-i "rename not" "identifier" values renames (list i)))
|
|
(cond
|
|
[(pair? exceptions)
|
|
;; Must be the only exception, so nothing is exported
|
|
#'(provide)]
|
|
[(pair? renames)
|
|
#`(provide (rename #,(caar renames) #,(cdar renames)))]
|
|
[extra-prefix
|
|
#`(provide (rename #,i #,(add-prefix extra-prefix i)))]
|
|
[else #`(provide #,i)]))]))))
|
|
|
|
(define (translate-impexp i orig-i k)
|
|
(let loop ([i i]
|
|
[exceptions #f] ; #f if onlys
|
|
[onlys #f] ; #f if exceptions
|
|
[renames null] ; null if onlys
|
|
[extra-prefix #f]) ; #f if onlys, already folded into exceptions & renames
|
|
(syntax-case* i (only except rename add-prefix) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
|
[(only sub name ...)
|
|
(let ([names (syntax->list #'(name ...))])
|
|
(for-each (check-identifier i) names)
|
|
(check-unique-names orig-i "`only'" names)
|
|
(check-present orig-i "rename not" "`only' list" values renames names)
|
|
(cond
|
|
[exceptions
|
|
(check-present orig-i "except not" "`only' list" values exceptions names)
|
|
(loop #'sub
|
|
#f
|
|
(remove* exceptions (map (lambda (i)
|
|
(cons i (or (locate-rename i renames)
|
|
(add-prefix extra-prefix i))))
|
|
names)
|
|
(lambda (a b) (bound-identifier=? (car a) (car b))))
|
|
null
|
|
#f)]
|
|
[onlys
|
|
(check-present orig-i "only not" "`only' list" values onlys names)
|
|
(loop #'sub #f onlys null #f)]
|
|
[else
|
|
(loop #'sub
|
|
#f
|
|
(map (lambda (i)
|
|
(cons i (or (locate-rename i renames)
|
|
(add-prefix extra-prefix i))))
|
|
names)
|
|
null
|
|
#f)]))]
|
|
[(only . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
i)]
|
|
[(except sub name ...)
|
|
(let ([names (syntax->list #'(name ...))])
|
|
(for-each (check-identifier i) names)
|
|
(check-unique-names orig-i "`except'" names)
|
|
(check-present orig-i "rename" "`except' list" not renames names)
|
|
(let ([remove-exceptions
|
|
(lambda ()
|
|
(remove* exceptions renames (lambda (a b) (bound-identifier=? (car a) (car b)))))])
|
|
(cond
|
|
[(pair? exceptions)
|
|
(check-present orig-i "except" "`except' list" not exceptions names)
|
|
;; union the exceptions
|
|
(loop #'sub
|
|
(append
|
|
(remove* exceptions (map (lambda (i)
|
|
(cons i (or (locate-rename i renames)
|
|
(add-prefix extra-prefix i))))
|
|
names)
|
|
(lambda (a b) (bound-identifier=? (car a) (car b))))
|
|
exceptions)
|
|
#f
|
|
(remove-exceptions)
|
|
extra-prefix)]
|
|
[(pair? onlys)
|
|
(check-present orig-i "only" "`except' list" not onlys names)
|
|
(loop #'sub #f onlys null #f)]
|
|
[else
|
|
(loop #'sub
|
|
(map (lambda (i)
|
|
(cons i (add-prefix extra-prefix i)))
|
|
names)
|
|
#f
|
|
(remove-exceptions)
|
|
extra-prefix)])))]
|
|
[(except . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
i)]
|
|
[(rename sub (new old) ...)
|
|
(let* ([new-names (syntax->list #'(new ...))]
|
|
[old-names (syntax->list #'(old ...))]
|
|
[name-pairs (map (lambda (old new)
|
|
(cons old (add-prefix extra-prefix new)))
|
|
old-names new-names)])
|
|
(for-each (check-identifier i) (apply append (map list new-names old-names)))
|
|
(check-unique-names orig-i "`rename' target" new-names)
|
|
(check-unique-names orig-i "`rename' source" old-names)
|
|
(let ([combine-renames
|
|
(lambda ()
|
|
(let ([renames (apply-rename new-names old-names renames)])
|
|
(append
|
|
renames
|
|
(remove* renames name-pairs
|
|
(lambda (a b)
|
|
(bound-identifier=? (car a) (car b)))))))])
|
|
(cond
|
|
[exceptions
|
|
(loop #'sub
|
|
(apply-rename new-names old-names exceptions)
|
|
#f
|
|
(combine-renames)
|
|
extra-prefix)]
|
|
[onlys
|
|
(loop #'sub
|
|
#f
|
|
(apply-rename new-names old-names onlys)
|
|
null
|
|
#f)]
|
|
[else
|
|
(loop #'sub
|
|
#f
|
|
#f
|
|
(combine-renames)
|
|
extra-prefix)])))]
|
|
[(rename . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
i)]
|
|
[(add-prefix sub prefix)
|
|
(cond
|
|
[onlys
|
|
(loop #'sub
|
|
#f
|
|
(remove-all-prefixes orig-i onlys "only" #'prefix)
|
|
null
|
|
#f)]
|
|
[else
|
|
(loop #'sub
|
|
(and exceptions
|
|
(remove-all-prefixes orig-i exceptions "except" #'prefix))
|
|
#f
|
|
(remove-all-prefixes orig-i renames "rename" #'prefix)
|
|
(add-prefix extra-prefix #'prefix))])]
|
|
[(add-prefix . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
i)]
|
|
[_else
|
|
(k i exceptions onlys renames extra-prefix)]))))
|