PasteRack.org
Paste # 11555
2021-08-18 15:56:38

Forked from paste # 48885.

Fork as a new paste.

Paste viewed 304 times.


Embed:

abstracting with a helper macro

  1. #lang typed/racket
  2.  
  3. (require (for-syntax syntax/parse racket/syntax))
  4.  
  5. (define-syntax (struct-with-assoc stx)
  6.   (syntax-parse stx
  7.     #:literals (:)
  8.     [(_ name ([field : Type] ...))
  9.      (with-syntax ([(pred ...) (generate-temporaries #'(Type ...))]
  10.                    [struct->assoc (format-id #'name "~a->assoc" #'name)]
  11.                    [assoc->struct (format-id #'name "assoc->~a" #'name)])
  12.        #'(begin
  13.            (struct name ([field : Type] ...) #:transparent)
  14.  
  15.            (define pred (make-predicate Type))
  16.            ...
  17.  
  18.            (assoc-for-struct name (field ...) (pred ...) (Type ...))))]))
  19.  
  20. (define-type Assoc (Listof (Pairof Any Any)))
  21.  
  22. (: assoc-ref (-> Assoc Any Any))
  23. (define (assoc-ref lst key)
  24.   (let ([pair (assoc key lst)])
  25.     (if (pair? pair)
  26.         (cdr pair)
  27.         (error "Missing field" key))))
  28.  
  29. (define-syntax (assoc-for-struct stx)
  30.   (syntax-parse stx
  31.     [(_ name (field ...) (pred ...) (Type ...))
  32.      (with-syntax ([struct->assoc (format-id #'name "~a->assoc" #'name)]
  33.                    [assoc->struct (format-id #'name "assoc->~a" #'name)])
  34.        #'(begin
  35.            (define (struct->assoc f)
  36.              (match f
  37.                [(name field ...)
  38.                 `((field . ,field) ...)]))
  39.  
  40.            (define (assoc->struct [x : Assoc])
  41.              (let ([field : Type
  42.                           (let ([val (assoc-ref x 'field)])
  43.                             (if (pred val)
  44.                                 val
  45.                                 (error "Type error" 'field "expected" 'Type "got" val)))]
  46.                    ...)
  47.                (name field ...)))))]))
  48.  
  49. (module+ test
  50.   (require typed/rackunit)
  51.  
  52.   (struct-with-assoc foo ([a : Integer]
  53.                           [b : Symbol]
  54.                           [c : String]))
  55.  
  56.   (define the-foo (foo 42 'hello "world"))
  57.  
  58.   (check-equal? (foo->assoc the-foo)
  59.                 '((a . 42) (b . hello) (c . "world")))
  60.  
  61.   (check-equal? (assoc->foo '((a . 1)
  62.                               (c . "c")
  63.                               (b . b)))
  64.                 (foo 1 'b "c")))

=>