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

Got it now. See line tagged with <=====. Thanks for your help.
Soon I will add let-struct-type and let-struct-var.
Jos

(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 . x) ; allow anu number of components
       (datum->syntax-object
        stx (string->symbol
             (apply string-append (map ->string x))))))

   ; (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)]
                           [set-type-name-field
                            (make-identifier #'var 'set- #'type-name "-" field "!")])
                        #'(define-syntax var.field
                            (make-set!-transformer ;<===========
                             (lambda (stx)
                              (syntax-case stx (set!)
                               [(set! ref v) #'(set-type-name-field var v)]
                               [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)
s.x ; --> 3

(((((lambda(x)((((((((x x)x)x)x)x)x)x)x))
    (lambda(x)(lambda(y)(x(x y)))))
   (lambda(x)(x)x))
  (lambda()(printf "Greetings, Jos~n"))))
  ----- Original Message ----- 
  From: Jens Axel Søgaard 
  To: Jens Axel Søgaard 
  Cc: jos koot ; plt-scheme at list.cs.brown.edu ; Sam TH 
  Sent: Sunday, March 11, 2007 5:10 PM
  Subject: Re: [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)

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20070311/f123d3f5/attachment.html>