suzanne.soy/subtemplate
1
0
Fork 0
Code Issues2 Pull Requests Actions Packages Projects Releases Wiki Activity

Closes 184 body which supports ddd on define

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-31 02:32:20 +01:00
parent 406698e113
commit a08c491baa
7 changed files with 366 additions and 63 deletions

9
copy-attribute.rkt
View File

@ -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)))))

105
ddd-forms.rkt Normal file
View File

@ -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 …))]))

45
ddd.rkt
View File

@ -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))]))

31
derived-valvar.rkt
View File

@ -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)))))

3
main.rkt
View File

@ -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

188
test/test-ddd-forms.rkt Normal file
View File

@ -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)]))
|#

48
test/test-ddd.rkt
View File

@ -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))
'(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)]))