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

[jos koot]

Skipped content of type multipart/alternative-------------- next part --------------
#| Module dot: for dotted notation of struct-fields for both references and assignments.
   By Jacob J. A. Koot with thanks to Jens Axel Søgaard.

   Syntax: (define-struct-type (def name constr pred [super-type-expr]) (field ...) [inspector-expr]) --> void
   Syntax: (define-struct-type  def name constr pred                    (field ...) [inspector-expr]) --> void
   def, name, constr and pred must be distinct identifiers.
   The super-type-expr is evaluated and must yield #f or a struct-type-decriptor.
   The inspector-expr is evaluated and must yield #f or a struct inspector.
   All fields must be distinct identifiers.
   The following definitions are made (at top level or as internal-defs.
   def    : syntax: (def var (expr ...)) --> void
            var must be an identifier 
            The variable is defined (either at top level or as an internal-def)
            such as to contain an instance of the struct-type with the values of the exprs for its fields.
            The number of exprs must correspond to the number of fields.
            In addition syntaxes var.field are defined such that:
            varref var.field returns the current contents of the field.
            (set! var.field value) stores the value in the field.
            (var.field arg ...) assumes the field to contain a procedure and applies the procedure to the args.
   name   : struct type descriptor that can be used as a super type for other struct types. 
   constr : procedure (constr expr ...) --> instance of the struct type.
   pred   : procedure (pred object) --> #t if the object is an instance of the struct type, else #f

  Syntax: (let-struct-type (binding ...) internal-def ... body-expr ...)
  Where binding ::= ((def name constr pred [super-type]) (field ...) [inspector-expr]) or
                    ( def name constr pred               (field ...) [inspector-expr])
  Synatx let-struct-type is related to syntax define-struct-type as let to define.
  
  Syntax: (let-struct-var ((var def (expr ...)) ...) internal-def ... body ...) ==>
  (let () (def var (expr ...)) ... internal-def ... body ...)
|#

(module dot mzscheme

  (require-for-syntax (only (lib "etc.ss") build-list build-vector identity))
  (require            (only (lib "etc.ss") build-list build-vector identity))
  
  (define-for-syntax (make-dotted-id stx var fld)
    (datum->syntax-object stx (string->symbol (string-append (symbol->string (syntax-e var)) "." (symbol->string (syntax-e fld))))))
  
  (define-syntax (define-struct-type stx)
    (syntax-case stx ()
      ((define-struct-type  def name constr pred        (field ...)          )
     #'(define-struct-type (def name constr pred #f   ) (field ...) #f       ))
      ((define-struct-type  def name constr pred        (field ...) inspector)
     #'(define-struct-type (def name constr pred #f   ) (field ...) inspector))
      ((define-struct-type (def name constr pred      ) (field ...)          )
     #'(define-struct-type (def name constr pred #f   ) (field ...) #f       ))
      ((define-struct-type (def name constr pred super) (field ...)          )
     #'(define-struct-type (def name constr pred super) (field ...) #f       ))
      ((define-struct-type (def name constr pred      ) (field ...) inspector)
     #'(define-struct-type (def name constr pred #f   ) (field ...) inspector))
      ((define-struct-type (def name constr pred super) (field ...) inspector)
        (let ((nr-of-fields  (length (syntax->list #'(field ...)))))
        #`(begin
            (define-values (name constr pred accessor mutator accessors mutators)
              (let-values
                (((name constr pred accessor mutator)
                    (make-struct-type 'name super #,nr-of-fields 0 #f () inspector #f () #f)))
                (define accessors (build-vector #,nr-of-fields (lambda (i) (make-struct-field-accessor accessor i))))
                (define mutators  (build-vector #,nr-of-fields (lambda (i) (make-struct-field-mutator  mutator  i))))
                (values name constr pred accessor mutator accessors mutators)))
            (define-syntax def
              (syntax-rules ()
                ((def var (expr (... ...)))
                  (begin (define var (constr expr (... ...)))
                    (define-struct-trafos var constr (field ...) accessors mutators))))))))))
  
  (define-syntax (define-struct-trafos stx)
    (syntax-case stx ()
      ((define-struct-trafos var constr (field ...) accessors mutators)
        (let*
          ((fields (syntax->list #'(field ...)))
            (nr-of-fields (length fields))
            (indices (build-list nr-of-fields identity)))
          #`(begin
            #,@(map (lambda (field index) #`(define-struct-trafo var #,field #,index accessors mutators))
              fields indices))))))
  
  (define-syntax (define-struct-trafo stx)
    (syntax-case stx ()
      ((define-struct-trafo var field index accessors mutators)
        (with-syntax ((dotted-id (syntax-local-introduce (make-dotted-id #'stx #'var #'field))))
        #`(define-syntax dotted-id
            (make-set!-transformer
              (lambda (tstx)
                (syntax-case tstx (set!)
                  ((set! id v) #'((vector-ref mutators index) var v))
                  ((id x (... ...)) #'(((vector-ref accessors index) var) x (... ...)))
                  (id #'((vector-ref accessors index) var))))))))))
  
  (define-syntax let-struct-type
    (syntax-rules ()
      ((let-struct-type (binding ...) . body)
        (let () (define-struct-type . binding) ... . body))))
  
  (define-syntax let-struct-var
    (syntax-rules ()
      ((let-struct-var ((var def (x ...)) ...) . body)
        (let () (def var (x ...)) ... . body))))
  
  (provide define-struct-type let-struct-type let-struct-var)
  ; the following syntaxes must be exported, but are not ment to be called explicitly by the importing program
  (provide define-struct-trafos define-struct-trafo))

(require dot)

;;; tests

; Welcome to DrScheme, version 369.8-svn9mar2007 [3m].
; Language: Textual (MzScheme, includes R5RS) custom (no debugging, case insensitive)

(define-struct-type (def type constr pred) (x y z) (make-inspector)) ;--> void
(list type constr pred) ; --> (#<struct-type:type> #<primitive:make-type> #<primitive:type?>)
(def var (1 2 add1)) ;--> void
(set! var.x 10) ;--> void
(list var var.x var.y (var.z 20)) ; --> (#(struct:type 10 2 #<primitive:add1>) 10 2 21)
(let-struct-type (((d n c p) (x y z) (make-inspector)))
  (let-struct-var ((v d (1 2 add1)))
    (set! v.x 10)
    (printf "~s ~s ~s ~s~n" v v.x v.y (v.z 20)))) ;--> #(struct:n 10 2 #<primitive:add1>) 10 2 21
(define-struct-type (dd tt cc pp (car (list type))) ()) ;--> void
(dd vv ('a 'b 'c)) ;--> void
(list vv (pred vv) (pp vv)) ;--> (#(struct:tt a b c) #t #t)