diff --git a/subtemplate.rkt b/subtemplate.rkt index 53e6658..172ede5 100644 --- a/subtemplate.rkt +++ b/subtemplate.rkt @@ -13,63 +13,62 @@ phc-toolkit/untyped syntax/strip-context srfi/13 + syntax/contract racket/contract)) (provide (rename-out [new-syntax-parse syntax-parse] [new-syntax-case syntax-case]) subtemplate - quasisubtemplate - (for-syntax find-subscript-binder)) ;; for testing only + quasisubtemplate) (begin-for-syntax (struct derived ())) (define-syntax-parameter maybe-syntax-pattern-variable-ids '()) -(define empty-pvar-values #f) +(define empty-pvar-values '()) (define-syntax-parameter pvar-values-id (make-rename-transformer #'empty-pvar-values)) +(define-for-syntax (new-scope rest lctx) + ;(wrap-expr/c + ;#'(listof (cons/c identifier? (listof symbol?))) + #`(cons (cons (quote-syntax #,(syntax-local-get-shadower + (datum->syntax lctx + 'outer-lctx)) + #:local) + '#,(~> (syntax->datum rest) + flatten + (filter symbol? _) + (remove-duplicates))) + (syntax-parameter-value + #'maybe-syntax-pattern-variable-ids)));) + (define-syntax/parse (new-syntax-parse . rest) (quasisyntax/top-loc (stx-car stx) - ;; HERE insert a hash table, to cache the uses - ;; lifting the define-temp-ids is not likely to work, as they + ;; HERE insert a hash table, to cache the uses of derived pvars. + ;; 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. + (let ([the-pvar-values (cons (make-hash) pvar-values-id)]) (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)))] + #,(new-scope #'rest (stx-car stx))] [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? - (flatten - (syntax->datum #'rest)))) - (syntax-parameter-value - #'maybe-syntax-pattern-variable-ids))] - [pvar-values-id (make-rename-transformer - #'the-pvar-values)]) - (syntax-case . rest))))) + (error "new-syntax-case not implemented yet") + #;(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? + (flatten + (syntax->datum #'rest)))) + (syntax-parameter-value + #'maybe-syntax-pattern-variable-ids))] + [pvar-values-id (make-rename-transformer + #'the-pvar-values)]) + (syntax-case . rest))))) (begin-for-syntax (define/contract (string-suffix a b) @@ -99,55 +98,75 @@ (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 (derived? binder) - (-> identifier? boolean?) - (displayln 'TODO-89641) - #f) - - (define/contract (find-subscript-binder2a scopes bound) - (-> (listof (listof identifier?)) + (define/contract (find-subscript-binder2a lctx scopes bound scope-depth) + (-> identifier? + (listof (cons/c identifier? (listof symbol?))) identifier? - (listof identifier?)) + exact-nonnegative-integer? + (listof (list/c identifier? exact-nonnegative-integer?))) (if (null? scopes) '() (let () - (define scope (car scopes)) - (define recur-found (find-subscript-binder2a (cdr scopes) bound)) + (define outer-lctx (caar scopes)) + (define syms (cdar scopes)) + (define recur-found (find-subscript-binder2a outer-lctx + (cdr scopes) + bound + (add1 scope-depth))) (define found-here - (for*/list ([binder (in-list scope)] - #:when (displayln (list (syntax-e bound) (syntax-e binder) - 'pvar?= (syntax-pattern-variable? - (syntax-local-value (replace-context bound binder) - (thunk #f))) - 'derived= (not (derived? binder)) - 'subscripts= (subscript-equal? bound - binder))) + (for*/list ([binder-sym (in-list syms)] + [binder (in-value (datum->syntax lctx binder-sym))] + #;#:when #;(displayln (list bound binder + 'pvar?= (syntax-pattern-variable? + (syntax-local-value binder (thunk #f))) + 'derived?= (derived? + (syntax-local-value + (format-id binder + " is-derived-~a " + binder) + (thunk #f))) + (subscript-equal? bound + binder))) #:when (syntax-pattern-variable? - (syntax-local-value (replace-context bound binder) ;; why do I need replace-context here??? - (thunk #f))) - #:when (not (derived? binder)) + (syntax-local-value binder (thunk #f))) + #:when (not (derived? + (syntax-local-value + (format-id binder + " is-derived-~a " + binder) + (thunk #f)))) [subscripts (in-value (subscript-equal? bound binder))] #:when subscripts) - binder)) + ;(displayln (list binder scope-depth)) + (list binder scope-depth))) + ;(displayln (list* 'found-here= bound '→ found-here)) (if (null? found-here) recur-found (append found-here recur-found))))) (define/contract (find-subscript-binder2 bound) (-> identifier? - (or/c #f (list/c (syntax/c (listof identifier?)) - exact-nonnegative-integer? - syntax?))) + (or/c #f (list/c identifier? ;; bound + (syntax/c (listof identifier?)) ;; bindings + exact-nonnegative-integer? ;; ellipsis-depth + exact-nonnegative-integer? ;; scope-depth + syntax?))) ;; check-ellipsis-count (define scopes (syntax-parameter-value #'maybe-syntax-pattern-variable-ids)) - (define/with-syntax (binder …) (find-subscript-binder2a scopes bound)) + (define/with-syntax ([binder scope-depth] …) + (find-subscript-binder2a bound ;; TODO: check this is okay (should be). + scopes + bound + 0)) + ;(displayln (syntax->datum #`(2 bound= #,bound 2a-result= [binder scope-depth] …))) (if (stx-null? #'(binder …)) #f (let () (define depths - (stx-map (∘ syntax-mapping-depth syntax-local-value) (replace-context bound #'(binder …)))) ;; why do I need replace-context here??? + (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …))) (unless (or (< (length depths) 2) (apply = depths)) (raise-syntax-error 'subtemplate (format "inconsistent depths: ~a" @@ -157,47 +176,11 @@ ;; ellipsis count (define/with-syntax check-ellipsis-count-ddd (nest-ellipses #'(binder …) (car depths))) - (list #'(binder …) (car depths) #'check-ellipsis-count-ddd)))) - - (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))] - [scope-depth (in-naturals)]) - (define result - (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)) - [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)) - (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)) + (list bound + #'(binder …) + (car depths) + (apply max (syntax->datum #'(scope-depth …))) + #'check-ellipsis-count-ddd)))) (define/contract (nest-ellipses stx n) (-> syntax? exact-nonnegative-integer? syntax?) @@ -206,43 +189,6 @@ #`(#,(nest-ellipses stx (sub1 n)) (… …))))) -(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-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)) - (define/with-syntax binder-ddd (nest-ellipses #'binder depth)) - ;; 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. - ;; TODO: 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. - - ;; 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-def #:local) - #'tmp-ddd)) - (define/with-syntax bound-ddd cached))))) - (define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl)) (define acc '()) (define (fold-process stx rec) @@ -253,16 +199,9 @@ [id (identifier? #'id) (let ([binders (find-subscript-binder2 #'id)]) (when binders - (displayln (syntax->datum (datum->syntax #f (cons #'id binders)))) - (set! acc (cons (cons #'id binders) - acc))) - #'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)] + ;(displayln (syntax->datum (datum->syntax #f binders))) + (set! acc (cons binders acc))) + #'id)] [other (rec #'other)])) (define result (quasisyntax/top-loc #'self @@ -271,22 +210,22 @@ #'tmpl)))) ;; Make sure that we remove duplicates, otherwise we'll get errors if we ;; define the same derived id twice. - (define/with-syntax ([bound (binder0 . binders) depth check-ellipsis-count] …) - (remove-duplicates acc free-identifier=? #:key car)) - #;(define/with-syntax ([bound binder depth] …) - (remove-duplicates acc free-identifier=? #:key car)) + (define/with-syntax ([bound (binder0 . binders) + depth + scope-depth + check-ellipsis-count] …) + (remove-duplicates acc #:key car)) - (displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth) - …))) + #;(displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth scope-depth) + …))) #`(let () - #;(derive bound binder depth) - (derive2 bound binder0 (binder0 . binders) depth) + (derive2 bound binder0 (binder0 . binders) depth scope-depth) … (let () - #'#,(replace-context ;; TODO: this is most certainly wrong - (stx-car #'(bound …)) - #'(check-ellipsis-count …)) + ;; no-op, just to raise an error when they are incompatible + #'(check-ellipsis-count …) + ;; actually call template or quasitemplate #,result))) (define-syntax subtemplate (sub*template #'template)) @@ -296,7 +235,7 @@ -(define-syntax/case (derive2 bound binder0 binders stx-depth) () +(define-syntax/case (derive2 bound binder0 binders stx-depth stx-scope-depth) () (define/with-syntax bound-def #'bound #;(replace-context #'binder0 #'bound)) (define depth (syntax-e #'stx-depth)) (define/with-syntax bound-ddd (nest-ellipses #'bound-def depth)) @@ -324,7 +263,12 @@ (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f))) #'(begin) #`(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)))) \ No newline at end of file + (define cached (hash-ref! (list-ref pvar-values-id + stx-scope-depth) + 'bound-def + #'tmp-ddd)) + (define/with-syntax bound-ddd cached) + (define-syntax #,(format-id #'bound + " is-derived-~a " + #'bound) + (derived))))) \ No newline at end of file diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt index d050124..b76c350 100644 --- a/test/test-subtemplate.rkt +++ b/test/test-subtemplate.rkt @@ -9,14 +9,15 @@ (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])) -#;(map syntax->datum - (syntax-parse #'() - [() - (syntax-parse #'(a b c) - [(xⱼ zᵢ …) - (list (let () (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))) - (syntax-parse #'(e) - [(e) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])) +(map syntax->datum + (syntax-parse #'() + [() + (syntax-parse #'(a b) + [(zᵢ …) + (list (syntax-parse #'(e) + [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]) + (syntax-parse #'(e) + [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])) #| (define-syntax (tst stx)