From 9dd2d0bce5f36775f8c5cf53e348ec9cb93f4ce1 Mon Sep 17 00:00:00 2001 From: Ben Greenman Date: Mon, 20 Sep 2021 23:19:10 -0400 Subject: [PATCH] add define/with-datum from https://github.com/syntax-objects/Summer2021/issues/21 cc @shhyou --- define-with-datum/define-with-datum-test.rkt | 23 ++++++++ define-with-datum/define-with-datum.rkt | 57 ++++++++++++++++++++ define-with-datum/define-with-datum.scrbl | 46 ++++++++++++++++ index.scrbl | 1 + render.rkt | 7 +++ 5 files changed, 134 insertions(+) create mode 100644 define-with-datum/define-with-datum-test.rkt create mode 100644 define-with-datum/define-with-datum.rkt create mode 100644 define-with-datum/define-with-datum.scrbl diff --git a/define-with-datum/define-with-datum-test.rkt b/define-with-datum/define-with-datum-test.rkt new file mode 100644 index 0000000..fda63ba --- /dev/null +++ b/define-with-datum/define-with-datum-test.rkt @@ -0,0 +1,23 @@ +#lang racket/base +(module+ test + (require rackunit syntax-parse-example/define-with-datum/define-with-datum syntax/datum syntax/macro-testing) + + (define/with-datum (x ((y z ...) ...)) + '("X" (("Y1" "Z11" "Z12") + ("Y2" "Z21")))) + + (check-equal? (datum x) "X") + + (check-equal? + (with-datum ([w "W"]) + (datum ((y w) ...))) + '(("Y1" "W") ("Y2" "W"))) + + (check-equal? + (datum ((^ z ... $) ...)) + '((^ "Z11" "Z12" $) (^ "Z21" $))) + + (check-exn #rx"x: pattern variable cannot be used outside of a template" + (lambda () (convert-compile-time-error x))) + +) diff --git a/define-with-datum/define-with-datum.rkt b/define-with-datum/define-with-datum.rkt new file mode 100644 index 0000000..d47191f --- /dev/null +++ b/define-with-datum/define-with-datum.rkt @@ -0,0 +1,57 @@ +#lang racket/base + +(provide define/with-datum) + +(require syntax/parse/define + syntax/datum + (for-syntax racket/base + racket/syntax + racket/private/sc)) + +(begin-for-syntax + (define-syntax-class (fresh-temporary fresh-stx) + #:attributes (fresh-var) + (pattern name + #:with fresh-var (format-id fresh-stx "~a" (generate-temporary #'name)))) + + (define (count-ellipses-depth var...^n) + (for/fold ([var...^n var...^n] + [depth 0]) + ([current-depth (in-naturals 1)] + #:break (not (pair? var...^n))) + (values (car var...^n) current-depth)))) + +#| +Source: + https://github.com/racket/racket/blob/8e83dc25f7f5767d9e975f20982fdbb82f62415a/racket/collects/racket/syntax.rkt#L22-#L59 + + racket/collects/racket/syntax.rktracket/collects/racket/syntax.rkt + Commit SHA: 8e83dc25f7f5767 + Line: 22-59 +|# +(define-syntax-parse-rule (define/with-datum pattern rhs) + #:attr matched-vars (get-match-vars #'define/with-datum + this-syntax + #'pattern + '()) + #:with (((~var pvar (fresh-temporary #'here)) . depth) ...) + (for/list ([x (attribute matched-vars)]) + (define-values (var depth) + (count-ellipses-depth x)) + (cons var depth)) + + (begin + (define-values (pvar.fresh-var ...) + (with-datum ([pattern rhs]) + (values (pvar-value pvar) ...))) + (define-syntax pvar + (make-s-exp-mapping 'depth (quote-syntax pvar.fresh-var))) + ...)) + +;; auxiliary macro +(define-syntax-parse-rule (pvar-value pvar:id) + #:attr mapping (syntax-local-value #'pvar) + #:do [(unless (s-exp-pattern-variable? (attribute mapping)) + (raise-syntax-error #f "not a datum variable" #'pvar))] + #:with value-var (s-exp-mapping-valvar (attribute mapping)) + value-var) diff --git a/define-with-datum/define-with-datum.scrbl b/define-with-datum/define-with-datum.scrbl new file mode 100644 index 0000000..f01feac --- /dev/null +++ b/define-with-datum/define-with-datum.scrbl @@ -0,0 +1,46 @@ +#lang syntax-parse-example +@require[ + (for-label racket/base syntax/parse racket/syntax syntax/datum syntax-parse-example/define-with-datum/define-with-datum)] + +@(define define-with-datum-eval + (make-base-eval '(require syntax/datum syntax-parse-example/define-with-datum/define-with-datum))) + +@title{@tt{define/with-datum}} + +@; ============================================================================= + +@defmodule[syntax-parse-example/define-with-datum/define-with-datum]{} +@stxbee2021["shhyou" 21] + +@defform[(define/with-datum pattern datum-expr)]{ + + Definition form of @racket[with-datum]. + Matches the value result of @racket[datum-expr] and binds the pattern variables + in @racket[pattern]. + + The following example defines three pattern variables: + @racket[x] gets bound to a string, + @racket[y] (at @tech/syntax{ellipsis depth} 1) gets bound to a list of strings, + and @racket[z] (at ellipsis depth 2) gets bound to a list of lists of strings. + + @examples[#:eval define-with-datum-eval + (define/with-datum (x ((y z ...) ...)) + '("X" (("Y1" "Z11" "Z12") + ("Y2" "Z21")))) + (datum x) + (with-datum ([w "W"]) + (datum ((y w) ...))) + (datum ((^ z ... $) ...)) + ] + + The implementation is similar to that of @racket[define/with-syntax] + (@hyperlink["https://github.com/racket/racket/blob/8e83dc25f7f5767d9e975f20982fdbb82f62415a/racket/collects/racket/syntax.rkt#L22-#L59" "link"]) + but uses @racket[syntax-parse] pattern directives to express the procedural + code from the original. + These pattern directives allow escaping into arbitrary expansion-time + computation while retaining appropriate semantical meanings such as binding a + pattern variable (@racket[#:with]) or performing an imperative action (@racket[#:do]). + + @racketfile{define-with-datum.rkt} + +} diff --git a/index.scrbl b/index.scrbl index a5ad43b..700c7a7 100644 --- a/index.scrbl +++ b/index.scrbl @@ -45,3 +45,4 @@ @include-example{define-freevar} @include-example{fnarg} @include-example{fresh-variable} +@include-example{define-with-datum} diff --git a/render.rkt b/render.rkt index 5263317..e154fb0 100644 --- a/render.rkt +++ b/render.rkt @@ -23,6 +23,10 @@ ;; where the `....` is the module path for The Racket Reference ;; (If the name is too long for you, `rename-in` to something shorter.) + tech/syntax + ;; Usage: @tech/syntax{text} + ;; where `text` refers to a definition from the `syntax` lib. + racketfile ;; Usage: @racketfile{filename} ;; where `filename` is a string representing a Racket file @@ -88,6 +92,9 @@ (define (tech/reference . text) (keyword-apply tech '(#:doc) '((lib "scribblings/reference/reference.scrbl")) text)) +(define (tech/syntax . text) + (keyword-apply tech '(#:doc) '((lib "syntax/scribblings/syntax.scrbl")) text)) + (define (github-user usr) (hyperlink (format "https://github.com/~a" usr) (tt usr)))