[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