suzanne.soy/remix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

progress... but broken

Browse Source
This commit is contained in:
Jay McCarthy 2016-02-20 15:44:10 -05:00
parent 9b1b41f835
commit eb48b06cfc
2 changed files with 228 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

348
remix/static-interface0.rkt
View File

@ -15,6 +15,7 @@
racket/generic racket/generic
(prefix-in remix: remix/stx0))) (prefix-in remix: remix/stx0)))
racket/stxparam racket/stxparam
racket/splicing
racket/unsafe/ops racket/unsafe/ops
racket/performance-hint racket/performance-hint
(prefix-in remix: remix/stx0)) (prefix-in remix: remix/stx0))
@ -33,6 +34,64 @@
(for-syntax (for-syntax
(submod "." interface-member)))) (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 (define-syntax static-interface
(singleton-struct (singleton-struct
#:property prop:procedure #:property prop:procedure
@ -43,146 +102,159 @@
(syntax-parse stx (syntax-parse stx
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
[(_def (remix:#%brackets me:id the-si:id) [(_def (remix:#%brackets me:id the-si:id)
;; XXX make expandable position body-expr ...)
(remix:#%brackets (syntax/loc stx
lhs:interface-member rhs:id (begin
(~optional (define-syntax the-sid (empty-static-interface-data #'the-si))
(~seq #:is rhs-dt:id) (splicing-syntax-parameterize
#:defaults ([rhs-dt #'#f]))) ([current-si
... (make-rename-transformer #'the-sid)])
(~optional body-expr ...)
(~seq #:extensions (static-interface-after-body the-sid)))]))]))
extension ...)
#:defaults ([[extension 1] '()]))) (define-syntax (static-interface-after-body stx)
(with-syntax* ([int-name (or (syntax-local-name) 'static-interface)] (syntax-parse stx
[(def-rhs ...) #:literals ()
(for/list ([lhs (in-list [(_me the-sid)
(map syntax->datum #:declare the-sid (static static-interface-data? "static interface data")
(syntax->list #'(lhs ...))))]) (match-define (static-interface-data si-id members extensions-b)
(format-id #f "~a-~a-for-def" #'int-name (attribute the-sid.value))
(if (keyword? lhs) (keyword->string lhs) (with-syntax* ([int-name si-id]
lhs)))] [([lhs rhs def-rhs rhs-dt full-def-rhs] ...)
[(full-def-rhs ...) (for/list ([(lhs rhs*rhs-dt) (in-hash members)])
(for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))] (match-define (vector rhs rhs-dt) rhs*rhs-dt)
[rhs-dt (in-list (syntax->list #'(rhs-dt ...)))]) (define def-rhs
(if (syntax-e rhs-dt) (format-id #f "~a-~a-for-def" #'int-name
(list def-rhs '#:is rhs-dt) (if (keyword? lhs) (keyword->string lhs)
(list def-rhs)))]) lhs)))
(syntax/loc stx (list
(remix:def lhs
(remix:#%brackets remix:stx the-si) rhs
(let () def-rhs
(define int-id->orig rhs-dt
(make-immutable-hasheq (if rhs-dt
(list (cons 'lhs (cons #'rhs #'rhs-dt)) #'(remix:#%brackets rhs-dt def-rhs)
...))) def-rhs)))]
(define available-ids [(extension ...) (reverse (unbox extensions-b))])
(sort (hash-keys int-id->orig) (syntax/loc stx
string<=? (remix:def
#:key ~a)) (remix:#%brackets remix:stx int-name)
(define (get-rhs stx x) (let ()
(define xv (syntax->datum x)) (define int-id->orig
(hash-ref int-id->orig (make-immutable-hasheq
xv (list (cons 'lhs (cons #'rhs #'rhs-dt))
(λ () ...)))
(raise-syntax-error (define available-ids
'int-name (sort (hash-keys int-id->orig)
(format "Unknown component ~v, expected one of ~v" string<=?
xv #:key ~a))
available-ids) (define (get-rhs stx x)
stx (define xv (syntax->datum x))
x)))) (hash-ref int-id->orig
(define (get-rhs-id stx x) xv
(car (get-rhs stx x))) (λ ()
(define (get-rhs-is stx x) (raise-syntax-error
(define r (cdr (get-rhs stx x))) 'int-name
(if (syntax-e r) (format "Unknown component ~v, expected one of ~v"
r xv
#f)) available-ids)
(define (get-rhs-def stx x-stx) stx
(define xd (get-rhs-is stx x-stx)) x))))
(with-syntax* ([xb (get-rhs-id stx x-stx)] (define (get-rhs-id stx x)
[x-def (car (get-rhs stx x)))
(if xd xd #'remix:stx)] (define (get-rhs-is stx x)
[x-def-v (define r (cdr (get-rhs stx x)))
(if xd #'xb #'(make-rename-transformer #'xb))]) (if (syntax-e r)
(quasisyntax/loc stx r
(remix:def (remix:#%brackets x-def #,x-stx) x-def-v)))) #f))
(singleton-struct (define (get-rhs-def stx x-stx)
#:methods gen:static-interface (define xd (get-rhs-is stx x-stx))
[(define (static-interface-members _) (with-syntax* ([xb (get-rhs-id stx x-stx)]
available-ids)] [x-def
#:methods remix:gen:dot-transformer (if xd xd #'remix:stx)]
[(define (dot-transform _ stx) [x-def-v
(syntax-parse stx (if xd #'xb #'(make-rename-transformer #'xb))])
[(_dot me:id (x:interface-member . args)) (quasisyntax/loc stx
(quasisyntax/loc stx (remix:def (remix:#%brackets x-def #,x-stx) x-def-v))))
(remix:#%app (remix:#%app (remix:#%dot me x)) . args))] (singleton-struct
[(_dot me:id x:interface-member) #:methods gen:static-interface
(get-rhs-id stx #'x)] [(define (static-interface-members _)
[(_dot me:id . (~and x+more (x:interface-member . more))) available-ids)]
(quasisyntax/loc stx #:methods remix:gen:dot-transformer
(remix:block [(define (dot-transform _ stx)
#,(get-rhs-def stx #'x) (syntax-parse stx
#,(syntax/loc #'x+more [(_dot me:id (x:interface-member . args))
(remix:#%dot x . more))))]))] (quasisyntax/loc stx
#:methods remix:gen:app-dot-transformer (remix:#%app (remix:#%app (remix:#%dot me x)) . args))]
[(define (app-dot-transform _ stx) [(_dot me:id x:interface-member)
(syntax-parse stx (get-rhs-id stx #'x)]
[(_app (_dot me:id (x:interface-member . args)) . body) [(_dot me:id . (~and x+more (x:interface-member . more)))
(quasisyntax/loc stx (quasisyntax/loc stx
(remix:#%app (remix:block
(remix:#%app (remix:#%app (remix:#%dot me x)) . args) #,(get-rhs-def stx #'x)
. body))] #,(syntax/loc #'x+more
[(_app (_dot me:id x:interface-member) . body) (remix:#%dot x . more))))]))]
(quasisyntax/loc stx #:methods remix:gen:app-dot-transformer
(#,(get-rhs-id stx #'x) . body))] [(define (app-dot-transform _ stx)
[(_app (_dot me:id x:interface-member . more) . body) (syntax-parse stx
(quasisyntax/loc stx [(_app (_dot me:id (x:interface-member . args)) . body)
(remix:block (quasisyntax/loc stx
#,(get-rhs-def stx #'x) (remix:#%app
(remix:#%app (remix:#%dot x . more) . body)))]))] (remix:#%app (remix:#%app (remix:#%dot me x)) . args)
#:methods remix:gen:def-transformer . body))]
[(define (def-transform _ stx) [(_app (_dot me:id x:interface-member) . body)
(syntax-parse stx (quasisyntax/loc stx
#:literals (remix:#%brackets) (#,(get-rhs-id stx #'x) . body))]
[(__def (remix:#%brackets me:id i:id) . body) [(_app (_dot me:id x:interface-member . more) . body)
(with-syntax ([real-i (generate-temporary #'i)]) (quasisyntax/loc stx
(syntax/loc stx (remix:block
(begin #,(get-rhs-def stx #'x)
(remix:def real-i . body) (remix:#%app (remix:#%dot x . more) . body)))]))]
(remix:def (remix:#%brackets remix:stx def-rhs) #:methods remix:gen:def-transformer
(λ (stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
[_:id #:literals (remix:#%brackets)
(syntax/loc stx [(__def (remix:#%brackets me:id i:id) . body)
(rhs real-i))] (with-syntax ([real-i (generate-temporary #'i)])
[(_ . blah) (syntax/loc stx
(syntax/loc stx (begin
(rhs real-i . blah))]))) (remix:def real-i . body)
... (remix:def (remix:#%brackets remix:stx def-rhs)
(remix:def (remix:#%brackets static-interface i) (λ (stx)
(remix:#%brackets lhs . full-def-rhs) (syntax-parse stx
... [_:id
#:extensions (syntax/loc stx
;; NB I don't pass on other (rhs real-i))]
;; extensions... I don't think [(_ . blah)
;; it can possibly make sense, (syntax/loc stx
;; because I don't know what (rhs real-i . blah))])))
;; they might be. ...
#:property prop:procedure (remix:def (remix:#%brackets static-interface i)
(λ (_ stx) (remix:def
(syntax-parse stx (remix:#%brackets static-interface-member lhs)
[_:id full-def-rhs)
(syntax/loc stx ...
real-i)] (remix:def
[(_ . blah) (remix:#%brackets static-interface-extension)
(syntax/loc stx ;; NB I don't pass on other
(real-i . blah))]))))))]))] ;; extensions... I don't think
extension ...)))))]))])) ;; 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 (provide static-interface
static-interface-member
static-interface-extension
(for-syntax gen:static-interface (for-syntax gen:static-interface
static-interface? static-interface?
static-interface-members)) static-interface-members))

29
remix/tests/static-interface.rkt
View File

@ -10,18 +10,22 @@
;; with particular functions. ;; with particular functions.
(def (example-f x y) x) (def (example-f x y) x)
(def (example-g x y) y) (def (example-g x y) y)
(def [static-interface example^] (def [static-interface example^]
[f example-f] (def [static-interface-member f]
[g example-g]) example-f)
(def [static-interface-member g]
example-g))
(module+ test (module+ test
{(example^.f 1 2) ≡ 1} {(example^.f 1 2) ≡ 1}
{(example^.g 1 2) ≡ 2}) {(example^.g 1 2) ≡ 2})
;; These static interfaces allow nesting ;; These static interfaces allow nesting
(def example2-h 19) (def example2-h 19)
(def [static-interface example2^] (def [static-interface example2^]
[fg example^] (def [static-interface-member fg]
[h example2-h]) example^)
(def [static-interface-member h]
example2-h))
(module+ test (module+ test
{(example2^.fg.f 1 2) ≡ 1} {(example2^.fg.f 1 2) ≡ 1}
{(example2^.fg.g 1 2) ≡ 2} {(example2^.fg.g 1 2) ≡ 2}
@ -51,9 +55,10 @@
;; use the keyword #:is and specify another def transformer for ;; use the keyword #:is and specify another def transformer for
;; contexts where the value is in tail position. ;; contexts where the value is in tail position.
(def [static-interface example3^] (def [static-interface example3^]
;; NB Perhaps it would be more punny to us [def id]? (def [static-interface-member fg]
[fg example2-fg #:is example^] [example^ example2-fg])
[h example2-h]) (def [static-interface-member h]
example2-h))
(def example2-fg 1) (def example2-fg 1)
(module+ test (module+ test
{(example3^.fg.f 2) ≡ 1} {(example3^.fg.f 2) ≡ 1}
@ -70,8 +75,10 @@
(def example4-kw-key '#:key) (def example4-kw-key '#:key)
(def example4-key 'key) (def example4-key 'key)
(def [static-interface example4^] (def [static-interface example4^]
[#:key example4-kw-key] (def [static-interface-member #:key]
[key example4-key]) example4-kw-key)
(def [static-interface-member key]
example4-key))
(module+ test (module+ test
{example4^.#:key ≡ '#:key} {example4^.#:key ≡ '#:key}
{example4^.key ≡ 'key}) {example4^.key ≡ 'key})