From 208ad3e3218fe7ce1878f8efce2864d79600cd68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 2 Feb 2017 23:45:56 +0100 Subject: [PATCH] Closes FB case 198 override #%top to get subtemplate-like behaviour for ddd --- ddd-forms.rkt | 14 +- info.rkt | 2 +- main.rkt | 494 +---------------------- override.rkt | 4 +- scribblings/subtemplate.scrbl | 4 +- subscripts.rkt | 147 +++++++ template-subscripts.rkt | 388 ++++++++++++++++++ test/test-ddd-top.rkt | 84 ++++ test/test-subtemplate-detect-stxinfo.rkt | 12 +- test/test-subtemplate.rkt | 2 +- top-subscripts.rkt | 41 ++ 11 files changed, 682 insertions(+), 510 deletions(-) create mode 100644 subscripts.rkt create mode 100644 template-subscripts.rkt create mode 100644 test/test-ddd-top.rkt create mode 100644 top-subscripts.rkt diff --git a/ddd-forms.rkt b/ddd-forms.rkt index 3dbe0c9..58e7487 100644 --- a/ddd-forms.rkt +++ b/ddd-forms.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (provide begin define let @@ -7,7 +7,8 @@ ?? ?@) -(require subtemplate/ddd +(require racket/list + subtemplate/ddd stxparse-info/case stxparse-info/parse phc-toolkit/untyped @@ -15,7 +16,8 @@ begin let lambda define)) (prefix-in - (only-in stxparse-info/case define/with-syntax)) - (for-syntax racket/list + (for-syntax racket/base + racket/list stxparse-info/parse stxparse-info/parse/experimental/template phc-toolkit/untyped) @@ -104,10 +106,12 @@ [{~and (_ fn arg:arg …) {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a … ;#'(#%app apply fn (#%app append arg.expanded …)) - #'(#%app apply fn (#%app splice-append arg.expanded …))] + (syntax/top-loc this-syntax + (#%app apply fn (#%app splice-append arg.expanded …)))] [(_ arg:arg …) ;; shorthand for list creation ;#'(#%app apply list (#%app append arg.expanded …)) - #'(#%app apply list (#%app splice-append arg.expanded …))])) + (syntax/top-loc this-syntax + (#%app apply list (#%app splice-append arg.expanded …)))])) (define (splice-append . l*) (splice-append* l*)) (define (splice-append* l*) diff --git a/info.rkt b/info.rkt index d8c9079..5c45faa 100644 --- a/info.rkt +++ b/info.rkt @@ -13,4 +13,4 @@ (define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library)))) (define pkg-desc "Description Here") (define version "0.0") -(define pkg-authors '(georges)) +(define pkg-authors '("Georges Dupéron")) diff --git a/main.rkt b/main.rkt index b3467da..7bc35af 100644 --- a/main.rkt +++ b/main.rkt @@ -1,493 +1 @@ -#lang racket - -(require racket/require - phc-toolkit/untyped - phc-toolkit/untyped-only/syntax-parse - racket/stxparam - stxparse-info/parse - stxparse-info/case - stxparse-info/current-pvars - stxparse-info/parse/experimental/template - (prefix-in - stxparse-info/parse/private/residual) - (prefix-in dbg: stxparse-info/parse/private/runtime) - syntax/id-table - (subtract-in racket/syntax stxparse-info/case) - "copy-attribute.rkt" - (for-syntax "patch-arrows.rkt" - racket/format - stxparse-info/parse - racket/private/sc - racket/syntax - racket/list - racket/function - phc-toolkit/untyped - syntax/strip-context - srfi/13 - (subtract-in racket/string srfi/13) - syntax/contract - racket/contract)) - -(provide subtemplate - quasisubtemplate) - -(define derived-valvar-cache (make-weak-hash)) - -(begin-for-syntax - (define/contract (string-suffix a b) - (-> string? string? string?) - (define suffix-length (string-suffix-length a b)) - (substring a - (- (string-length a) suffix-length))) - - (define/contract (subscript-binder? bound binder) - (-> identifier? identifier? (or/c #f string?)) - (and (syntax-pattern-variable? - (syntax-local-value binder - (thunk #f))) - (let* ([bound-string (symbol->string (syntax-e bound))] - [binder-string (symbol->string (syntax-e binder))] - [suffix (string-suffix bound-string binder-string)] - [subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)]) - (and subs (car subs))))) - - (define/contract (extract-subscripts id) - (-> identifier? string?) - (car (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$" - (symbol->string (syntax-e id))))) - - (define/contract (subscript-equal? bound binder) - (-> identifier? identifier? (or/c #f string?)) - (let* ([binder-subscripts (extract-subscripts binder)] - [bound-subscripts (extract-subscripts bound)]) - (and (string=? binder-subscripts bound-subscripts) - (not (string=? binder-subscripts "")) - binder-subscripts))) - - (define/contract (drop-subscripts id) - (-> identifier? identifier?) - (let* ([str (symbol->string (syntax-e id))] - [sub (extract-subscripts id)] - [new-str (substring str 0 (- (string-length str) - (string-length sub)))]) - (datum->syntax id (string->symbol new-str) id id))) - - (define/contract (nest-ellipses stx n) - (-> syntax? exact-nonnegative-integer? syntax?) - (if (= n 0) - stx - #`(#,(nest-ellipses stx (sub1 n)) - (… …)))) - - (define/contract (find-subscript-binder bound) - (-> identifier? - (or/c #f (list/c identifier? ; bound - (syntax/c (listof identifier?)) ; binders - (syntax/c (listof identifier?)) ; unique-at-runtime ids - exact-nonnegative-integer?))) ; ellipsis-depth - - (let/cc return - ;; EARLY RETURN (already a pattern variable) - (when (syntax-pattern-variable? - (syntax-local-value bound (thunk #f))) - (return #f)) - - (define/with-syntax ([binder . unique-at-runtime-id] …) - (filter (compose (conjoin identifier? - (λ~> (syntax-local-value _ (thunk #f)) - syntax-pattern-variable?) - ;; force call syntax-local-value to prevent - ;; ambiguous bindings, as syntax-local-value - ;; triggers an error for those. - ;; Must be done before the free-identifier=? - ;; which just returns #false - (λ~> (datum->syntax _ (syntax-e bound)) - (syntax-local-value _ (thunk #f)) - (thunk* #t)) ;; ok if no error. - (λ~> (datum->syntax _ (syntax-e bound)) - (free-identifier=? _ bound)) - (λ~> (subscript-equal? bound _))) - car) - (current-pvars+unique))) - - ;; Or write it as: - - #;(define/with-syntax ([binder . unique-at-runtime] …) - (for/list ([binder (current-pvars+unique)] - #:when (identifier? (car binder)) - #:when (syntax-pattern-variable? - (syntax-local-value (car binder) (thunk #f))) - ;; force call syntax-local-value to prevent ambiguous - ;; bindings, as syntax-local-value triggers an error for - ;; those. - ;; Must be done before the free-identifier=? which just - ;; returns #false - #:when (begin - (syntax-local-value - (datum->syntax _ (syntax-e bound)) - (thunk #f)) - #t) ;; ok if no error. - #:when (free-identifier=? (datum->syntax (car binder) - (syntax-e bound)) - bound) - #:when (subscript-equal? bound (car binder))) - binder)) - - ;; EARLY RETURN (no candidate binders found) - (when (stx-null? #'(binder …)) - (return #f)) - - (define depths - (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …))) - - ;; EARLY ERROR (inconsistent depths) - (unless (or (< (length depths) 2) (apply = depths)) - (car depths) - (raise-syntax-error 'subtemplate - (format "inconsistent depths: ~a" - (syntax->list #'(binder …))) - bound)) - - ;; FINAL RETURN (list of same-depth binders + their depth) - (return (list bound - #'(binder …) - #'(unique-at-runtime-id …) - (car depths)))))) - -;; Checks that all the given attribute values have the same structure. -;; -;; ellipsis-count/c works with the value of pattern variables and of attributes -;; too, including those missing (optional) elements in the lists, at any level. -;; -;; The lists must have the same lengths across all attribute values, including -;; the missing #f elements. -;; -;; If same-shape is #true, a #f in one attribute value implies #f in all other -;; attribute values at the same position. The same-shape check is not -;; performed on the bottommost #f values (as they do not influence the shape of -;; the tree). -(define/contract (ellipsis-count/c depth - [bottom-predicate any/c] - #:same-shape [same-shape #f]) - (->* {exact-nonnegative-integer?} - {flat-contract? - #:same-shape boolean?} - flat-contract?) - ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself - (define (recur/c sublists) - ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape) - sublists)) - (flat-named-contract - (apply build-compound-type-name - (list* 'ellipsis-count/c depth bottom-predicate - (if same-shape - (list '#:same-shape same-shape) - (list)))) - (λ (l*) - (true? - (and (list? l*) - (if (and same-shape (> depth 0)) - (or (andmap false? l*) ;; all #f - (andmap identity l*)) ;; all non-#f - #t) - (let ([l* (filter identity l*)]) - (if (= depth 0) - (andmap bottom-predicate l*) - (let ([lengths (map length l*)]) - (and (or (< (length lengths) 2) (apply = lengths)) - (or (empty? l*) - (apply andmap - (λ sublists - (recur/c sublists)) - l*))))))))))) - -(define/contract (map-merge-stx-depth f l* depth) - (->i {[f (-> (listof any/c) any/c)] - [l* (depth) (ellipsis-count/c depth any/c)] - [depth exact-nonnegative-integer?]} - {result (depth l*) - (λ (r) ((ellipsis-count/c depth) (cons r l*)))}) - (let ([l* (filter identity l*)]) - (if (= depth 0) - (f l*) - (if (empty? l*) - #f - (apply map - (λ sublists - (map-merge-stx-depth f - sublists - (sub1 depth))) - l*))))) - -(define-for-syntax (sub*template self-form tmpl-form) - (syntax-parser - [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}} - {~optkw #:props (prop:id ...)} - ;; #: marks end of options (so that we can have implicit ?@ later) - {~optional #:} - tmpl) - (unless (attribute force-no-stxinfo) - (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser - syntax-case define/with-syntax with-syntax))]) - (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))] - [good (datum->syntax #'here sym)]) - (when (or (not (identifier-binding shadower)) - (not (free-identifier=? shadower good))) - (raise-syntax-error self-form - (~a sym (if (identifier-binding shadower) - (~a " resolves to the official " - sym ",") - " seems undefined,") - " but subtemplate needs the patched" - " version from stxparse-info. Use (require" - " stxparse-info/parse) and (require" - " stxparse-info/case) to fix this. This" - " message can be disabled with (" self-form - " #:force-no-stxinfo …), if you know what" - " you're doing.")))))) - - (define acc '()) - - ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ - ;; bindings - (define (fold-process stx rec) - (syntax-case stx () - [(id . _) (and (identifier? #'id) - (free-identifier=? #'id #'unsyntax)) - stx] - [id (identifier? #'id) - (let ([binders+info (find-subscript-binder #'id)]) - (when binders+info - (set! acc (cons binders+info acc))) - #'id)] - [other (rec #'other)])) - ;; Process the syntax, extract the derived bindings into acc - ;; Does not take zᵢ identifiers generated by template metafunctions into - ;; account for now. - (fold-syntax fold-process #'tmpl) - - ;; define the result, which looks like (template . tmpl) or - ;; like (quasitemplate . tmpl) - (define result - (quasisyntax/top-loc #'self - (#,tmpl-form tmpl - #,@(if (attribute props) #'(#:props (prop ...)) #'())))) - ;; Make sure that we remove duplicates, otherwise we'll get errors if we - ;; define the same derived id twice. - (define/with-syntax ([bound - (binder …) - unique-at-runtime-ids - ellipsis-depth] - …) - (remove-duplicates acc bound-identifier=? #:key car)) - - (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate)) - - #`(let-values () - (define-values (whole-form-id) (quote-syntax #,this-syntax)) - (derive - bound (binder …) unique-at-runtime-ids ellipsis-depth whole-form-id) - … - (let-values () - ;; check that all the binders for a given bound are compatible. - ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) … - ;; actually call template or quasitemplate - #,result))])) - -(define-syntax subtemplate - (sub*template 'subtemplate #'template)) -(define-syntax quasisubtemplate - (sub*template 'quasisubtemplate #'quasitemplate)) - -(define/contract (multi-hash-ref! h keys to-set) - ;; This assumes that the hash does not get mutated during the execution of - ;; this function. - (-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?) - (listof symbol?) - any/c - any/c) - (define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f)) - to-set)) - ;; Set the existing value (or new to-set if none) on all keys which - ;; are not present in the hash table. - (for ([k (in-list keys)]) (hash-ref! h k val)) - val) - -(define formattable/c (or/c number? string? symbol? bytes?)) - -(define/contract - (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form) - (->i {[depth exact-nonnegative-integer?] - [bound identifier?] - [binder₀ identifier?] - [format (-> formattable/c string?)] - [l* (depth) (listof (attribute-val/c depth))] - [attribute-names (l*) (and/c (listof identifier?) - (λ (a) (= (length l*) (length a))))] - [whole-form syntax?]} - #:pre (l* depth attribute-names whole-form bound) - (if ((ellipsis-count/c depth) l*) - #t - (raise-syntax-error - (syntax-case whole-form () - [(self . _) (syntax-e #'self)] - [_ 'subtemplate]) - "incompatible ellipsis match counts for subscripted variables:" - whole-form - bound - attribute-names)) - {result (depth l*) - (and/c (attribute-val/c depth identifier?) - (λ (r) ((ellipsis-count/c depth) (cons r l*))))}) - - - (define (gen bottom*) - (define v - (let ([vs (filter-map (λ (v) - (cond [(formattable/c v) v] - [(formattable/c (syntax-e v)) (syntax-e v)] - [else #f])) - bottom*)]) - (if (empty? vs) - (syntax-e (generate-temporary binder₀)) - (car vs)))) - (datum->syntax ((make-syntax-introducer) bound) - (string->symbol (format v)))) - - (map-merge-stx-depth gen l* depth)) - -(define-syntax/case (derive bound - (binder₀ binderᵢ …) - (unique-at-runtime-idᵢ …) - ellipsis-depth - whole-form-id) () - (define depth (syntax-e #'ellipsis-depth)) - (define/with-syntax bound-ddd (nest-ellipses #'bound depth)) - (define/with-syntax tmp-id - (format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound))) - (define/with-syntax tmp-str - (datum->syntax #'tmp-id - (symbol->string - (syntax-e - (format-id #'here "~~a/~a" (drop-subscripts #'bound)))))) - (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth)) - (define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth)) - - ;; Draw arrows in DrRacket. - (with-arrows - (define subscripts (subscript-equal? #'bound #'binder₀)) - (define bound-id-str (identifier->string #'bound)) - (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))]) - (define binder-id-str (identifier->string binder)) - (record-sub-range-binders! (vector #'bound - (- (string-length bound-id-str) - (string-length subscripts)) - (string-length subscripts) - binder - (- (string-length binder-id-str) - (string-length subscripts)) - (string-length subscripts)))) - #;(define binder0-id-str (identifier->string #'binder0)) - #;(record-sub-range-binders! (vector #'bound - (- (string-length bound-id-str) - (string-length subscripts)) - (string-length subscripts) - #'binder0 - (- (string-length binder0-id-str) - (string-length subscripts)) - (string-length subscripts))) - (define/with-syntax temp-derived (generate-temporary #'bound)) - (define/with-syntax temp-valvar (generate-temporary #'bound)) - (define/with-syntax temp-cached (generate-temporary #'bound)) - (define/with-syntax temp-generated (generate-temporary #'bound)) - (define/with-syntax temp-id-table (generate-temporary #'bound)) - ;; HERE: cache the define-temp-ids in the free-id-table, and make sure - ;; that we retrieve the cached ones, so that two subtemplate within the same - ;; syntax-case or syntax-parse clause use the same derived ids. - ;; - ;; We mark specially those bindings bound by (derive …) so that they are - ;; not seen as original bindings in nested subtemplates (e.g. with an - ;; "unsyntax"), otherwise that rule may not hold anymore, e.g. - ;; (syntax-parse #'(a b c) - ;; [(xᵢ …) - ;; (quasisubtemplate (yᵢ … - ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ - ;; zᵢ …))]) - ;; the test above is not exactly right (zᵢ will still have the correct - ;; binding), but it gives the general idea. - #`(begin - (define-values (temp-generated) - (generate-nested-ids 'ellipsis-depth - (quote-syntax bound) - (quote-syntax binder₀) - (λ (v) (format tmp-str v)) - (list (attribute* binder₀) - (attribute* binderᵢ) - …) - (list (quote-syntax binder₀) - (quote-syntax binderᵢ) - …) - whole-form-id)) - (define-values (temp-id-table) - (multi-hash-ref! derived-valvar-cache - (list unique-at-runtime-idᵢ - …) - (make-free-id-table))) - (define-values (temp-cached) - (free-id-table-ref! temp-id-table - (quote-syntax bound) - temp-generated)) - ;; TODO: we should check that if the hash-table access worked, - ;; any new pvars are compatible with the old ones on which the cache is - ;; based (in the sense of "no new non-#f positions") - - ;; Check that all derived pvars for this subscript from all binders - ;; have the same shape, i.e. we wouldn't want some elements to be missing - ;; (as in ~optional) at some position from one derived pvar, but not from - ;; others. This check implies that the original binder used did not - ;; introduce new elements compared to the binders used for other derived - ;; pvars, e.g: - ;; (syntax-parse #'([1 2 3] #f) - ;; [({~and {~or (xᵢ ...) #f}} ...) - ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _) - ;; (syntax-case #'([a b c] [d e]) () - ;; ;; introduces elements [d e] which were unknown when yᵢ was - ;; ;; generated: - ;; [((wᵢ ...) ...) - ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is - ;; ;; inconsistent with the shape of yᵢ. - ;; (subtemplate ({?? (zᵢ ...) _} ...))])]) - ;; The check must also compare temp-generated, even if it was not - ;; assigned to #'bound, so that it also cathes the error if we replace - ;; zᵢ with yᵢ in the example above. - (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t) - (cons temp-generated - (free-id-table-map temp-id-table (λ (k v) v)))) - ;; TODO: For now this will just blow up, a better error message would - ;; be nice. Especially saying which one failed. - (raise-syntax-error - 'sublist - (format (string-append - "some derived variables do not have the same ellipsis" - " shape\n" - " depth: ~a\n" - " attributes...:\n" - " ~a\n" - " attribute ~a if it were generated here...:\n" - " ~a") - 'ellipsis-depth - (string-join (free-id-table-map - temp-id-table - (λ (k v) - (format "~a => ~a" - (syntax-e k) - (syntax->datum - (datum->syntax #f v))))) - "\n ") - 'bound - (syntax->datum - (datum->syntax #f temp-generated))) - (quote-syntax whole-form-id) - (quote-syntax bound) - (free-id-table-map temp-id-table (λ (k v) k)))) - - (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t)))) +#lang racket/base diff --git a/override.rkt b/override.rkt index 5539969..19b9705 100644 --- a/override.rkt +++ b/override.rkt @@ -1,6 +1,6 @@ #lang racket (require racket/require - (rename-in subtemplate + (rename-in subtemplate/template-subscripts [subtemplate syntax] [quasisubtemplate quasisyntax]) stxparse-info/parse @@ -11,7 +11,7 @@ quasitemplate/loc) stxparse-info/case (subtract-in racket/syntax stxparse-info/case)) -(provide (all-from-out subtemplate +(provide (all-from-out subtemplate/template-subscripts stxparse-info/parse stxparse-info/parse/experimental/template stxparse-info/case diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl index 108aaba..f2ca6f0 100644 --- a/scribblings/subtemplate.scrbl +++ b/scribblings/subtemplate.scrbl @@ -1,13 +1,13 @@ #lang scribble/manual @require[scriblib/footnote - @for-label[subtemplate + @for-label[subtemplate/template-subscripts syntax/parse/experimental/template racket/base]] @title{Subtemplate} @author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]] -@defmodule[subtemplate] +@defmodule[subtemplate/template-subscripts] @defform*[{(subtemplate template) (subtemplate template #:properties (prop ...))} diff --git a/subscripts.rkt b/subscripts.rkt new file mode 100644 index 0000000..3bd0f31 --- /dev/null +++ b/subscripts.rkt @@ -0,0 +1,147 @@ +#lang racket/base + +(provide subscript-equal? + drop-subscripts + find-subscript-binders) + +(require (for-template stxparse-info/current-pvars) + racket/private/sc + racket/function + racket/list + phc-toolkit/untyped + racket/contract + racket/string + racket/syntax) + +(define/contract (extract-subscripts id) + (-> identifier? string?) + (cadr (regexp-match #px".(_.+|[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*)$" + (symbol->string (syntax-e id))))) + +(define/contract (string-replace* str from* to*) + (->i ([str string?] + [from* (listof string?)] + [to* (from*) + (and/c (listof string?) + (λ (to*) (= (length from*) (length to*))))]) + [range string?]) + (if (null? from*) + str + (string-replace* (string-replace str (car from*) (car to*)) + (cdr from*) + (cdr to*)))) + + +(define/contract (normalize-subscripts sub) + (-> string? string?) + (if (or (string=? sub "") + (equal? (string-ref sub 0) #\_)) + sub + (string-append + "_" + (string-replace* sub + (map symbol->string + '(ₐ ₑ ₕ ᵢ ⱼ ₖ ₗ ₘ ₙ ₒ ₚ ᵣ ₛ ₜ ᵤ ᵥ ₓ ᵦ ᵧ ᵨ ᵩ ᵪ)) + (map symbol->string + '(A E H I J K L M N O P R S T U V X β γ ρ ϕ χ)))))) + +(define/contract (subscript-equal? bound binder) + (-> identifier? identifier? (or/c #f string?)) + (let* ([binder-subscripts (normalize-subscripts (extract-subscripts binder))] + [bound-subscripts (normalize-subscripts (extract-subscripts bound))]) + (and (string=? binder-subscripts bound-subscripts) + (not (string=? binder-subscripts "")) + binder-subscripts))) + +(define/contract (drop-subscripts id) + (-> identifier? identifier?) + (let* ([str (symbol->string (syntax-e id))] + [sub (extract-subscripts id)] + [new-str (substring str 0 (- (string-length str) + (string-length sub)))]) + (datum->syntax id (string->symbol new-str) id id))) + +(define (filter-current-pvars bound) + (remove-duplicates + (map (λ (pv+u) (cons (syntax-local-get-shadower (car pv+u)) + (cdr pv+u))) + (filter (compose (conjoin identifier? + (λ~> (syntax-local-value _ (thunk #f)) + syntax-pattern-variable?) + ;; force call syntax-local-value to prevent + ;; ambiguous bindings, as syntax-local-value + ;; triggers an error for those. + ;; Must be done before the free-identifier=? + ;; which just returns #false + (λ~> (datum->syntax _ (syntax-e bound)) + (syntax-local-value _ (thunk #f)) + (thunk* #t)) ;; ok if no error. + (λ~> (datum->syntax _ (syntax-e bound)) + (free-identifier=? _ bound)) + (λ~> (subscript-equal? bound _))) + car) + (current-pvars+unique))) + bound-identifier=? + #:key car)) + +;; Or write it as: +#;(define (filter-current-pvars bound) + (for/list ([binder (current-pvars+unique)] + #:when (identifier? (car binder)) + #:when (syntax-pattern-variable? + (syntax-local-value (car binder) (thunk #f))) + ;; force call syntax-local-value to prevent ambiguous + ;; bindings, as syntax-local-value triggers an error for + ;; those. + ;; Must be done before the free-identifier=? which just + ;; returns #false + #:when (begin + (syntax-local-value + (datum->syntax _ (syntax-e bound)) + (thunk #f)) + #t) ;; ok if no error. + #:when (free-identifier=? (datum->syntax (car binder) + (syntax-e bound)) + bound) + #:when (subscript-equal? bound (car binder))) + binder)) + +(define/contract (find-subscript-binders bound) + (-> identifier? + (or/c #f (list/c identifier? ; bound + (syntax/c (listof identifier?)) ; binders + (syntax/c (listof identifier?)) ; unique-at-runtime ids + exact-nonnegative-integer?))) ; ellipsis-depth + + (let/cc return + ;; EARLY RETURN (already a pattern variable) + (when (syntax-pattern-variable? + (syntax-local-value bound (thunk #f))) + (return #f)) + + (define/with-syntax ([binder . unique-at-runtime-id] …) + (filter-current-pvars bound)) + + ;; EARLY RETURN (no candidate binders found) + (when (stx-null? #'(binder …)) + (return #f)) + + (define depths + (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …))) + + ;; EARLY ERROR (inconsistent depths) + (unless (or (< (length depths) 2) (apply = depths)) + (car depths) + (raise-syntax-error 'subtemplate + (format "inconsistent depths: ~a" + (map cons + (syntax->datum #'(binder …)) + depths)) + bound + (syntax->list #'(binder …)))) + + ;; FINAL RETURN (list of same-depth binders + their depth) + (return (list bound + #'(binder …) + #'(unique-at-runtime-id …) + (car depths))))) diff --git a/template-subscripts.rkt b/template-subscripts.rkt new file mode 100644 index 0000000..e981e68 --- /dev/null +++ b/template-subscripts.rkt @@ -0,0 +1,388 @@ +#lang racket/base + +(require racket/require + racket/list + racket/string + racket/function + racket/contract + phc-toolkit/untyped + phc-toolkit/untyped-only/syntax-parse + racket/stxparam + stxparse-info/parse + stxparse-info/case + stxparse-info/current-pvars + stxparse-info/parse/experimental/template + (prefix-in - stxparse-info/parse/private/residual) + (prefix-in dbg: stxparse-info/parse/private/runtime) + syntax/id-table + (subtract-in racket/syntax stxparse-info/case) + "copy-attribute.rkt" + (for-syntax (subtract-in racket/base srfi/13) + "patch-arrows.rkt" + "subscripts.rkt" + racket/format + stxparse-info/parse + racket/private/sc + racket/syntax + racket/list + racket/function + phc-toolkit/untyped + syntax/strip-context + srfi/13 + (subtract-in racket/string srfi/13) + syntax/contract + racket/contract)) + +(provide subtemplate + quasisubtemplate + derive + ellipsis-count/c) ;; TODO: don't provide this here. + +(define derived-valvar-cache (make-weak-hash)) + +(begin-for-syntax + (define/contract (nest-ellipses stx n) + (-> syntax? exact-nonnegative-integer? syntax?) + (if (= n 0) + stx + #`(#,(nest-ellipses stx (sub1 n)) + (… …))))) + +;; Checks that all the given attribute values have the same structure. +;; +;; ellipsis-count/c works with the value of pattern variables and of attributes +;; too, including those missing (optional) elements in the lists, at any level. +;; +;; The lists must have the same lengths across all attribute values, including +;; the missing #f elements. +;; +;; If same-shape is #true, a #f in one attribute value implies #f in all other +;; attribute values at the same position. The same-shape check is not +;; performed on the bottommost #f values (as they do not influence the shape of +;; the tree). +(define/contract (ellipsis-count/c depth + [bottom-predicate any/c] + #:same-shape [same-shape #f]) + (->* {exact-nonnegative-integer?} + {flat-contract? + #:same-shape boolean?} + flat-contract?) + ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself + (define (recur/c sublists) + ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape) + sublists)) + (flat-named-contract + (apply build-compound-type-name + (list* 'ellipsis-count/c depth bottom-predicate + (if same-shape + (list '#:same-shape same-shape) + (list)))) + (λ (l*) + (true? + (and (list? l*) + (if (and same-shape (> depth 0)) + (or (andmap false? l*) ;; all #f + (andmap identity l*)) ;; all non-#f + #t) + (let ([l* (filter identity l*)]) + (if (= depth 0) + (andmap bottom-predicate l*) + (let ([lengths (map length l*)]) + (and (or (< (length lengths) 2) (apply = lengths)) + (or (empty? l*) + (apply andmap + (λ sublists + (recur/c sublists)) + l*))))))))))) + +(define/contract (map-merge-stx-depth f l* depth) + (->i {[f (-> (listof any/c) any/c)] + [l* (depth) (ellipsis-count/c depth any/c)] + [depth exact-nonnegative-integer?]} + {result (depth l*) + (λ (r) ((ellipsis-count/c depth) (cons r l*)))}) + (let ([l* (filter identity l*)]) + (if (= depth 0) + (f l*) + (if (empty? l*) + #f + (apply map + (λ sublists + (map-merge-stx-depth f + sublists + (sub1 depth))) + l*))))) + +(define-for-syntax (sub*template self-form tmpl-form) + (syntax-parser + [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}} + {~optkw #:props (prop:id ...)} + ;; #: marks end of options (so that we can have implicit ?@ later) + {~optional #:} + tmpl) + (unless (attribute force-no-stxinfo) + (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser + syntax-case define/with-syntax with-syntax))]) + (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))] + [good (datum->syntax #'here sym)]) + (when (or (not (identifier-binding shadower)) + (not (free-identifier=? shadower good))) + (raise-syntax-error self-form + (~a sym (if (identifier-binding shadower) + (~a " resolves to the official " + sym ",") + " seems undefined,") + " but subtemplate needs the patched" + " version from stxparse-info. Use (require" + " stxparse-info/parse) and (require" + " stxparse-info/case) to fix this. This" + " message can be disabled with (" self-form + " #:force-no-stxinfo …), if you know what" + " you're doing.")))))) + + (define acc '()) + + ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ + ;; bindings + (define (fold-process stx rec) + (syntax-case stx () + [(id . _) (and (identifier? #'id) + (free-identifier=? #'id #'unsyntax)) + stx] + [id (identifier? #'id) + (let ([binders+info (find-subscript-binders #'id)]) + (when binders+info + (set! acc (cons binders+info acc))) + #'id)] + [other (rec #'other)])) + ;; Process the syntax, extract the derived bindings into acc + ;; Does not take zᵢ identifiers generated by template metafunctions into + ;; account for now. + (fold-syntax fold-process #'tmpl) + + ;; define the result, which looks like (template . tmpl) or + ;; like (quasitemplate . tmpl) + (define result + (quasisyntax/top-loc #'self + (#,tmpl-form tmpl + #,@(if (attribute props) #'(#:props (prop ...)) #'())))) + ;; Make sure that we remove duplicates, otherwise we'll get errors if we + ;; define the same derived id twice. + (define/with-syntax ([bound + (binder …) + unique-at-runtime-ids + ellipsis-depth] + …) + (remove-duplicates acc bound-identifier=? #:key car)) + + (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate)) + + #`(let-values () + (define-values (whole-form-id) (quote-syntax #,this-syntax)) + (derive + bound (binder …) unique-at-runtime-ids ellipsis-depth whole-form-id) + … + (let-values () + ;; check that all the binders for a given bound are compatible. + ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) … + ;; actually call template or quasitemplate + #,result))])) + +(define-syntax subtemplate + (sub*template 'subtemplate #'template)) +(define-syntax quasisubtemplate + (sub*template 'quasisubtemplate #'quasitemplate)) + +(define/contract (multi-hash-ref! h keys to-set) + ;; This assumes that the hash does not get mutated during the execution of + ;; this function. + (-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?) + (listof symbol?) + any/c + any/c) + (define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f)) + to-set)) + ;; Set the existing value (or new to-set if none) on all keys which + ;; are not present in the hash table. + (for ([k (in-list keys)]) (hash-ref! h k val)) + val) + +(define formattable/c (or/c number? string? symbol? bytes?)) + +(define/contract + (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form) + (->i {[depth exact-nonnegative-integer?] + [bound identifier?] + [binder₀ identifier?] + [format (-> formattable/c string?)] + [l* (depth) (listof (attribute-val/c depth))] + [attribute-names (l*) (and/c (listof identifier?) + (λ (a) (= (length l*) (length a))))] + [whole-form syntax?]} + #:pre (l* depth attribute-names whole-form bound) + (if ((ellipsis-count/c depth) l*) + #t + (raise-syntax-error + (syntax-case whole-form () + [(self . _) (syntax-e #'self)] + [_ 'subtemplate]) + "incompatible ellipsis match counts for subscripted variables:" + whole-form + bound + attribute-names)) + {result (depth l*) + (and/c (attribute-val/c depth identifier?) + (λ (r) ((ellipsis-count/c depth) (cons r l*))))}) + + + (define (gen bottom*) + (define v + (let ([vs (filter-map (λ (v) + (cond [(formattable/c v) v] + [(formattable/c (syntax-e v)) (syntax-e v)] + [else #f])) + bottom*)]) + (if (empty? vs) + (syntax-e (generate-temporary binder₀)) + (car vs)))) + (datum->syntax ((make-syntax-introducer) bound) + (string->symbol (format v)))) + + (map-merge-stx-depth gen l* depth)) + +(define-syntax/case (derive bound + (binder₀ binderᵢ …) + (unique-at-runtime-idᵢ …) + ellipsis-depth + whole-form-id) () + (define depth (syntax-e #'ellipsis-depth)) + (define/with-syntax bound-ddd (nest-ellipses #'bound depth)) + (define/with-syntax tmp-id + (format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound))) + (define/with-syntax tmp-str + (datum->syntax #'tmp-id + (symbol->string + (syntax-e + (format-id #'here "~~a/~a" (drop-subscripts #'bound)))))) + (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth)) + (define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth)) + + ;; Draw arrows in DrRacket. + (with-arrows + (define subscripts (subscript-equal? #'bound #'binder₀)) + (define bound-id-str (identifier->string #'bound)) + (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))]) + (define binder-id-str (identifier->string binder)) + (record-sub-range-binders! (vector #'bound + (- (string-length bound-id-str) + (string-length subscripts)) + (string-length subscripts) + binder + (- (string-length binder-id-str) + (string-length subscripts)) + (string-length subscripts)))) + #;(define binder0-id-str (identifier->string #'binder0)) + #;(record-sub-range-binders! (vector #'bound + (- (string-length bound-id-str) + (string-length subscripts)) + (string-length subscripts) + #'binder0 + (- (string-length binder0-id-str) + (string-length subscripts)) + (string-length subscripts))) + (define/with-syntax temp-derived (generate-temporary #'bound)) + (define/with-syntax temp-valvar (generate-temporary #'bound)) + (define/with-syntax temp-cached (generate-temporary #'bound)) + (define/with-syntax temp-generated (generate-temporary #'bound)) + (define/with-syntax temp-id-table (generate-temporary #'bound)) + ;; HERE: cache the define-temp-ids in the free-id-table, and make sure + ;; that we retrieve the cached ones, so that two subtemplate within the same + ;; syntax-case or syntax-parse clause use the same derived ids. + ;; + ;; We mark specially those bindings bound by (derive …) so that they are + ;; not seen as original bindings in nested subtemplates (e.g. with an + ;; "unsyntax"), otherwise that rule may not hold anymore, e.g. + ;; (syntax-parse #'(a b c) + ;; [(xᵢ …) + ;; (quasisubtemplate (yᵢ … + ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ + ;; zᵢ …))]) + ;; the test above is not exactly right (zᵢ will still have the correct + ;; binding), but it gives the general idea. + #`(begin + (define-values (temp-generated) + (generate-nested-ids 'ellipsis-depth + (quote-syntax bound) + (quote-syntax binder₀) + (λ (v) (format tmp-str v)) + (list (attribute* binder₀) + (attribute* binderᵢ) + …) + (list (quote-syntax binder₀) + (quote-syntax binderᵢ) + …) + whole-form-id)) + (define-values (temp-id-table) + (multi-hash-ref! derived-valvar-cache + (list unique-at-runtime-idᵢ + …) + (make-free-id-table))) + (define-values (temp-cached) + (free-id-table-ref! temp-id-table + (quote-syntax bound) + temp-generated)) + ;; TODO: we should check that if the hash-table access worked, + ;; any new pvars are compatible with the old ones on which the cache is + ;; based (in the sense of "no new non-#f positions") + + ;; Check that all derived pvars for this subscript from all binders + ;; have the same shape, i.e. we wouldn't want some elements to be missing + ;; (as in ~optional) at some position from one derived pvar, but not from + ;; others. This check implies that the original binder used did not + ;; introduce new elements compared to the binders used for other derived + ;; pvars, e.g: + ;; (syntax-parse #'([1 2 3] #f) + ;; [({~and {~or (xᵢ ...) #f}} ...) + ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _) + ;; (syntax-case #'([a b c] [d e]) () + ;; ;; introduces elements [d e] which were unknown when yᵢ was + ;; ;; generated: + ;; [((wᵢ ...) ...) + ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is + ;; ;; inconsistent with the shape of yᵢ. + ;; (subtemplate ({?? (zᵢ ...) _} ...))])]) + ;; The check must also compare temp-generated, even if it was not + ;; assigned to #'bound, so that it also cathes the error if we replace + ;; zᵢ with yᵢ in the example above. + (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t) + (cons temp-generated + (free-id-table-map temp-id-table (λ (k v) v)))) + ;; TODO: For now this will just blow up, a better error message would + ;; be nice. Especially saying which one failed. + (raise-syntax-error + 'sublist + (format (string-append + "some derived variables do not have the same ellipsis" + " shape\n" + " depth: ~a\n" + " attributes...:\n" + " ~a\n" + " attribute ~a if it were generated here...:\n" + " ~a") + 'ellipsis-depth + (string-join (free-id-table-map + temp-id-table + (λ (k v) + (format "~a => ~a" + (syntax-e k) + (syntax->datum + (datum->syntax #f v))))) + "\n ") + 'bound + (syntax->datum + (datum->syntax #f temp-generated))) + (quote-syntax whole-form-id) + (quote-syntax bound) + (free-id-table-map temp-id-table (λ (k v) k)))) + + (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t)))) diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt new file mode 100644 index 0000000..756efca --- /dev/null +++ b/test/test-ddd-top.rkt @@ -0,0 +1,84 @@ +#lang racket + +(require subtemplate/top-subscripts + subtemplate/ddd-forms + (except-in subtemplate/override ?? ?@) + stxparse-info/case + stxparse-info/parse + rackunit + syntax/macro-testing + phc-toolkit/untyped + (only-in racket/base [... …])) + +#;(check-equal? (syntax-parse #'(a b c) + [(xᵢ …) + yᵢ]) + '(a/y b/y c/y)) + +(check-equal? (syntax-case #'(a b c) () + [(xᵢ …) + (yᵢ …)]) + '(a/y b/y c/y)) + +(check-equal? (syntax-case #'(a b c) () + [(xᵢ …) + ([list xᵢ yᵢ] …)]) + '([a a/y] [b b/y] [c c/y])) + +(check-equal? (syntax-case #'(a b c) () + [(xᵢ …) + ({?@ xᵢ yᵢ} …)]) + '(a a/y b b/y c c/y)) + +(check-match (syntax-case #'(a b c) () + [(xᵢ …) + (list #'yᵢ …)]) + (list (? syntax?) (? syntax?) (? syntax?))) + +(check-equal? (map syntax->datum + (syntax-case #'(a b c) () + [(xᵢ …) + (list #'yᵢ …)])) + '(a/y b/y c/y)) + +(check-match (syntax-case #'(a b c) () + [(xᵢ …) + ([list xᵢ #'yᵢ] …)]) + (list (list 'a (? syntax?)) + (list 'b (? syntax?)) + (list 'c (? syntax?)))) + +(check-match (syntax-case #'(a b c) () + [(xᵢ …) + ([list #'xᵢ #'yᵢ] …)]) + (list (list (? syntax?) (? syntax?)) + (list (? syntax?)(? syntax?)) + (list (? syntax?)(? syntax?)))) + +(check-match (syntax-case #'(a b c) () + [(xᵢ …) + ({?@ #'xᵢ #'yᵢ} …)]) + (list (? syntax?) (? syntax?) + (? syntax?) (? syntax?) + (? syntax?) (? syntax?))) + +(check-equal? (syntax->datum + (datum->syntax #f + (syntax-case #'(a b c) () + [(xᵢ …) + ([list xᵢ #'yᵢ] …)]))) + '([a a/y] [b b/y] [c c/y])) + +(check-equal? (syntax->datum + (datum->syntax #f + (syntax-case #'(a b c) () + [(xᵢ …) + ([list #'xᵢ #'yᵢ] …)]))) + '([a a/y] [b b/y] [c c/y])) + +(check-equal? (syntax->datum + (datum->syntax #f + (syntax-case #'(a b c) () + [(xᵢ …) + ({?@ #'xᵢ #'yᵢ} …)]))) + '(a a/y b b/y c c/y)) \ No newline at end of file diff --git a/test/test-subtemplate-detect-stxinfo.rkt b/test/test-subtemplate-detect-stxinfo.rkt index 2b7f28e..43bcb43 100644 --- a/test/test-subtemplate-detect-stxinfo.rkt +++ b/test/test-subtemplate-detect-stxinfo.rkt @@ -1,6 +1,6 @@ #lang racket (module m-ok racket - (require subtemplate + (require subtemplate/template-subscripts stxparse-info/parse stxparse-info/case rackunit @@ -11,7 +11,7 @@ (subtemplate ok))))) (module m-no-parse racket - (require subtemplate + (require subtemplate/template-subscripts stxparse-info/case rackunit syntax/macro-testing) @@ -21,7 +21,7 @@ (subtemplate ok))))) (module m-wrong-parse racket - (require subtemplate + (require subtemplate/template-subscripts syntax/parse stxparse-info/case rackunit @@ -33,7 +33,7 @@ (subtemplate ok))))) (module m-wrong-case racket - (require subtemplate + (require subtemplate/template-subscripts stxparse-info/parse rackunit syntax/macro-testing) @@ -43,7 +43,7 @@ (subtemplate ok))))) (module m-no-parse-wrong-case racket - (require subtemplate + (require subtemplate/template-subscripts rackunit syntax/macro-testing) (check-exn #rx"subtemplate: syntax-parse seems undefined," @@ -52,7 +52,7 @@ (subtemplate ok))))) (module m-wrong-parse-wrong-case racket - (require subtemplate + (require subtemplate/template-subscripts syntax/parse rackunit syntax/macro-testing) diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt index 0987790..d7001b9 100644 --- a/test/test-subtemplate.rkt +++ b/test/test-subtemplate.rkt @@ -1,5 +1,5 @@ #lang racket -(require subtemplate +(require subtemplate/template-subscripts stxparse-info/parse stxparse-info/parse/experimental/template stxparse-info/case diff --git a/top-subscripts.rkt b/top-subscripts.rkt new file mode 100644 index 0000000..a930a39 --- /dev/null +++ b/top-subscripts.rkt @@ -0,0 +1,41 @@ +#lang racket/base +(require (only-in "template-subscripts.rkt" + derive + ellipsis-count/c) + phc-toolkit/untyped + (for-syntax racket/base + racket/syntax + syntax/stx + (only-in racket/base [... …]) + "subscripts.rkt")) + +(provide (rename-out [top #%top])) + +(define-syntax (top stx) + (define/with-syntax bound (stx-cdr stx)) + + (define binders+info (find-subscript-binders #'bound)) + + (if binders+info + (let () + (define/with-syntax [_bound + (binder …) + unique-at-runtime-ids + ellipsis-depth] + binders+info) + + (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate)) + + #'(let-values () + (define-values (whole-form-id) (quote-syntax #,this-syntax)) + (derive bound + (binder …) + unique-at-runtime-ids + ellipsis-depth + whole-form-id) + (let-values () + ;; check that all the binders for a given bound are compatible. + ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) + ;; actually call template or quasitemplate + bound))) + (datum->syntax stx `(,#'#%top . ,#'bound)))) \ No newline at end of file