progress... but broken
This commit is contained in:
Jay McCarthy
parent
9b1b41f835
commit
eb48b06cfc
|
|
@ -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,34 +102,43 @@
|
|||
(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 ...))))])
|
||||
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)))]
|
||||
[(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)))])
|
||||
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 the-si)
|
||||
(remix:#%brackets remix:stx int-name)
|
||||
(let ()
|
||||
(define int-id->orig
|
||||
(make-immutable-hasheq
|
||||
|
|
@ -162,9 +230,12 @@
|
|||
(rhs real-i . blah))])))
|
||||
...
|
||||
(remix:def (remix:#%brackets static-interface i)
|
||||
(remix:#%brackets lhs . full-def-rhs)
|
||||
(remix:def
|
||||
(remix:#%brackets static-interface-member lhs)
|
||||
full-def-rhs)
|
||||
...
|
||||
#:extensions
|
||||
(remix:def
|
||||
(remix:#%brackets static-interface-extension)
|
||||
;; NB I don't pass on other
|
||||
;; extensions... I don't think
|
||||
;; it can possibly make sense,
|
||||
|
|
@ -178,11 +249,12 @@
|
|||
real-i)]
|
||||
[(_ . blah)
|
||||
(syntax/loc stx
|
||||
(real-i . blah))]))))))]))]
|
||||
extension ...)))))]))]))
|
||||
(real-i . blah))])))))))]))]
|
||||
extension ...)))))]))
|
||||
|
||||
(provide static-interface
|
||||
static-interface-member
|
||||
static-interface-extension
|
||||
(for-syntax gen:static-interface
|
||||
static-interface?
|
||||
static-interface-members))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,8 +11,10 @@
|
|||
(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-member f]
|
||||
example-f)
|
||||
(def [static-interface-member g]
|
||||
example-g))
|
||||
(module+ test
|
||||
{(example^.f 1 2) ≡ 1}
|
||||
{(example^.g 1 2) ≡ 2})
|
||||
|
|
@ -20,8 +22,10 @@
|
|||
;; These static interfaces allow nesting
|
||||
(def example2-h 19)
|
||||
(def [static-interface example2^]
|
||||
[fg example^]
|
||||
[h example2-h])
|
||||
(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})
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user