[plt-scheme] Dot-notation for structure field access
George Herson skrev:
> May not be the best approach but I'm enjoying the
> compactness of the resulting code (which allows
> conventional table-name.column-name notation in a
> sql-like mini-language).
That remark sparked inspired me to play a little
with #top in order to get the following to work:
(require dot)
(define-struct color (r g b) (make-inspector))
(define-accessor r color-r)
(define-accessor g color-g)
(define-accessor b color-b)
(define a (make-color 1 2 3))
a.r ; evaluates to 1
a.g ; evaluates to 2
a.b ; evaluates to 3
The entire program, which by no means is well-tested, is below.
/Jens Axel
; Put the entire program in a buffer, choose "Pretty Big"
; and click "Run".
(module dot-helper mzscheme
(provide dot define-accessor)
(begin-for-syntax
(define accessors (list)))
(require-for-syntax (prefix srfi: (lib "1.ss" "srfi")))
(define-syntax (dot stx)
(syntax-case stx ()
[(dot expr accessor)
#`(#,(cdr (srfi:assoc #'accessor accessors module-identifier=?))
expr)]))
(define-syntax (define-accessor stx)
(syntax-case stx ()
[(define-accessor name getter)
(begin
(set! accessors (cons (cons #'name #'getter)
accessors))
#'(void))])))
(module dot mzscheme
(provide (rename my-top #%top)
define-accessor
dot)
(require (lib "pregexp.ss")
dot-helper)
(define-for-syntax (contains-dot? sym)
(member #\. (string->list
(symbol->string sym))))
(define-for-syntax (split-at-dot sym)
(cond
[(regexp-match #rx"^([^.]*)\\.([^.]*)$" (symbol->string sym))
=>(lambda (result)
(values (string->symbol (list-ref result 1))
(string->symbol (list-ref result 2))))]
[else #f]))
(define-syntax (my-top stx)
(syntax-case stx ()
[(_ . name)
(and (identifier? #'name)
(contains-dot? (syntax-e #'name)))
(let-values ([(before after)
(split-at-dot (syntax-e #'name))])
(with-syntax ([var (datum->syntax-object #'stx before)]
[acc (datum->syntax-object #'stx after)])
#'(dot var acc)))]
[(_ . name)
#'(#%top . name)])))
(require dot)
(define-struct color (r g b) (make-inspector))
(define-accessor r color-r)
(define-accessor g color-g)
(define-accessor b color-b)
(define a (make-color 1 2 3))
a.r
a.g
a.b