commit a08c491baac1a398a91aa6e877e01e4626c58bb3
parent 406698e113021b12298df401082e7682b69abdfb
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 31 Jan 2017 02:32:20 +0100
Closes 184 body which supports ddd on define
Diffstat:
7 files changed, 367 insertions(+), 65 deletions(-)
diff --git a/copy-attribute.rkt b/copy-attribute.rkt
@@ -47,8 +47,7 @@
(define-syntax/parse (copy-raw-syntax-attribute name:id
attr-value:expr
ellipsis-depth:nat
- syntax?:boolean
- props:expr)
+ syntax?:boolean)
;; the ~and is important, to prevent the nested ~or from being treated as
;; an ellipsis-head pattern.
#:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
@@ -61,13 +60,11 @@
(syntax-e #'ellipsis-depth))
(if (syntax-e #'syntax?)
#'(begin
- (define/syntax-parse nested attr-value)
- (define-pvars name))
+ (define/syntax-parse nested attr-value))
#'(begin
(define-syntax-class extract-non-syntax
#:attributes (name)
(pattern v
#:attr name (wrapped-value (syntax-e #'v))))
(define/syntax-parse nested (attribute-wrap attr-value
- ellipsis-depth))
- (define-pvars name))))
+ ellipsis-depth)))))
diff --git a/ddd-forms.rkt b/ddd-forms.rkt
@@ -0,0 +1,105 @@
+#lang racket
+(provide begin
+ define
+ let
+ (rename-out [begin #%intef-begin])
+ (rename-out [app #%app]))
+
+(require subtemplate/ddd
+ stxparse-info/case
+ stxparse-info/parse
+ phc-toolkit/untyped
+ (prefix-in - (only-in racket/base
+ begin let lambda define))
+ (prefix-in - (only-in stxparse-info/case
+ define/with-syntax))
+ (for-syntax racket/list
+ stxparse-info/parse
+ stxparse-info/parse/experimental/template
+ phc-toolkit/untyped)
+ (for-meta 2 racket/base)
+ (for-meta 2 phc-toolkit/untyped)
+ (for-meta 2 stxparse-info/parse))
+
+(begin-for-syntax
+ (define (-nest* before after -v -ooo* [depth 0])
+ (if (stx-null? -ooo*)
+ -v
+ (-nest* before
+ after
+ (datum->syntax before `(,@(syntax->list before) ,-v . ,after))
+ (stx-cdr -ooo*)
+ (add1 depth))))
+
+ (define-syntax nest*
+ (syntax-parser
+ [(self (before … {~datum %} . after) v ooo*)
+ (with-syntax ([s (datum->syntax #'self 'syntax)])
+ #'(-nest* (s ((… …) (before …))) (s ((… …) after)) (s v) (s ooo*)))]))
+
+ (define-syntax ddd*
+ (syntax-parser
+ [(_ e ooo*)
+ #'(with-syntax ([dotted (nest* (ddd %) e ooo*)])
+ (nest* (append* %)
+ (list dotted)
+ ooo*))]))
+
+ (define-syntax-class ooo
+ (pattern {~and ooo {~literal …}}))
+
+ (define-splicing-syntax-class ooo*
+ #:attributes (ooo*)
+ (pattern {~seq {~and ooo {~literal …}} …+}
+ #:with ooo* #'(ooo …)))
+
+ (define-syntax-class not-macro-id
+ #:attributes ()
+ (pattern id:id
+ #:when (not (syntax-local-value #'id (λ () #f))))
+ (pattern id:id
+ #:when (syntax-pattern-variable?
+ (syntax-local-value #'id (λ () #f)))))
+
+ (define-syntax-class not-macro-expr
+ #:attributes ()
+ (pattern :not-macro-id)
+ (pattern (:not-macro-id . _)))
+
+ (define-splicing-syntax-class stmt
+ #:literals (define define/with-syntax)
+ (pattern {~seq (define name:id e:expr) :ooo*}
+ #:with expanded
+ #`(-define name
+ #,(nest* (ddd %) e ooo*)))
+ (pattern {~seq (define/with-syntax pat e:expr) :ooo*}
+ #:with expanded
+ #`(-define/with-syntax #,(nest* (% …) pat ooo*)
+ #,(nest* (ddd %) e ooo*)))
+ (pattern {~seq e:not-macro-expr :ooo*}
+ ;#:with expanded #`(apply values #,(ddd* e ooo*))
+ #:with expanded (ddd* e ooo*))
+ (pattern other
+ #:with expanded #'other)))
+
+(define-syntax/parse (begin stmt:stmt …)
+ (template (-begin (?@ stmt.expanded) …)))
+
+(define-syntax/parse (let ([var . val] …) . body)
+ (template (-let ([var (begin . val)] …) (begin . body))))
+
+(begin-for-syntax
+ (define-splicing-syntax-class arg
+ (pattern {~seq e:expr ooo*:ooo*}
+ #:with expanded (ddd* e ooo*))
+ (pattern other
+ #:with expanded #'(#%app list other))))
+(define-syntax app
+ (syntax-parser
+ [(_ fn {~and arg {~not {~literal …}}} …)
+ #'(#%app fn arg …)]
+ [{~and (_ fn arg:arg …)
+ {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
+ #'(#%app apply fn (#%app append arg.expanded …))]
+ [(_ arg:arg …) ;; shorthand for list creation
+ #'(#%app apply list (#%app append arg.expanded …))]))
diff --git a/ddd.rkt b/ddd.rkt
@@ -6,8 +6,7 @@
phc-toolkit/untyped
subtemplate/copy-attribute
(prefix-in - syntax/parse/private/residual)
- (for-syntax "derived-valvar.rkt"
- racket/contract
+ (for-syntax racket/contract
racket/syntax
phc-toolkit/untyped
racket/function
@@ -24,7 +23,7 @@
(begin-for-syntax
(define/contract (attribute-real-valvar attr)
(-> identifier? (or/c #f identifier?))
- (define valvar1
+ (define valvar
(let ([slv (syntax-local-value attr (λ () #f))])
(if (syntax-pattern-variable? slv)
(let* ([valvar (syntax-mapping-valvar slv)]
@@ -36,20 +35,14 @@
'attribute*
"not bound as an attribute or pattern variable"
attr))))
- ;; Try to extract the actual variable from a subtemplate derived valvar.
- (define valvar2
- (let ([valvar1-slv (syntax-local-value valvar1 (λ () #f))])
- (if (derived-valvar? valvar1-slv)
- (derived-valvar-valvar valvar1-slv)
- valvar1)))
- (if (syntax-local-value valvar2 (λ () #f)) ;; is it a macro-ish thing?
+ (if (syntax-local-value valvar (λ () #f)) ;; is it a macro-ish thing?
(begin
(log-warning
(string-append "Could not extract the plain variable corresponding to"
" the pattern variable or attribute ~a"
(syntax-e attr)))
#f)
- valvar2)))
+ valvar)))
;; free-identifier=? seems to stop working on the valvars once we are outside of
;; the local-expand containing the let which introduced these valvars, therefore
@@ -90,12 +83,16 @@
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …)
- (map syntax-local-introduce
- (filter (conjoin identifier?
- (λ~> (syntax-local-value _ (thunk #f))
- syntax-pattern-variable?)
- attribute-real-valvar)
- (current-pvars))))
+ (remove-duplicates
+ (map syntax-local-get-shadower
+ (map syntax-local-introduce
+ (filter (conjoin identifier?
+ (λ~> (syntax-local-value _ (thunk #f))
+ syntax-pattern-variable?)
+ attribute-real-valvar)
+ (reverse (current-pvars)))))
+ bound-identifier=?))
+
(define-temp-ids "~aᵢ" (pvar …))
(define/with-syntax f
#`(#%plain-lambda (pvarᵢ …)
@@ -126,6 +123,7 @@
stx))
(begin
+ ;; present?+pvars is a list of (list shadow? pv pvᵢ present? depth/#f)
(define present?+pvars
(for/list ([present? (in-list present-variables)]
[pv (in-syntax #'(pvar …))]
@@ -136,7 +134,7 @@
(if (> depth 0)
(list #t pv pvᵢ #t depth)
(list #f pv pvᵢ #t depth))]) ;; TODO: detect shadowed bindings, if the pvar was already iterated on, raise an error (we went too deep).
- (list #f pv pvᵢ #f))))
+ (list #f pv pvᵢ #f #f))))
;; Pvars which are iterated over
(define/with-syntax ((_ iterated-pvar iterated-pvarᵢ _ _) …)
(filter car present?+pvars))
@@ -147,8 +145,9 @@
;; If the pvar is iterated, use the iterated pvarᵢ
;; otherwise use the original (attribute* pvar)
(define/with-syntax (filling-pvar …)
- (map (match-λ [(list #t pv pvᵢ _ _) pvᵢ]
- [(list #f pv pvᵢ _ _) #`(attribute* #,pv)])
+ (map (match-λ [(list #t pv pvᵢ #t _) pvᵢ]
+ [(list #f pv pvᵢ #t _) #`(attribute* #,pv)]
+ [(list #f pv pvᵢ #f _) #'#f])
present?+pvars)))
#'(map (λ (iterated-pvarᵢ …)
@@ -164,7 +163,11 @@
#,(max 0 (sub1 depth))
#,syntax?)]
[`(pvar ,valvar ,depth)
- #`(define-raw-syntax-mapping pvar
+ #`(copy-raw-syntax-attribute pvar
+ new-value
+ #,(max 0 (sub1 depth))
+ #t)
+ #;#`(define-raw-syntax-mapping pvar
tmp-valvar
new-value
#,(sub1 depth))]))
diff --git a/derived-valvar.rkt b/derived-valvar.rkt
@@ -1,31 +0,0 @@
-#lang racket/base
-
-(provide (struct-out derived-valvar)
- id-is-derived-valvar?)
-
-(require racket/function
- racket/private/sc
- (for-template (prefix-in - stxparse-info/parse/private/residual)))
-
-;; Act like a syntax transformer, but which is recognizable via the
-;; derived-pattern-variable? predicate.
-(struct derived-valvar (valvar)
- #:property prop:procedure
- (λ (self stx)
- #`(#%expression #,(derived-valvar-valvar self))))
-
-(define (id-is-derived-valvar? id)
- (define mapping (syntax-local-value id (thunk #f)))
- (and mapping ;; … defined as syntax
- (syntax-pattern-variable? mapping) ; and is a syntax pattern variable
- (let ()
- (define mapping-slv
- (syntax-local-value (syntax-mapping-valvar mapping) (thunk #f)))
- ;; either a mapping → attribute → derived,
- ;; or directly mapping → derived
- (or (and (-attribute-mapping? mapping-slv) ;; is an attribute
- (derived-valvar? ;; and the pvar's valvar is a derived
- (syntax-local-value (-attribute-mapping-var mapping-slv)
- (thunk #f))))
- ;; or the pvar's valvar is derived
- (derived-valvar? mapping-slv)))))
-\ No newline at end of file
diff --git a/main.rkt b/main.rkt
@@ -14,7 +14,6 @@
(subtract-in racket/syntax stxparse-info/case)
"copy-attribute.rkt"
(for-syntax "patch-arrows.rkt"
- "derived-valvar.rkt"
racket/format
stxparse-info/parse
racket/private/sc
@@ -94,7 +93,6 @@
(define/with-syntax ([binder . unique-at-runtime-id] …)
(filter (compose (conjoin identifier?
- (negate id-is-derived-valvar?)
(λ~> (syntax-local-value _ (thunk #f))
syntax-pattern-variable?)
;; force call syntax-local-value to prevent
@@ -116,7 +114,6 @@
#;(define/with-syntax ([binder . unique-at-runtime] …)
(for/list ([binder (current-pvars+unique)]
#:when (identifier? (car binder))
- #:unless (id-is-derived-valvar? (car binder))
#:when (syntax-pattern-variable?
(syntax-local-value (car binder) (thunk #f)))
;; force call syntax-local-value to prevent ambiguous
diff --git a/test/test-ddd-forms.rkt b/test/test-ddd-forms.rkt
@@ -0,0 +1,188 @@
+#lang racket
+
+(require subtemplate/ddd-forms
+ stxparse-info/case
+ stxparse-info/parse
+ rackunit
+ syntax/macro-testing
+ phc-toolkit/untyped)
+
+;; case, let + begin, define
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (let ()
+ (begin
+ (define y (- (syntax-e #'x))) … …
+ y))])
+ '((-1 -2 -3) (-4 -5)))
+
+;; case, let + begin, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (let ()
+ (begin
+ (define/with-syntax y (- (syntax-e #'x))) … …
+ #'((y …) …)))]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; case, let, define
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (let ()
+ (define y (- (syntax-e #'x))) … …
+ y)])
+ '((-1 -2 -3) (-4 -5)))
+
+;; case, let, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (let ()
+ (define/with-syntax y (- (syntax-e #'x))) … …
+ #'((y …) …))]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, let + begin, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (let ()
+ (begin
+ (define y (- (syntax-e #'x))) … …
+ y))])
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, let + begin, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (let ()
+ (begin
+ (define/with-syntax y (- (syntax-e #'x))) … …
+ #'((y …) …)))]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, let, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (let ()
+ (define y (- (syntax-e #'x))) … …
+ y)])
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, let, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (let ()
+ (define/with-syntax y (- (syntax-e #'x))) … …
+ #'((y …) …))]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, begin, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (begin
+ (define y (- (syntax-e #'x))) … …)
+ y])
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, begin, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (begin
+ (define/with-syntax y (- (syntax-e #'x))) … …)
+ #'((y …) …)]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, directly in the body, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (define y (- (syntax-e #'x))) … …
+ y])
+ '((-1 -2 -3) (-4 -5)))
+
+;; parse, directly in the body, define/with-syntax
+(check-equal? (syntax->datum
+ (syntax-parse #'((1 2 3) (4 5))
+ [((x …) …)
+ (define/with-syntax y (- (syntax-e #'x))) … …
+ #'((y …) …)]))
+ '((-1 -2 -3) (-4 -5)))
+
+;; #%app
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+ [([x …] [y …])
+ (vector (syntax-e #'x) … 'then (syntax-e #'y) …)])
+ #(1 2 3 then a))
+
+;; #%app, depth 2 → flat
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+ [(([x …] …) [y …])
+ (vector (syntax-e #'x) … … 'then (syntax-e #'y) …)])
+ #(1 2 3 4 5 6 then a))
+
+;; #%app, depth 2 → nested
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+ [(([x …] …) [y …])
+ (vector ((syntax-e #'x) …) … 'then (syntax-e #'y) …)])
+ #((1 2 3) (4 5 6) then a))
+
+;; #%app, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+ [([x …] [y …])
+ (vector x … 'then y …)])
+ #(1 2 3 then a))
+
+;; #%app, with auto-syntax-e behaviour, same variable iterated twice
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+ [([x …] [y …])
+ (vector x … 'then x …)])
+ #(1 2 3 then 1 2 3))
+
+;; #%app, depth 2 → flat, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+ [(([x …] …) [y …])
+ (vector x … … 'then y …)])
+ #(1 2 3 4 5 6 then a))
+
+;; #%app, depth 2 → nested, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+ [(([x …] …) [y …])
+ (vector (x …) … 'then y …)])
+ #((1 2 3) (4 5 6) then a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+ [(([x …] …) [y …])
+ (vector (x … …) 'then y …)])
+ #((1 2 3 4 5 6) then a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+ [(([x …] …) [y …])
+ (y …)])
+ '(a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+ [(([x …] …) [y …])
+ (x … …)])
+ '(1 2 3 4 5 6))
+
+;; Implicit (list _), could also be changed to an implicit (values).
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+ [(([x …] …) [y …])
+ x … …])
+ '(1 2 3 4 5 6))
+
+#|
+;; TODO: expr … inside begin and let
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (let ()
+ (list (length (syntax->list #'(x …)))
+ (+ (syntax-e #'x) 3) …)
+ …)])
+ '([3 (4 5 6)]
+ [2 (7 8)]))
+|#
+
diff --git a/test/test-ddd.rkt b/test/test-ddd.rkt
@@ -4,7 +4,15 @@
stxparse-info/parse
(only-in racket/base [... …])
rackunit
- syntax/macro-testing)
+ syntax/macro-testing
+ syntax/stx)
+
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (ddd (list (length (syntax->list #'(x …)))
+ (ddd (+ (syntax-e #'x) 3))))])
+ '([3 (4 5 6)]
+ [2 (7 8)]))
(check-equal? (syntax-case #'(1 2 3) ()
[(x …)
@@ -16,6 +24,35 @@
(ddd (+ (syntax-e #'x) 3))])
'(4 5 6))
+(check-equal? (syntax-case #'(((1 2) (3)) ((4 5 6))) ()
+ [(((x …) …) …)
+ (ddd (list (length (syntax->list #'((x …) …)))
+ (length (syntax->list #'(x … …)))
+ (ddd (ddd (- (syntax-e #'x))))))])
+ '([2 3 ((-1 -2) (-3))]
+ [1 3 ((-4 -5 -6))]))
+
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+ [([x …] [y …])
+ (ddd (+ (syntax-e #'x) 3))])
+ '(4 5 6))
+
+(check-equal? (syntax-case #'(([1 2 3] [a])) ()
+ [(([x …] [y …]) …)
+ (ddd (ddd (+ (syntax-e #'x) 3)))])
+ '((4 5 6)))
+
+;; The inner ddd should not make the outer one consider the variables actually
+;; used. This test will break if y is considered to be used, because it does not
+;; have the same shape as x anywhere, so map will complain that the lists do not
+;; have the same length.
+(check-equal? (syntax-case #'([#:xs (1 2 3) (4 5)]
+ [#:ys (a) (b) (c) (d)]) ()
+ [([#:xs (x …) …]
+ [#:ys (y …) …])
+ (ddd (ddd (+ (syntax-e #'x) 3)))])
+ '((4 5 6) (7 8)))
+
(check-exn
#rx"no pattern variables with depth > 0 were found in the body"
(λ ()
@@ -27,4 +64,11 @@
(check-equal? (syntax-parse #'(1 2 3 4)
[(x … y)
(ddd (+ (syntax-e #'x) (syntax-e #'y)))])
- '(5 6 7))
-\ No newline at end of file
+ '(5 6 7))
+
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+ [((x …) …)
+ (ddd (list (length (syntax->list #'(x …)))
+ (ddd (+ (syntax-e #'x) 3))))])
+ '([3 (4 5 6)]
+ [2 (7 8)]))
+\ No newline at end of file
