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

prep for expandable

Browse Source
This commit is contained in:
Jay McCarthy 2016-01-18 19:34:58 -05:00
parent d08f01c736
commit 985b540ccc
3 changed files with 162 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
remix/data0.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket/base
;; xxx data (fixed set of interfaces)

315
remix/static-interface0.rkt
View File

@ -31,175 +31,158 @@
(provide interface-member)) (provide interface-member))
(require (submod "." interface-member) (require (submod "." interface-member)
(for-syntax (for-syntax
(submod "." interface-member))) (submod "." interface-member))))
(define-syntax (phase1:static-interface stx) (define-syntax static-interface
(syntax-parse stx (singleton-struct
#:literals (remix:#%brackets) #:property prop:procedure
[(_si (λ (_ stx)
;; XXX make expandable position (raise-syntax-error 'static-interface "Illegal outside def" stx))
(remix:#%brackets #:methods remix:gen:def-transformer
lhs:interface-member rhs:id [(define (def-transform _ stx)
(~optional (syntax-parse stx
(~seq #:is rhs-dt:id) #:literals (remix:#%brackets)
#:defaults ([rhs-dt #'#f]))) [(_def (remix:#%brackets me:id the-si:id)
... ;; XXX make expandable position
(~optional (remix:#%brackets
(~seq #:extensions lhs:interface-member rhs:id
extension ...) (~optional
#:defaults ([[extension 1] '()]))) (~seq #:is rhs-dt:id)
(with-syntax* ([int-name (or (syntax-local-name) 'static-interface)] #:defaults ([rhs-dt #'#f])))
[(def-rhs ...) ...
(for/list ([lhs (in-list (~optional
(map syntax->datum (~seq #:extensions
(syntax->list #'(lhs ...))))]) extension ...)
(format-id #f "~a-~a-for-def" #'int-name #:defaults ([[extension 1] '()])))
(if (keyword? lhs) (keyword->string lhs) (with-syntax* ([int-name (or (syntax-local-name) 'static-interface)]
lhs)))] [(def-rhs ...)
[(full-def-rhs ...) (for/list ([lhs (in-list
(for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))] (map syntax->datum
[rhs-dt (in-list (syntax->list #'(rhs-dt ...)))]) (syntax->list #'(lhs ...))))])
(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 [(full-def-rhs ...)
(let () (for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))]
(define int-id->orig [rhs-dt (in-list (syntax->list #'(rhs-dt ...)))])
(make-immutable-hasheq (if (syntax-e rhs-dt)
(list (cons 'lhs (cons #'rhs #'rhs-dt)) (list def-rhs '#:is rhs-dt)
...))) (list def-rhs)))])
(define available-ids (syntax/loc stx
(sort (hash-keys int-id->orig) (remix:def
string<=? (remix:#%brackets remix:stx the-si)
#:key ~a)) (let ()
(define (get-rhs stx x) (define int-id->orig
(define xv (syntax->datum x)) (make-immutable-hasheq
(hash-ref int-id->orig (list (cons 'lhs (cons #'rhs #'rhs-dt))
xv ...)))
(λ () (define available-ids
(raise-syntax-error (sort (hash-keys int-id->orig)
'int-name string<=?
(format "Unknown component ~v, expected one of ~v" #:key ~a))
xv (define (get-rhs stx x)
available-ids) (define xv (syntax->datum x))
stx (hash-ref int-id->orig
x)))) xv
(define (get-rhs-id stx x) (λ ()
(car (get-rhs stx x))) (raise-syntax-error
(define (get-rhs-is stx x) 'int-name
(define r (cdr (get-rhs stx x))) (format "Unknown component ~v, expected one of ~v"
(if (syntax-e r) xv
r available-ids)
#f)) stx
(define (get-rhs-def stx x-stx) x))))
(define xd (get-rhs-is stx x-stx)) (define (get-rhs-id stx x)
(with-syntax* ([xb (get-rhs-id stx x-stx)] (car (get-rhs stx x)))
[x-def (define (get-rhs-is stx x)
(if xd xd #'remix:stx)] (define r (cdr (get-rhs stx x)))
[x-def-v (if (syntax-e r)
(if xd #'xb #'(make-rename-transformer #'xb))]) r
(quasisyntax/loc stx #f))
(remix:def (remix:#%brackets x-def #,x-stx) x-def-v)))) (define (get-rhs-def stx x-stx)
(singleton-struct (define xd (get-rhs-is stx x-stx))
#:methods gen:static-interface (with-syntax* ([xb (get-rhs-id stx x-stx)]
[(define (static-interface-members _) [x-def
available-ids)] (if xd xd #'remix:stx)]
#:methods remix:gen:dot-transformer [x-def-v
[(define (dot-transform _ stx) (if xd #'xb #'(make-rename-transformer #'xb))])
(syntax-parse stx
[(_dot me:id (x:interface-member . args))
(quasisyntax/loc stx (quasisyntax/loc stx
(remix:#%app (remix:#%app (remix:#%dot me x)) . args))] (remix:def (remix:#%brackets x-def #,x-stx) x-def-v))))
[(_dot me:id x:interface-member) (singleton-struct
(get-rhs-id stx #'x)] #:methods gen:static-interface
[(_dot me:id . (~and x+more (x:interface-member . more))) [(define (static-interface-members _)
(quasisyntax/loc stx available-ids)]
(remix:block #:methods remix:gen:dot-transformer
#,(get-rhs-def stx #'x) [(define (dot-transform _ stx)
#,(syntax/loc #'x+more (syntax-parse stx
(remix:#%dot x . more))))]))] [(_dot me:id (x:interface-member . args))
#:methods remix:gen:app-dot-transformer (quasisyntax/loc stx
[(define (app-dot-transform _ stx) (remix:#%app (remix:#%app (remix:#%dot me x)) . args))]
(syntax-parse stx [(_dot me:id x:interface-member)
[(_app (_dot me:id (x:interface-member . args)) . body) (get-rhs-id stx #'x)]
(quasisyntax/loc stx [(_dot me:id . (~and x+more (x:interface-member . more)))
(remix:#%app (quasisyntax/loc stx
(remix:#%app (remix:#%app (remix:#%dot me x)) . args) (remix:block
. body))] #,(get-rhs-def stx #'x)
[(_app (_dot me:id x:interface-member) . body) #,(syntax/loc #'x+more
(quasisyntax/loc stx (remix:#%dot x . more))))]))]
(#,(get-rhs-id stx #'x) . body))] #:methods remix:gen:app-dot-transformer
[(_app (_dot me:id x:interface-member . more) . body) [(define (app-dot-transform _ stx)
(quasisyntax/loc stx (syntax-parse stx
(remix:block [(_app (_dot me:id (x:interface-member . args)) . body)
#,(get-rhs-def stx #'x) (quasisyntax/loc stx
(remix:#%app (remix:#%dot x . more) . body)))]))] (remix:#%app
#:methods remix:gen:def-transformer (remix:#%app (remix:#%app (remix:#%dot me x)) . args)
[(define (def-transform _ stx) . body))]
(syntax-parse stx [(_app (_dot me:id x:interface-member) . body)
#:literals (remix:#%brackets) (quasisyntax/loc stx
[(def (remix:#%brackets me:id i:id) . body) (#,(get-rhs-id stx #'x) . body))]
(with-syntax ([real-i (generate-temporary #'i)]) [(_app (_dot me:id x:interface-member . more) . body)
(syntax/loc stx (quasisyntax/loc stx
(begin (remix:block
(remix:def real-i . body) #,(get-rhs-def stx #'x)
(remix:def (remix:#%brackets remix:stx def-rhs) (remix:#%app (remix:#%dot x . more) . body)))]))]
(λ (stx) #:methods remix:gen:def-transformer
(syntax-parse stx [(define (def-transform _ stx)
[_:id (syntax-parse stx
(syntax/loc stx #:literals (remix:#%brackets)
(rhs real-i))] [(__def (remix:#%brackets me:id i:id) . body)
[(_ . blah) (with-syntax ([real-i (generate-temporary #'i)])
(syntax/loc stx (syntax/loc stx
(rhs real-i . blah))]))) (begin
... (remix:def real-i . body)
(remix:def (remix:#%brackets remix:stx i) (remix:def (remix:#%brackets remix:stx def-rhs)
(phase1:static-interface (λ (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:#%brackets lhs . full-def-rhs)
(syntax-parse stx ...
[_:id #:extensions
(syntax/loc stx ;; NB I don't pass on other
real-i)] ;; extensions... I don't think
[(_ . blah) ;; it can possibly make sense,
(syntax/loc stx ;; because I don't know what
(real-i . blah))])))))))]))] ;; they might be.
extension ...))))]))) #:property prop:procedure
(λ (_ stx)
(syntax-parse stx
[_:id
(syntax/loc stx
real-i)]
[(_ . blah)
(syntax/loc stx
(real-i . blah))]))))))]))]
extension ...)))))]))]))
(define-syntax (define-phase0-def->phase1-macro stx) (provide static-interface
(syntax-parse stx (for-syntax gen:static-interface
[(_ base:id)
(with-syntax ([phase0:base (format-id #'base "phase0:~a" #'base)]
[phase1:base (format-id #'base "phase1:~a" #'base)])
(syntax/loc stx
(define-syntax phase0:base
(singleton-struct
#:property prop:procedure
(λ (_ stx)
(raise-syntax-error 'base "Illegal outside def" stx))
#:methods remix:gen:def-transformer
[(define (def-transform _ stx)
(syntax-parse stx
#:literals (remix:#%brackets)
[(def (remix:#%brackets me:id i:id) . body)
(syntax/loc stx
(remix:def (remix:#%brackets remix:stx i)
(phase1:base . body)))]))]))))]))
(define-phase0-def->phase1-macro static-interface)
(provide (rename-out [phase0:static-interface static-interface])
(for-syntax (rename-out [phase1:static-interface static-interface])
gen:static-interface
static-interface? static-interface?
static-interface-members)) static-interface-members))
;; xxx data (fixed set of interfaces)

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

@ -10,20 +10,18 @@
;; 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 [stx example^] (def [static-interface example^]
(static-interface [f example-f]
[f example-f] [g example-g])
[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 [stx example2^] (def [static-interface example2^]
(static-interface [fg example^]
[fg example^] [h example2-h])
[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}
@ -52,11 +50,10 @@
;; static-interface, rather than the binding itself. In that case, we ;; static-interface, rather than the binding itself. In that case, we
;; 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 [stx example3^] (def [static-interface example3^]
(static-interface ;; NB Perhaps it would be more punny to us [def id]?
;; NB Perhaps it would be more punny to us [def id]? [fg example2-fg #:is example^]
[fg example2-fg #:is example^] [h example2-h])
[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}