diff --git a/copy-attribute.rkt b/copy-attribute.rkt index 8cd43b3..90506da 100644 --- 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 new file mode 100644 index 0000000..d822992 --- /dev/null +++ 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 index 4e34a45..046d7a3 100644 --- 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 deleted file mode 100644 index 000eeb6..0000000 --- a/derived-valvar.rkt +++ /dev/null @@ -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 index 6c372a0..b3467da 100644 --- 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 new file mode 100644 index 0000000..596e2a5 --- /dev/null +++ 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 index ab75c59..3ecc119 100644 --- 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