54 lines
1.8 KiB
Racket
54 lines
1.8 KiB
Racket
(module structure-helper mzscheme
|
|
(require syntax/stx)
|
|
(provide str str? str-renames make-str remove-dups split open open-as-helper)
|
|
(define-struct str (renames))
|
|
|
|
(define (remove-dups l)
|
|
(let ((ht (make-hash-table)))
|
|
(let loop ((l l))
|
|
(cond
|
|
((null? l) null)
|
|
((hash-table-get ht (caar l) (lambda () #f)) (loop (cdr l)))
|
|
(else
|
|
(hash-table-put! ht (caar l) #t)
|
|
(cons (car l) (loop (cdr l))))))))
|
|
|
|
(define (split path)
|
|
(let ((r (reverse path)))
|
|
(values (reverse (cdr r)) (car r))))
|
|
|
|
(define (get-renames id err)
|
|
(let ((x (syntax-local-value id (err id))))
|
|
(unless (str? x)
|
|
((err id)))
|
|
(str-renames x)))
|
|
|
|
(define (open path type)
|
|
(unless (identifier? (car path))
|
|
(raise-syntax-error type "Path component must be an identifier" (car path)))
|
|
(let ((err (lambda (name)
|
|
(lambda ()
|
|
(raise-syntax-error type "Unknown structure" name)))))
|
|
(let loop ((path (cdr path))
|
|
(env (get-renames (car path) err)))
|
|
(cond
|
|
((null? path) env)
|
|
(else
|
|
(unless (identifier? (car path))
|
|
(raise-syntax-error type "Path component must be an identifier" (car path)))
|
|
(let ((bind (assq (syntax-object->datum (car path)) env)))
|
|
(unless bind
|
|
((err (car path))))
|
|
(loop (cdr path) (get-renames (cdr bind) err))))))))
|
|
|
|
(define (open-as-helper path field)
|
|
(unless (identifier? field)
|
|
(raise-syntax-error 'open-as "Field to open must be an identifier" field))
|
|
(let ((hid (assq (syntax-object->datum field )
|
|
(open (stx->list path) 'open-as))))
|
|
(unless hid
|
|
(raise-syntax-error 'open-as "Unknown field" field))
|
|
(make-rename-transformer (cdr hid))))
|
|
|
|
)
|