suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

WIP

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-06 02:02:23 +02:00
parent 41013e5ef4
commit f4adf61aba
2 changed files with 262 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
subtemplate.rkt
View File

@ -11,6 +11,7 @@
racket/list racket/list
racket/function racket/function
phc-toolkit/untyped phc-toolkit/untyped
syntax/strip-context
srfi/13 srfi/13
racket/contract)) racket/contract))
@ -21,11 +22,43 @@
(for-syntax find-subscript-binder)) ;; for testing only (for-syntax find-subscript-binder)) ;; for testing only
(define-syntax-parameter maybe-syntax-pattern-variable-ids '()) (define-syntax-parameter maybe-syntax-pattern-variable-ids '())
(define-syntax-parameter pvar-values-id #f) (define empty-pvar-values #f)
(define-syntax-parameter pvar-values-id (make-rename-transformer
#'empty-pvar-values))
(define-syntax/parse (new-syntax-parse . rest) (define-syntax/parse (new-syntax-parse . rest)
(quasisyntax/top-loc (stx-car stx) (quasisyntax/top-loc (stx-car stx)
(let ([the-pvar-values (make-free-id-table)]) ;; HERE insert a hash table, to cache the uses
;; lifting the define-temp-ids is not likely to work, as they
;; need to define syntax pattern variables so that other macros
;; can recognize them. Instead, we only lift the values, but still
;; do the bindings around the subtemplate.
(let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
;; TODO: add a let before calling get-shadower.
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
((λ (x) #;(displayln x) x)
(cons (syntax->list
(quote-syntax
#,(~> (syntax->datum #'rest)
flatten
(filter symbol? _)
(remove-duplicates)
(map (λ (sym)
(syntax-local-get-shadower
(datum->syntax (stx-car stx)
sym)
#t))
_))
#:local))
(syntax-parameter-value
#'maybe-syntax-pattern-variable-ids)))]
[pvar-values-id (make-rename-transformer
#'the-pvar-values)])
(syntax-parse . rest)))))
(define-syntax/case (new-syntax-case . rest) ()
(quasisyntax/top-loc (stx-car stx)
(let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
(syntax-parameterize ([maybe-syntax-pattern-variable-ids (syntax-parameterize ([maybe-syntax-pattern-variable-ids
(cons '#,(remove-duplicates (cons '#,(remove-duplicates
(filter symbol? (filter symbol?
@ -35,30 +68,7 @@
#'maybe-syntax-pattern-variable-ids))] #'maybe-syntax-pattern-variable-ids))]
[pvar-values-id (make-rename-transformer [pvar-values-id (make-rename-transformer
#'the-pvar-values)]) #'the-pvar-values)])
(syntax-parse . rest)) (syntax-case . rest)))))
#;(syntax-parse option …
[clause-pat
;; HERE insert a hash table, to cache the uses
;; lifting the define-temp-ids is not likely to work, as they
;; need to define syntax pattern variables so that other macros
;; can recognize them. Instead, we only lift the values, but still
;; do the bindings around the subtemplate.
#:do (define #,(lifted-scope (syntax-local-introduce #'pvar-values)
'add)
(make-free-id-table))
. clause-rest]
…))))
(define-syntax/case (new-syntax-case . rest) ()
(quasisyntax/top-loc (stx-car stx)
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
(cons '#,(remove-duplicates
(filter symbol?
(flatten
(syntax->datum #'rest))))
(syntax-parameter-value
#'maybe-syntax-pattern-variable-ids))])
(syntax-case . rest))))
(begin-for-syntax (begin-for-syntax
(define/contract (string-suffix a b) (define/contract (string-suffix a b)
@ -78,23 +88,99 @@
[subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)]) [subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
(and subs (car subs))))) (and subs (car subs)))))
(define/contract (subscript-equal? bound binder)
(-> identifier? identifier? (or/c #f string?))
(and (let* ([binder-string (symbol->string (syntax-e binder))]
[bound-string (symbol->string (syntax-e bound))]
[binder-s (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$" binder)]
[bound-s (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$" bound)])
(equal? (car binder-s)
(car bound-s)))))
(define/contract (derived? binder)
(-> identifier? boolean?)
(displayln 'TODO-89641)
#f)
(define/contract (find-subscript-binder2a scopes bound)
(-> (listof (listof identifier?)) identifier? (listof identifier?))
(if (null? scopes)
'()
(let ()
(define scope (car scopes))
(define recur-found (find-subscript-binder2a (cdr scopes) bound))
(define found-here
(for*/list ([binder (in-list scope)]
#:when (syntax-pattern-variable?
(syntax-local-value binder
(thunk #f)))
#:when (not (derived? binder))
[subscripts (in-value (subscript-equal? bound
binder))]
#:when subscripts)
(list binder subscripts)))
(if (null? found-here)
recur-found
(append found-here recur-found)))))
(define/contract (find-subscript-binder2 scopes bound)
(-> (listof (listof identifier?))
identifier?
(or/c #f (syntax/c (cons/c syntax? (listof identifier?)))))
(define/with-syntax (binder …) (find-subscript-binder2a scopes bound))
(if (stx-null? #'(binder …))
#f
(let ()
(define depths
(stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
(unless (apply = depths)
(raise-syntax-error 'subtemplate
(format "inconsistent depths: ~a"
(syntax->list #'(binder …)))
bound))
;; generate code to check that the bindings have all the same
;; ellipsis count
(define/with-syntax check-ellipsis-count-ddd
(nest-ellipses #'(binder …) (car depths)))
(values #'(check-ellipsis-count-ddd binder …)))))
(define/contract (find-subscript-binder bound [fallback bound]) (define/contract (find-subscript-binder bound [fallback bound])
(->* (identifier?) (any/c) (or/c identifier? any/c)) (->* (identifier?) (any/c) (or/c identifier? any/c))
(define result/scopes (define result/scopes
(for/list ([scope (in-list (for/list ([scope (in-list
(syntax-parameter-value (syntax-parameter-value
#'maybe-syntax-pattern-variable-ids))]) #'maybe-syntax-pattern-variable-ids))]
[scope-depth (in-naturals)])
(define result (define result
(for*/list ([sym (in-list scope)] (for*/list ([binder (in-list scope)]
#:unless (string=? (symbol->string sym) #:when (displayln (list 'bound= (syntax-e bound)
'binder= (syntax-e binder)
'patvar? (syntax-pattern-variable? (syntax-local-value binder (thunk #f)))
'free=?/shadowed
(free-identifier=? binder
(replace-context bound binder))))
#:unless (string=? (identifier->string binder)
(identifier->string bound)) (identifier->string bound))
[binder (in-value (datum->syntax bound sym))]
[subscripts (in-value (subscript-binder? bound [subscripts (in-value (subscript-binder? bound
binder))] binder))]
#:when subscripts) #:when subscripts)
(displayln (list 'bound= (syntax-e bound)
'binder= (syntax-e binder)
'patvar? (syntax-pattern-variable? (syntax-local-value binder (thunk #f)))
'free=?/shadowed
(free-identifier=? binder
(replace-context bound binder))
subscripts))
(cons binder subscripts))) (cons binder subscripts)))
(and (not (null? result)) (and (not (null? result))
(car (argmax (∘ string-length cdr) result))))) (syntax-local-introduce
(car (argmax (∘ string-length cdr) result))))))
(displayln (list* (syntax-e bound)
(map stx-e result/scopes)
(stx-e (ormap identity result/scopes))
(map (λ (v) (map syntax-e v))
(syntax-parameter-value
#'maybe-syntax-pattern-variable-ids))))
(or (ormap identity result/scopes) (or (ormap identity result/scopes)
fallback)) fallback))
@ -106,9 +192,10 @@
(… …))))) (… …)))))
(define-syntax/case (derive bound binder stx-depth) () (define-syntax/case (derive bound binder stx-depth) ()
(define/with-syntax bound-def (replace-context #'binder #'bound))
(define depth (syntax-e #'stx-depth)) (define depth (syntax-e #'stx-depth))
(define/with-syntax bound-ddd (nest-ellipses #'bound depth)) (define/with-syntax bound-ddd (nest-ellipses #'bound-def depth))
(define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound)) (define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound-def))
(define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string (define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
(syntax-e #'tmp-id)))) (syntax-e #'tmp-id))))
(define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth)) (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
@ -127,26 +214,39 @@
;; the test above is not exactly right (zᵢ will still have the correct ;; the test above is not exactly right (zᵢ will still have the correct
;; binding), but it gives the general idea. ;; binding), but it gives the general idea.
#`(begin (define-temp-ids tmp-str binder-ddd) ;; TODO: shouldn't be called in the first place?
(define cached (free-id-table-ref! pvar-values-id (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
(quote-syntax bound) #'(begin)
#'tmp-ddd)) ((λ (x)
(define/with-syntax bound-ddd cached))) #;(newline)
;(displayln (syntax->datum x))
;(displayln (list #'bound-def #'binder (hash-ref (syntax-debug-info #'bound-def) 'context)))
x)
#`(begin (define-temp-ids tmp-str binder-ddd)
(define cached (free-id-table-ref! pvar-values-id
(quote-syntax bound-def #:local)
#'tmp-ddd))
(define/with-syntax bound-ddd cached)))))
(define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl)) (define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
(define acc '()) (define acc '())
(define (fold-process stx rec)
(syntax-case stx ()
[(id . _) (and (identifier? #'id)
(free-identifier=? #'id #'unsyntax))
stx]
[id (identifier? #'id)
(let ([binder (find-subscript-binder #'id #f)])
(when binder
(let ([depth (syntax-mapping-depth
(syntax-local-value binder))])
(set! acc `((,#'id ,binder ,depth) . ,acc))))
#'id)]
[other (rec #'other)]))
(define result (define result
(quasisyntax/top-loc #'self (quasisyntax/top-loc #'self
(#,tmpl-form (#,tmpl-form
. #,(fold-syntax (λ (stx rec) . #,(fold-syntax fold-process
(if (identifier? stx)
(let ([binder (find-subscript-binder stx #f)])
(when binder
(let ([depth (syntax-mapping-depth
(syntax-local-value binder))])
(set! acc `((,stx ,binder ,depth) . ,acc))))
stx)
(rec stx)))
#'tmpl)))) #'tmpl))))
;; Make sure that we remove duplicates, otherwise we'll get errors if we use ;; Make sure that we remove duplicates, otherwise we'll get errors if we use
;; the same derived id twice. ;; the same derived id twice.

131
test/test-subtemplate.rkt
View File

@ -2,7 +2,7 @@
(require "../subtemplate.rkt" (require "../subtemplate.rkt"
phc-toolkit/untyped phc-toolkit/untyped
rackunit) rackunit)
#|
(define-syntax (tst stx) (define-syntax (tst stx)
(syntax-case stx () (syntax-case stx ()
[(_ tt) [(_ tt)
@ -190,19 +190,118 @@
;; the test above is not exactly right (zᵢ will still have the correct ;; the test above is not exactly right (zᵢ will still have the correct
;; binding), but it gives the general idea. ;; binding), but it gives the general idea.
(syntax->datum (syntax-parse (syntax-parse #'(a b c)
(syntax-parse #'(a b c) [(xᵢ …)
[(xᵢ …) (define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
(define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))])) (quasisubtemplate (yᵢ …
(quasisubtemplate (yᵢ … ;; must be from xᵢ, not yᵢ
;; must be from xᵢ, not yᵢ #,flob
#,flob zᵢ …))])
zᵢ …))])) [(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
(check free-identifier=? #'a2 #'a3)
(check free-identifier=? #'b2 #'b3)
(check free-identifier=? #'c2 #'c3)
(check (∘ not free-identifier=?) #'a1 #'a2)
(check (∘ not free-identifier=?) #'b1 #'b2)
(check (∘ not free-identifier=?) #'c1 #'c2)])
(syntax->datum (syntax-parse (syntax-parse #'(a b c)
(syntax-parse #'(a b c) [(xᵢ …)
[(xᵢ …) (quasisubtemplate (yᵢ …
(quasisubtemplate (yᵢ … ;; must be from xᵢ, not yᵢ
;; must be from xᵢ, not yᵢ #,(syntax-parse #'d
#,(syntax-parse #'d [d (quasisubtemplate (zᵢ …))]) [d (quasisubtemplate (zᵢ …))])
zᵢ …))])) zᵢ …))])
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
(check free-identifier=? #'a2 #'a3)
(check free-identifier=? #'b2 #'b3)
(check free-identifier=? #'c2 #'c3)
(check (∘ not free-identifier=?) #'a1 #'a2)
(check (∘ not free-identifier=?) #'b1 #'b2)
(check (∘ not free-identifier=?) #'c1 #'c2)])
(syntax-parse (syntax-parse #'(a b c)
[(xᵢ …)
(quasisubtemplate (yᵢ …
;; must be from xᵢ, not yᵢ
#,(syntax-parse #'d
[d (quasisubtemplate (zᵢ …))])
#,(syntax-parse #'d
[d (quasisubtemplate (zᵢ …))])
zᵢ …))])
[(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
(check free-identifier=? #'a2 #'a3)
(check free-identifier=? #'b2 #'b3)
(check free-identifier=? #'c2 #'c3)
(check free-identifier=? #'a3 #'a4)
(check free-identifier=? #'b3 #'b4)
(check free-identifier=? #'c3 #'c4)
(check free-identifier=? #'a2 #'a4)
(check free-identifier=? #'b2 #'b4)
(check free-identifier=? #'c2 #'c4)
(check (∘ not free-identifier=?) #'a1 #'a2)
(check (∘ not free-identifier=?) #'b1 #'b2)
(check (∘ not free-identifier=?) #'c1 #'c2)])
(syntax-parse (syntax-parse #'(a b c)
[(xᵢ …)
(quasisubtemplate (yᵢ …
;; must be from xᵢ, not yᵢ
#,(syntax-parse #'d
[d (quasisubtemplate (kᵢ …))])
#,(syntax-parse #'d
[d (quasisubtemplate (kᵢ …))])
zᵢ …))])
[(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
(check free-identifier=? #'a2 #'a3)
(check free-identifier=? #'b2 #'b3)
(check free-identifier=? #'c2 #'c3)
(check (∘ not free-identifier=?) #'a1 #'a2)
(check (∘ not free-identifier=?) #'b1 #'b2)
(check (∘ not free-identifier=?) #'c1 #'c2)
(check (∘ not free-identifier=?) #'a2 #'a4)
(check (∘ not free-identifier=?) #'b2 #'b4)
(check (∘ not free-identifier=?) #'c2 #'c4)
(check (∘ not free-identifier=?) #'a3 #'a4)
(check (∘ not free-identifier=?) #'b3 #'b4)
(check (∘ not free-identifier=?) #'c3 #'c4)])
|#
(map syntax->datum
(syntax-parse #'(a b c)
[(xᵢ …)
(list (syntax-parse #'(d)
[(pᵢ …) #`(#,(quasisubtemplate (xᵢ … pᵢ … zᵢ …))
#,(quasisubtemplate (xᵢ … pᵢ … zᵢ …)))])
(syntax-parse #'(e)
[(pᵢ …) (quasisubtemplate (xᵢ … pᵢ … zᵢ …))]))]))
#;(syntax->datum
(syntax-parse #'(a b c)
[(xᵢ …)
(quasisubtemplate (yᵢ …
;; must be from xᵢ, not yᵢ
#,(syntax-parse #'(d)
[(pᵢ …) (quasisubtemplate (pᵢ … zᵢ …))])
;; GIVES WRONG ID (re-uses the one above, shouldn't):
#,(syntax-parse #'(e)
[(pᵢ …) (quasisubtemplate (pᵢ … zᵢ …))])
wᵢ …))]))
#|
(syntax-parse #'(a b c)
[(xᵢ …)
(quasisubtemplate (yᵢ …
;; must be from xᵢ, not yᵢ
#,(syntax-parse #'d
[zᵢ (quasisubtemplate (zᵢ …))])
#,(syntax-parse #'e
[zᵢ (quasisubtemplate (zᵢ …))])
zᵢ …))])
|#