PasteRack.org
Paste # 48885
2021-08-12 21:02:56

Fork as a new paste.

Paste viewed 647 times.


Embed:

with-quasisyntax

  1. #lang typed/racket
  2.  
  3. (define-syntax (with-quasisyntax stx)
  4.   (syntax-case stx ()
  5.     [(_ ([a b] ...) form)
  6.      (eval-syntax #'(with-syntax ([a b] ...) #`form))]))
  7.  
  8. (with-quasisyntax ([(a b c) #'(x y z)])
  9.   (quote (a b c)))
  10.  
  11. (define-for-syntax foo-fields
  12.   #'([a : Integer]
  13.      [b : Symbol]
  14.      [c : String]))
  15.  
  16. (define-for-syntax foo-field-ids
  17.   (syntax-case foo-fields ()
  18.     [([id more ...] ...)
  19.      #'(id ...)]))
  20.  
  21. (define-for-syntax foo-field-types
  22.   (syntax-case foo-fields (:)
  23.     [([id : Type] ...)
  24.      #'(Type ...)]))
  25.  
  26. (with-quasisyntax ()
  27.   (struct foo #,foo-fields #:transparent))
  28.  
  29. (define the-foo (foo 42 'hello "world"))
  30. the-foo
  31.  
  32. (define-type Assoc (Listof (Pairof Any Any)))
  33.  
  34. (: foo->assoc (All (a) (case-> (-> foo Assoc)
  35.                                (-> (Listof a) (Listof a)))))
  36. (with-quasisyntax ([(field ...) foo-field-ids]
  37.                    [ooo (quote-syntax ...)])
  38.   (define (foo->assoc f)
  39.     (match f
  40.       [(foo field ...)
  41.        `((field . ,field) ...)]
  42.       ; just making sure that ooo works:
  43.       [(list a b more ooo)
  44.        (cons b (cons a more))])))
  45.  
  46. (foo->assoc the-foo)
  47. (foo->assoc '(1 2 3 4 5))
  48.  
  49. (: assoc-ref (-> Assoc Any Any))
  50. (define (assoc-ref lst key)
  51.   (let ([pair (assoc key lst)])
  52.     (if (pair? pair)
  53.         (cdr pair)
  54.         (error "Missing field" key))))
  55.  
  56. (with-quasisyntax ([(field ...) foo-field-ids]
  57.                    [(Type ...) foo-field-types]
  58.                    [(pred ...) (generate-temporaries foo-field-types)])
  59.   (begin
  60.     (define pred (make-predicate Type))
  61.     ...
  62.     (define (assoc->foo [x : Assoc])
  63.       (let ([field : Type
  64.                    (let ([val (assoc-ref x 'field)])
  65.                      (if (pred val)
  66.                          val
  67.                          (error "Type error" 'field "expected" 'Type "got" val)))]
  68.             ...)
  69.         (foo field ...)))))
  70.  
  71. (assoc->foo '((a . 1)
  72.               (c . "c")
  73.               (b . b)))

=>