WIP
This commit is contained in:
Georges Dupéron
parent
41013e5ef4
commit
f4adf61aba
188
subtemplate.rkt
188
subtemplate.rkt
|
|
@ -11,6 +11,7 @@
|
|||
racket/list
|
||||
racket/function
|
||||
phc-toolkit/untyped
|
||||
syntax/strip-context
|
||||
srfi/13
|
||||
racket/contract))
|
||||
|
||||
|
|
@ -21,11 +22,43 @@
|
|||
(for-syntax find-subscript-binder)) ;; for testing only
|
||||
|
||||
(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)
|
||||
(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
|
||||
(cons '#,(remove-duplicates
|
||||
(filter symbol?
|
||||
|
|
@ -35,30 +68,7 @@
|
|||
#'maybe-syntax-pattern-variable-ids))]
|
||||
[pvar-values-id (make-rename-transformer
|
||||
#'the-pvar-values)])
|
||||
(syntax-parse . 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))))
|
||||
(syntax-case . rest)))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define/contract (string-suffix a b)
|
||||
|
|
@ -78,23 +88,99 @@
|
|||
[subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
|
||||
(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])
|
||||
(->* (identifier?) (any/c) (or/c identifier? any/c))
|
||||
(define result/scopes
|
||||
(for/list ([scope (in-list
|
||||
(syntax-parameter-value
|
||||
#'maybe-syntax-pattern-variable-ids))])
|
||||
#'maybe-syntax-pattern-variable-ids))]
|
||||
[scope-depth (in-naturals)])
|
||||
(define result
|
||||
(for*/list ([sym (in-list scope)]
|
||||
#:unless (string=? (symbol->string sym)
|
||||
(for*/list ([binder (in-list scope)]
|
||||
#: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))
|
||||
[binder (in-value (datum->syntax bound sym))]
|
||||
[subscripts (in-value (subscript-binder? bound
|
||||
binder))]
|
||||
#: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)))
|
||||
(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)
|
||||
fallback))
|
||||
|
||||
|
|
@ -106,9 +192,10 @@
|
|||
(… …)))))
|
||||
|
||||
(define-syntax/case (derive bound binder stx-depth) ()
|
||||
(define/with-syntax bound-def (replace-context #'binder #'bound))
|
||||
(define depth (syntax-e #'stx-depth))
|
||||
(define/with-syntax bound-ddd (nest-ellipses #'bound depth))
|
||||
(define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound))
|
||||
(define/with-syntax bound-ddd (nest-ellipses #'bound-def depth))
|
||||
(define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound-def))
|
||||
(define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
|
||||
(syntax-e #'tmp-id))))
|
||||
(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
|
||||
;; binding), but it gives the general idea.
|
||||
|
||||
;; TODO: shouldn't be called in the first place?
|
||||
(if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
|
||||
#'(begin)
|
||||
((λ (x)
|
||||
#;(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)
|
||||
(quote-syntax bound-def #:local)
|
||||
#'tmp-ddd))
|
||||
(define/with-syntax bound-ddd cached)))
|
||||
(define/with-syntax bound-ddd cached)))))
|
||||
|
||||
(define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
|
||||
(define acc '())
|
||||
(define result
|
||||
(quasisyntax/top-loc #'self
|
||||
(#,tmpl-form
|
||||
. #,(fold-syntax (λ (stx rec)
|
||||
(if (identifier? stx)
|
||||
(let ([binder (find-subscript-binder stx #f)])
|
||||
(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 `((,stx ,binder ,depth) . ,acc))))
|
||||
stx)
|
||||
(rec stx)))
|
||||
(set! acc `((,#'id ,binder ,depth) . ,acc))))
|
||||
#'id)]
|
||||
[other (rec #'other)]))
|
||||
(define result
|
||||
(quasisyntax/top-loc #'self
|
||||
(#,tmpl-form
|
||||
. #,(fold-syntax fold-process
|
||||
#'tmpl))))
|
||||
;; Make sure that we remove duplicates, otherwise we'll get errors if we use
|
||||
;; the same derived id twice.
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(require "../subtemplate.rkt"
|
||||
phc-toolkit/untyped
|
||||
rackunit)
|
||||
|
||||
#|
|
||||
(define-syntax (tst stx)
|
||||
(syntax-case stx ()
|
||||
[(_ tt)
|
||||
|
|
@ -190,19 +190,118 @@
|
|||
;; the test above is not exactly right (zᵢ will still have the correct
|
||||
;; binding), but it gives the general idea.
|
||||
|
||||
(syntax->datum
|
||||
(syntax-parse #'(a b c)
|
||||
(syntax-parse (syntax-parse #'(a b c)
|
||||
[(xᵢ …)
|
||||
(define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
|
||||
(quasisubtemplate (yᵢ …
|
||||
;; must be from xᵢ, not yᵢ
|
||||
#,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)
|
||||
[(xᵢ …)
|
||||
(quasisubtemplate (yᵢ …
|
||||
;; must be from xᵢ, not yᵢ
|
||||
#,(syntax-parse #'d
|
||||
[d (quasisubtemplate (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 [d (quasisubtemplate (zᵢ …))])
|
||||
zᵢ …))]))
|
||||
#,(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ᵢ …))])
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user