Skip to content

Instantly share code, notes, and snippets.

@Metaxal
Last active December 18, 2015 20:28
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Metaxal/5840051 to your computer and use it in GitHub Desktop.
Save Metaxal/5840051 to your computer and use it in GitHub Desktop.
Giving default/optional values for struct. Define the struct with opt-struct instead of struct, and use make-<struct-name> as the default constructor. struct-default.rkt is the simple version, but does not handle super structs as struct-default-super.rkt does (though not entirely correctly).
#lang racket
(require (for-syntax syntax/parse
racket/syntax))
;;; Recognizes super-id and keyword arguments of struct.
;;; Caveats:
;;; - does not recognize per-field options (like per-field mutability).
;;; - the hash table uses the symbol of the super-id, but should use the binding instead.
;;; - may not work if the default expr depends on bindings not available in the context of the
;;; child struct.
(begin-for-syntax
(define hstruct (make-hash)))
(define-syntax opt-struct
(syntax-parser
[(_ name:id (~optional maybe-super:id) (field:id ... [field-opt:id val-opt:expr] ...) rest ...)
(define super-fields (if (attribute maybe-super)
(hash-ref hstruct (syntax->datum #'maybe-super) '())
'(()())))
(define super-mand (car super-fields)) ; (listof (listof symbol))
(define super-opt (cadr super-fields)) ; (listof (listof (list symbol default-expr)))
; The super-mand and super-opt contain a list of lists (one list per super-struct)
; in order to keep to rebuild the correct field order
; (which is different for the struct and for the constructor).
#;(displayln super-fields)
(hash-set! hstruct (syntax->datum #'name) ; WARNING: we should use the binding, not the symbol!
(list (append super-mand
(list (syntax->datum #'(field ...))))
(append super-opt
(list (syntax->datum #'((field-opt val-opt) ...))))
))
#;(displayln hstruct)
(with-syntax ([make (format-id #'name "make-~a" #'name)]
[hstruct hstruct])
#`(begin (struct name #,@(if (attribute maybe-super) (list #'maybe-super) '())
(field ... field-opt ...) rest ...)
(define (make #,@(apply append super-mand) field ...
#,@(apply append super-opt) [field-opt val-opt] ...)
; we must reorder the mandatory and optional fields:
(name #,@(apply append (map (λ(m o)(append m (map car o))) super-mand super-opt))
field ... field-opt ...))
))]))
(module+ test
(require rackunit)
(opt-struct mystruct (a b [c 'c] [d 'd])
#:transparent)
#;(begin (struct mystruct (a b c d) #:transparent)
(define (make-mystruct a b [c 'c] [d 'd])
(mystruct a b c d)))
(check-equal? (struct->vector (make-mystruct 'a 'b))
#(struct:mystruct a b c d))
(check-equal? (struct->vector (make-mystruct 'aa 'bb 'cc 'dd))
#(struct:mystruct aa bb cc dd))
(opt-struct mystruct2 mystruct (e f)
#:transparent)
#;(begin (struct mystruct2 mystruct (e f) #:transparent)
(define (make-mystruct2 a b e f (c 'c) (d 'd))
(mystruct2 a b c d e f)))
(check-equal? (struct->vector (make-mystruct2 'a 'b 'e 'f))
#(struct:mystruct2 a b c d e f))
(opt-struct mystruct3 mystruct2 (g [h 'h])
#:transparent)
#;(begin (struct mystruct3 mystruct2 (g h) #:transparent)
(define (make-mystruct3 a b e f g (c 'c) (d 'd) [h 'h])
(mystruct3 a b c d e f g h)))
(check-equal? (struct->vector (make-mystruct3 'a 'b 'e 'f 'g 'cc 'dd 'hh))
#(struct:mystruct3 a b cc dd e f g hh))
(check-equal? (struct->vector (make-mystruct3 'a 'b 'e 'f 'g 'ccc 'dd 'h))
#(struct:mystruct3 a b ccc dd e f g h))
)
#lang racket
(require (for-syntax syntax/parse
racket/syntax))
;;; Caveats:
;;; - does not recognize per-field options (like per-field mutability).
;;; - does not allow for a super struct.
;;; - may not work if the default expr depends on bindings not available in the context of the
;;; child struct.
(define-syntax opt-struct
(syntax-parser
[(_ name (field:id ... [field-opt:id val-opt:expr] ...) rest ...)
(with-syntax ([make (format-id #'name "make-~a" #'name)])
#'(begin (struct name (field ... field-opt ...) rest ...)
(define (make field ... [field-opt val-opt] ...)
(name field ... field-opt ...))
))]))
(module+ test
(require rackunit)
(opt-struct mystruct (a b [c 3] [d 5])
#:transparent)
(check-equal? (struct->vector (make-mystruct 1 2))
#(struct:mystruct 1 2 3 5))
(check-equal? (struct->vector (make-mystruct 7 8 9 10))
#(struct:mystruct 7 8 9 10))
)
@Metaxal
Copy link
Author

Metaxal commented Jun 22, 2013

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment