[plt-scheme] Dot-notation for structure field access

Jens Axel Søgaard skrev:
> jos koot skrev:
>> Hi Jens Axel,
>> Thanks, Yes I guessed the problem was located there.
>> I understand that the two transformers produce syntactically distinct 
>> identifiers, but I would not know how to make them identical. I have 
>> tried (quasi)syntax/loc, but that did not work either. Is there a 
>> solution for this problem? If so, can you give me some extra hint? 
> 
> Haven't figured it out yet.

Still haven't, but instead here is the beginning of an
alternative solution. The s.x syntax works now. If you want
to avoid the explicit use of the type in define-struct-var, then
introduce a registry for constructors to types as you had in
your original version.

Also (set! s.x expr) is missing in this version.

/Jens Axe,


(module for-dot-transformers mzscheme
   (define-struct type (name fields))
   (provide (struct type (name fields))))

(module dot mzscheme ; for dotted notation of struct-fields for both 
references and assignments.

   (require-for-syntax
    for-dot-transformers
    (prefix srfi: (lib "1.ss" "srfi"))) ; for srfi:assoc

   (begin-for-syntax
     (define types '())
     (define (register-type! name type)
       (set! types (cons (cons name type) types)))
     (define (lookup-type name)
       (cond
         [(srfi:assoc name types module-identifier=?)
          => cdr]
         [else
          (error 'lookup-type "unknown type: ~a\n" name)]))

     (define (->string o)
       (cond
         [(identifier? o) (symbol->string (syntax-e o))]
         [(symbol? o)     (symbol->string o)]
         [(string? o)     o]
         [else
           (error '->string
            "expected, identifier, symbol, or string, got: ~a\n" o)]))

     (define (make-identifier stx before between after)
       (datum->syntax-object
        stx (string->symbol
             (string-append (->string before)
                            between (->string after))))))

   ; (define-struct-type d c p (x y z) (make-inspector))
   (define-syntax (define-struct-type stx)
     (syntax-case stx ()
       ((define-struct-type name constr pred (field ...))
        #'(define-struct-type (name constr pred #f)
                              (field ...) #f       ))
       ((define-struct-type name constr pred (field ...) inspector)
        #'(define-struct-type (name constr pred #f   )
                              (field ...) inspector))
       ((define-struct-type (name constr pred) (field ...))
        #'(define-struct-type (name constr pred #f   )
                              (field ...) #f       ))
       ((define-struct-type (name constr pred super)
                            (field ...)          )
        #'(define-struct-type (name constr pred super)
                              (field ...) #f       ))
       ((define-struct-type (name constr pred      )
                            (field ...) inspector)
        #'(define-struct-type (name constr pred #f   )
                              (field ...) inspector))
       ((define-struct-type (name constr pred super)
                            (field ...) inspector)
        (register-type! #'name
                       (make-type #'name
                                  (syntax-object->datum #'(field ...))))
        #`(begin
            #,(syntax-case #'super ()
                [#f    #`(define-struct name (field ...) inspector)]
                [super #`(define-struct (name super)
                                        (field ...) inspector)])
            (define name   #,(make-identifier stx 'struct ":" #'name))
            (define constr #,(make-identifier stx 'make "-" #'name))
            (define pred   #,(make-identifier stx #'name "" "?"))))))


   (define-syntax (define-struct-var stx)
     (syntax-case stx ()
       ((define-struct-var var type-name (constr expr ...))
        #`(begin
            (define var (constr expr ...))
            (define-dotted-accessors s type-name)))))

   (define-syntax (define-dotted-accessors stx)
     (syntax-case stx ()
       [(define-dotted-accessors var type-name)
        #`(begin
            #,@(map (lambda (field)
                      (with-syntax
                          ([var.field
                            (syntax-local-introduce
                              (make-identifier #'stx #'var "." field))]
                           [type-name-field
                            (make-identifier
                               #'var #'type-name "-" field)])
                        #'(define-syntax (var.field stx)
                            (syntax-case stx ()
                              [ref #'(type-name-field var)]))))
                    (type-fields (lookup-type #'type-name))))]))

   (provide define-struct-type define-struct-var))

;;; test

(require dot)

"one"                                               ; --> "one"
(define-struct-type d c p (x y z) (make-inspector))
"two"                                               ; --> "two"
(define-struct-var s d (make-d 1 2 add1))
"three"                                             ; --> "three"
struct:d                                                   ; --> 
#<struct-type:d>
c                                                   ; --> 
#<primitive:make-d>
d?                                                   ; --> #<primitive:d?>
s                                                   ; --> #(struct:d 1 2 3)
(p s)
"four"                                              ; --> "four"
s.x
;(set! s.x 3)