PasteRack.org
Paste # 92975
2019-05-03 18:46:56

Fork as a new paste.

Paste viewed 356 times.


Embed:

  1. #lang typed/racket
  2.  
  3. (require (for-syntax racket/syntax
  4.                      racket/list
  5.                      syntax/parse))
  6.  
  7. (provide struct/fields)
  8.  
  9.  
  10. (begin-for-syntax
  11.   (define (syntax->keyword stx)
  12.     (string->keyword (symbol->string (syntax->datum stx)))))
  13.  
  14. (: symbol (-> Any Symbol))
  15. (define (symbol a)
  16.   (if (symbol? a)
  17.       a
  18.       'error))
  19.  
  20. (define symbol->keyword
  21.   (compose string->keyword symbol->string))
  22.  
  23. (define-syntax struct/fields
  24.   (syntax-parser
  25.     [(_ id ([field : type] ...))
  26.      (with-syntax ([constructor/kw (format-id #'id "~a/kw" #'id)]
  27.                    [constructor/fields (format-id #'id "~a/fields" #'id)]
  28.                    [(kw+type ...) (append*
  29.                                    (map (lambda (fld type)
  30.                                           (list (syntax->keyword fld)
  31.                                                 type))
  32.                                         (syntax->list #'(field ...))
  33.                                         (syntax->list #'(type ...))))]
  34.                    [(kw+field ...) (append*
  35.                                     (map (lambda (fld)
  36.                                            (list (syntax->keyword fld)
  37.                                                  fld))
  38.                                          (syntax->list #'(field ...))))]
  39.                    [ooo #'(... ...)])
  40.        #'(begin
  41.            (struct id ([field : type] ...))
  42.            (define constructor/kw
  43.              (ann (λ (kw+field ...)
  44.                     (id field ...))
  45.                   (kw+type ... -> id)))
  46.            (define-syntax constructor/fields
  47.              (syntax-parser
  48.                [(_ [fld val] ooo)
  49.                 (with-syntax ([(kw+val ooo) (append*
  50.                                              (map (lambda (fld val)
  51.                                                     (list (syntax->keyword fld)
  52.                                                           val))
  53.                                                   (syntax->list #'(fld ooo))
  54.                                                   (syntax->list #'(val ooo))))])
  55.                   #'(constructor/kw kw+val ooo))]))))]))
  56.  
  57. (struct/fields
  58.  foo
  59.  ([a : Integer]
  60.   [b : Symbol]))
  61.  
  62. (foo/fields
  63.  [b 'x]
  64.  [a 5])

=>