PasteRack.org
Paste # 58945
2019-05-03 18:55:10

Fork as a new paste.

Paste viewed 359 times.


Embed:

  1. #lang typed/racket
  2.  
  3. (require (for-syntax racket/syntax
  4.                      racket/list
  5.                      racket/struct-info
  6.                      syntax/parse))
  7.  
  8. (provide struct/fields)
  9.  
  10. (begin-for-syntax
  11.   (define (syntax->keyword stx)
  12.     (string->keyword (symbol->string (syntax->datum stx)))))
  13.  
  14. (define-syntax struct/fields
  15.   (syntax-parser
  16.     [(_ id (~optional super-id:id) ([field : type] ...) opt ...)
  17.      (with-syntax ([constructor/kw (format-id #'id "~a/kw" #'id)]
  18.                    [constructor/fields (format-id #'id "~a/fields" #'id)]
  19.                    [(kw+type ...) (append*
  20.                                    (map (lambda (fld type)
  21.                                           (list (syntax->keyword fld)
  22.                                                 type))
  23.                                         (syntax->list #'(field ...))
  24.                                         (syntax->list #'(type ...))))]
  25.                    [(kw+field ...) (append*
  26.                                     (map (lambda (fld)
  27.                                            (list (syntax->keyword fld)
  28.                                                  fld))
  29.                                          (syntax->list #'(field ...))))]
  30.                    [ooo #'(... ...)])
  31.        (if (not (attribute super-id))
  32.            #'(begin
  33.                (struct id ([field : type] ...)
  34.                  opt ...)
  35.                (define constructor/kw
  36.                  (ann (lambda (kw+field ...)
  37.                         (id field ...))
  38.                       (kw+type ... -> id)))
  39.                (define-syntax constructor/fields
  40.                  (syntax-parser
  41.                    [(_ [fld val] ooo)
  42.                     (with-syntax ([(kw+val ooo) (append*
  43.                                                  (map (lambda (fld val)
  44.                                                         (list (syntax->keyword fld)
  45.                                                               val))
  46.                                                       (syntax->list #'(fld ooo))
  47.                                                       (syntax->list #'(val ooo))))])
  48.                       #'(constructor/kw kw+val ooo))])))
  49.            (with-syntax
  50.                ([super-kw (syntax->keyword #'super-id)]
  51.                 [(super-accessors ...) (reverse (cadddr (extract-struct-info (syntax-local-value #'super-id))))])
  52.              #'(begin
  53.                  (struct id super-id ([field : type] ...)
  54.                    opt ...)
  55.                  (define constructor/kw
  56.                    (ann (lambda (super-kw super kw+field ...)
  57.                           (id (super-accessors super) ...
  58.                               field ...))
  59.                         (super-kw super-id kw+type ... -> id)))
  60.                  (define-syntax constructor/fields
  61.                    (syntax-parser
  62.                      [(_ [fld val] ooo)
  63.                       (with-syntax ([(kw+val ooo) (append*
  64.                                                    (map (lambda (fld val)
  65.                                                           (list (syntax->keyword fld)
  66.                                                                 val))
  67.                                                         (syntax->list #'(fld ooo))
  68.                                                         (syntax->list #'(val ooo))))])
  69.                         #'(constructor/kw kw+val ooo))]))))))]))
  70.  
  71. (struct/fields foo ([a : Integer] [b : Symbol]))
  72. (struct/fields bar foo ([a : String] [b : Number]))
  73.  
  74. (bar/fields
  75.    [b 1/3]
  76.    [a ""]
  77.    [foo (foo/fields
  78.          [b 'x]
  79.          [a 0])])
  80.  

=>