diff --git a/remix/static-interface0.rkt b/remix/static-interface0.rkt index 64e52dd..919f3cf 100644 --- a/remix/static-interface0.rkt +++ b/remix/static-interface0.rkt @@ -15,6 +15,7 @@ racket/generic (prefix-in remix: remix/stx0))) racket/stxparam + racket/splicing racket/unsafe/ops racket/performance-hint (prefix-in remix: remix/stx0)) @@ -33,6 +34,64 @@ (for-syntax (submod "." interface-member)))) +(begin-for-syntax + (struct static-interface-data + (si-id members extensions)) + (define (empty-static-interface-data si-id) + (static-interface-data si-id (make-hasheq) (box null)))) + +(define-syntax default-si #f) +(define-rename-transformer-parameter current-si + (make-rename-transformer #'default-si)) + +(define-syntax static-interface-member + (singleton-struct + #:property prop:procedure + (λ (_ stx) + (raise-syntax-error 'static-interface-member "Illegal outside def" stx)) + #:methods remix:gen:def-transformer + [(define (def-transform _ stx) + (define sid + (or (syntax-local-value #'current-si (λ () #f)) + (raise-syntax-error 'static-interface-member + "Illegal outside static-interface" stx))) + (syntax-parse stx + #:literals (remix:#%brackets) + [(_def (remix:#%brackets me:id the-sim:interface-member) + (~or + (remix:#%brackets rhs-dt the-target:id) + (~and the-target:id + (~bind [rhs-dt #'#f])))) + (define the-sim-v (syntax->datum #'the-sim)) + (define mems (static-interface-data-members sid)) + (when (hash-has-key? mems the-sim-v) + (raise-syntax-error + 'static-interface-member + (format "Duplicate definition of static-interface-member ~a" + the-sim-v) + stx)) + (hash-set! mems the-sim-v (vector #'the-target #'rhs-dt)) + #'(void)]))])) + +(define-syntax static-interface-extension + (singleton-struct + #:property prop:procedure + (λ (_ stx) + (raise-syntax-error 'static-interface-extension "Illegal outside def" stx)) + #:methods remix:gen:def-transformer + [(define (def-transform _ stx) + (define sid + (or (syntax-local-value #'current-si (λ () #f)) + (raise-syntax-error 'static-interface-extension + "Illegal outside static-interface" stx))) + (syntax-parse stx + #:literals (remix:#%brackets) + [(_def (remix:#%brackets me:id) + . extension) + (define exts (static-interface-data-extensions sid)) + (set-box! exts (cons #'extension (unbox exts))) + #'(void)]))])) + (define-syntax static-interface (singleton-struct #:property prop:procedure @@ -43,146 +102,159 @@ (syntax-parse stx #:literals (remix:#%brackets) [(_def (remix:#%brackets me:id the-si:id) - ;; XXX make expandable position - (remix:#%brackets - lhs:interface-member rhs:id - (~optional - (~seq #:is rhs-dt:id) - #:defaults ([rhs-dt #'#f]))) - ... - (~optional - (~seq #:extensions - extension ...) - #:defaults ([[extension 1] '()]))) - (with-syntax* ([int-name (or (syntax-local-name) 'static-interface)] - [(def-rhs ...) - (for/list ([lhs (in-list - (map syntax->datum - (syntax->list #'(lhs ...))))]) - (format-id #f "~a-~a-for-def" #'int-name - (if (keyword? lhs) (keyword->string lhs) - lhs)))] - [(full-def-rhs ...) - (for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))] - [rhs-dt (in-list (syntax->list #'(rhs-dt ...)))]) - (if (syntax-e rhs-dt) - (list def-rhs '#:is rhs-dt) - (list def-rhs)))]) - (syntax/loc stx - (remix:def - (remix:#%brackets remix:stx the-si) - (let () - (define int-id->orig - (make-immutable-hasheq - (list (cons 'lhs (cons #'rhs #'rhs-dt)) - ...))) - (define available-ids - (sort (hash-keys int-id->orig) - string<=? - #:key ~a)) - (define (get-rhs stx x) - (define xv (syntax->datum x)) - (hash-ref int-id->orig - xv - (λ () - (raise-syntax-error - 'int-name - (format "Unknown component ~v, expected one of ~v" - xv - available-ids) - stx - x)))) - (define (get-rhs-id stx x) - (car (get-rhs stx x))) - (define (get-rhs-is stx x) - (define r (cdr (get-rhs stx x))) - (if (syntax-e r) - r - #f)) - (define (get-rhs-def stx x-stx) - (define xd (get-rhs-is stx x-stx)) - (with-syntax* ([xb (get-rhs-id stx x-stx)] - [x-def - (if xd xd #'remix:stx)] - [x-def-v - (if xd #'xb #'(make-rename-transformer #'xb))]) - (quasisyntax/loc stx - (remix:def (remix:#%brackets x-def #,x-stx) x-def-v)))) - (singleton-struct - #:methods gen:static-interface - [(define (static-interface-members _) - available-ids)] - #:methods remix:gen:dot-transformer - [(define (dot-transform _ stx) - (syntax-parse stx - [(_dot me:id (x:interface-member . args)) - (quasisyntax/loc stx - (remix:#%app (remix:#%app (remix:#%dot me x)) . args))] - [(_dot me:id x:interface-member) - (get-rhs-id stx #'x)] - [(_dot me:id . (~and x+more (x:interface-member . more))) - (quasisyntax/loc stx - (remix:block - #,(get-rhs-def stx #'x) - #,(syntax/loc #'x+more - (remix:#%dot x . more))))]))] - #:methods remix:gen:app-dot-transformer - [(define (app-dot-transform _ stx) - (syntax-parse stx - [(_app (_dot me:id (x:interface-member . args)) . body) - (quasisyntax/loc stx - (remix:#%app - (remix:#%app (remix:#%app (remix:#%dot me x)) . args) - . body))] - [(_app (_dot me:id x:interface-member) . body) - (quasisyntax/loc stx - (#,(get-rhs-id stx #'x) . body))] - [(_app (_dot me:id x:interface-member . more) . body) - (quasisyntax/loc stx - (remix:block - #,(get-rhs-def stx #'x) - (remix:#%app (remix:#%dot x . more) . body)))]))] - #:methods remix:gen:def-transformer - [(define (def-transform _ stx) - (syntax-parse stx - #:literals (remix:#%brackets) - [(__def (remix:#%brackets me:id i:id) . body) - (with-syntax ([real-i (generate-temporary #'i)]) - (syntax/loc stx - (begin - (remix:def real-i . body) - (remix:def (remix:#%brackets remix:stx def-rhs) - (λ (stx) - (syntax-parse stx - [_:id - (syntax/loc stx - (rhs real-i))] - [(_ . blah) - (syntax/loc stx - (rhs real-i . blah))]))) - ... - (remix:def (remix:#%brackets static-interface i) - (remix:#%brackets lhs . full-def-rhs) - ... - #:extensions - ;; NB I don't pass on other - ;; extensions... I don't think - ;; it can possibly make sense, - ;; because I don't know what - ;; they might be. - #:property prop:procedure - (λ (_ stx) - (syntax-parse stx - [_:id - (syntax/loc stx - real-i)] - [(_ . blah) - (syntax/loc stx - (real-i . blah))]))))))]))] - extension ...)))))]))])) + body-expr ...) + (syntax/loc stx + (begin + (define-syntax the-sid (empty-static-interface-data #'the-si)) + (splicing-syntax-parameterize + ([current-si + (make-rename-transformer #'the-sid)]) + body-expr ...) + (static-interface-after-body the-sid)))]))])) + +(define-syntax (static-interface-after-body stx) + (syntax-parse stx + #:literals () + [(_me the-sid) + #:declare the-sid (static static-interface-data? "static interface data") + (match-define (static-interface-data si-id members extensions-b) + (attribute the-sid.value)) + (with-syntax* ([int-name si-id] + [([lhs rhs def-rhs rhs-dt full-def-rhs] ...) + (for/list ([(lhs rhs*rhs-dt) (in-hash members)]) + (match-define (vector rhs rhs-dt) rhs*rhs-dt) + (define def-rhs + (format-id #f "~a-~a-for-def" #'int-name + (if (keyword? lhs) (keyword->string lhs) + lhs))) + (list + lhs + rhs + def-rhs + rhs-dt + (if rhs-dt + #'(remix:#%brackets rhs-dt def-rhs) + def-rhs)))] + [(extension ...) (reverse (unbox extensions-b))]) + (syntax/loc stx + (remix:def + (remix:#%brackets remix:stx int-name) + (let () + (define int-id->orig + (make-immutable-hasheq + (list (cons 'lhs (cons #'rhs #'rhs-dt)) + ...))) + (define available-ids + (sort (hash-keys int-id->orig) + string<=? + #:key ~a)) + (define (get-rhs stx x) + (define xv (syntax->datum x)) + (hash-ref int-id->orig + xv + (λ () + (raise-syntax-error + 'int-name + (format "Unknown component ~v, expected one of ~v" + xv + available-ids) + stx + x)))) + (define (get-rhs-id stx x) + (car (get-rhs stx x))) + (define (get-rhs-is stx x) + (define r (cdr (get-rhs stx x))) + (if (syntax-e r) + r + #f)) + (define (get-rhs-def stx x-stx) + (define xd (get-rhs-is stx x-stx)) + (with-syntax* ([xb (get-rhs-id stx x-stx)] + [x-def + (if xd xd #'remix:stx)] + [x-def-v + (if xd #'xb #'(make-rename-transformer #'xb))]) + (quasisyntax/loc stx + (remix:def (remix:#%brackets x-def #,x-stx) x-def-v)))) + (singleton-struct + #:methods gen:static-interface + [(define (static-interface-members _) + available-ids)] + #:methods remix:gen:dot-transformer + [(define (dot-transform _ stx) + (syntax-parse stx + [(_dot me:id (x:interface-member . args)) + (quasisyntax/loc stx + (remix:#%app (remix:#%app (remix:#%dot me x)) . args))] + [(_dot me:id x:interface-member) + (get-rhs-id stx #'x)] + [(_dot me:id . (~and x+more (x:interface-member . more))) + (quasisyntax/loc stx + (remix:block + #,(get-rhs-def stx #'x) + #,(syntax/loc #'x+more + (remix:#%dot x . more))))]))] + #:methods remix:gen:app-dot-transformer + [(define (app-dot-transform _ stx) + (syntax-parse stx + [(_app (_dot me:id (x:interface-member . args)) . body) + (quasisyntax/loc stx + (remix:#%app + (remix:#%app (remix:#%app (remix:#%dot me x)) . args) + . body))] + [(_app (_dot me:id x:interface-member) . body) + (quasisyntax/loc stx + (#,(get-rhs-id stx #'x) . body))] + [(_app (_dot me:id x:interface-member . more) . body) + (quasisyntax/loc stx + (remix:block + #,(get-rhs-def stx #'x) + (remix:#%app (remix:#%dot x . more) . body)))]))] + #:methods remix:gen:def-transformer + [(define (def-transform _ stx) + (syntax-parse stx + #:literals (remix:#%brackets) + [(__def (remix:#%brackets me:id i:id) . body) + (with-syntax ([real-i (generate-temporary #'i)]) + (syntax/loc stx + (begin + (remix:def real-i . body) + (remix:def (remix:#%brackets remix:stx def-rhs) + (λ (stx) + (syntax-parse stx + [_:id + (syntax/loc stx + (rhs real-i))] + [(_ . blah) + (syntax/loc stx + (rhs real-i . blah))]))) + ... + (remix:def (remix:#%brackets static-interface i) + (remix:def + (remix:#%brackets static-interface-member lhs) + full-def-rhs) + ... + (remix:def + (remix:#%brackets static-interface-extension) + ;; NB I don't pass on other + ;; extensions... I don't think + ;; it can possibly make sense, + ;; because I don't know what + ;; they might be. + #:property prop:procedure + (λ (_ stx) + (syntax-parse stx + [_:id + (syntax/loc stx + real-i)] + [(_ . blah) + (syntax/loc stx + (real-i . blah))])))))))]))] + extension ...)))))])) (provide static-interface + static-interface-member + static-interface-extension (for-syntax gen:static-interface static-interface? static-interface-members)) - diff --git a/remix/tests/static-interface.rkt b/remix/tests/static-interface.rkt index ba70f91..4115495 100644 --- a/remix/tests/static-interface.rkt +++ b/remix/tests/static-interface.rkt @@ -10,18 +10,22 @@ ;; with particular functions. (def (example-f x y) x) (def (example-g x y) y) -(def [static-interface example^] - [f example-f] - [g example-g]) +(def [static-interface example^] + (def [static-interface-member f] + example-f) + (def [static-interface-member g] + example-g)) (module+ test {(example^.f 1 2) ≡ 1} {(example^.g 1 2) ≡ 2}) ;; These static interfaces allow nesting (def example2-h 19) -(def [static-interface example2^] - [fg example^] - [h example2-h]) +(def [static-interface example2^] + (def [static-interface-member fg] + example^) + (def [static-interface-member h] + example2-h)) (module+ test {(example2^.fg.f 1 2) ≡ 1} {(example2^.fg.g 1 2) ≡ 2} @@ -51,9 +55,10 @@ ;; use the keyword #:is and specify another def transformer for ;; contexts where the value is in tail position. (def [static-interface example3^] - ;; NB Perhaps it would be more punny to us [def id]? - [fg example2-fg #:is example^] - [h example2-h]) + (def [static-interface-member fg] + [example^ example2-fg]) + (def [static-interface-member h] + example2-h)) (def example2-fg 1) (module+ test {(example3^.fg.f 2) ≡ 1} @@ -70,8 +75,10 @@ (def example4-kw-key '#:key) (def example4-key 'key) (def [static-interface example4^] - [#:key example4-kw-key] - [key example4-key]) + (def [static-interface-member #:key] + example4-kw-key) + (def [static-interface-member key] + example4-key)) (module+ test {example4^.#:key ≡ '#:key} {example4^.key ≡ 'key})