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

adding additional layer of static interfaces

Browse Source
This commit is contained in:
Jay McCarthy 2015-11-28 16:07:04 -05:00
parent 124e97acf2
commit f7f1a57334
3 changed files with 74 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
remix/data0.rkt
View File

@ -6,29 +6,35 @@
(prefix-in remix: remix/stx0)
remix/stx/singleton-struct0
(for-syntax racket/base
syntax/parse))
syntax/parse
(prefix-in remix: remix/stx0)))
(prefix-in remix: remix/stx0))
(begin-for-syntax
(define-syntax (static-interface stx)
(syntax-parse stx
#:literals (remix:#%brackets)
[(_si (remix:#%brackets lhs:id rhs:id) ...)
[(_si (remix:#%brackets
lhs:id rhs:id
(~optional
(~seq #:is rhs-dt:id)
#:defaults ([rhs-dt #'#f])))
...)
(with-syntax ([int-name (syntax-local-name)]
[(def-rhs ...) (generate-temporaries #'(rhs ...))])
(syntax/loc stx
(let ()
(define int-id->orig-id
(define int-id->orig
(make-immutable-hasheq
(list (cons 'lhs #'rhs)
(list (cons 'lhs (cons #'rhs #'rhs-dt))
...)))
(define available-ids
(sort (hash-keys int-id->orig-id)
(sort (hash-keys int-id->orig)
string<=?
#:key symbol->string))
(define (get-binding stx x)
(define (get-rhs stx x)
(define xv (syntax->datum x))
(hash-ref int-id->orig-id
(hash-ref int-id->orig
xv
(λ ()
(raise-syntax-error
@ -38,6 +44,22 @@
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
#:property prop:procedure
(λ (_ stx)
@ -46,36 +68,36 @@
[(define (dot-transform _ stx)
(syntax-parse stx
[(_dot me:id x:id)
(get-binding stx #'x)]
(get-rhs-id stx #'x)]
[(_dot me:id x:id . more:expr)
(with-syntax ([xb (get-binding stx #'x)])
(syntax/loc stx
(let-syntax ([x (make-rename-transformer #'xb)])
(remix:#%dot x . more))))]))]
(quasisyntax/loc stx
(remix:block
#,(get-rhs-def stx #'x)
(remix:#%dot x . more)))]))]
#:methods remix:gen:app-dot-transformer
[(define (app-dot-transform _ stx)
(syntax-parse stx
[(_app (_dot me:id x:id) . body:expr)
(quasisyntax/loc stx
(#,(get-binding stx #'x) . body))]
(#,(get-rhs-id stx #'x) . body))]
[(_app (_dot me:id x:id . more:expr) . body:expr)
(with-syntax ([xb (get-binding stx #'x)])
(syntax/loc stx
(let-syntax ([x (make-rename-transformer #'xb)])
(remix:#%app (remix:#%dot x . 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 x:id) . body:expr)
(with-syntax ([real-x (generate-temporary #'x)])
[(def (remix:#%brackets me:id i:id) . body:expr)
(with-syntax ([real-i (generate-temporary #'i)])
(syntax/loc stx
(begin
(remix:def real-x . body)
(remix:def real-i . body)
(remix:def (remix:#%brackets remix:mac (def-rhs . blah:expr))
(rhs real-x . blah))
(remix:#%app rhs real-i . blah))
...
(remix:def (remix:#%brackets remix:stx x)
(remix:def (remix:#%brackets remix:stx i)
(static-interface
(remix:#%brackets lhs def-rhs)
...)))))]))]))))])))

17
remix/stx0.rkt
View File

@ -169,9 +169,10 @@
(define-syntax (#%dot stx)
(syntax-parse stx
#:literals (#%dot)
[(_ x:expr ... (#%dot y:expr ...))
[(_ dt x:expr ... (#%dot y:expr ...))
#:declare dt (static dot-transformer? "dot transformer")
(syntax/loc stx
(#%dot x ... y ...))]
(#%dot dt x ... y ...))]
[(_ dt . _)
#:declare dt (static dot-transformer? "dot transformer")
(dot-transform (attribute dt.value) stx)]))
@ -184,7 +185,7 @@
#:literals (#%dot)
[(_ (~and dot-rator (#%dot x:expr ... (#%dot y:expr ...))) . body:expr)
(syntax/loc stx
(#%app (#%dot x ... y ...) . body))]
(remix-#%app (#%dot x ... y ...) . body))]
[(_ (~and dot-rator (#%dot adt . _)) . body:expr)
#:declare adt (static app-dot-transformer? "app-dot transformer")
(app-dot-transform (attribute adt.value) stx)]
@ -324,7 +325,9 @@
(provide def def*
(for-syntax gen:def-transformer
gen:def*-transformer)
def-transformer?
gen:def*-transformer
def*-transformer?)
(rename-out [def ≙] ;; \defs
[def :=]
[def* ≙*]
@ -343,9 +346,11 @@
binary-operator?
binary-operator-precedence)
#%dot
(for-syntax gen:dot-transformer)
(for-syntax gen:dot-transformer
dot-transformer?)
(rename-out [remix-#%app #%app])
(for-syntax gen:app-dot-transformer)
(for-syntax gen:app-dot-transformer
app-dot-transformer?)
(rename-out [... …]) ;; \ldots
#%datum
quote

23
remix/tests/simple.rkt
View File

@ -265,7 +265,9 @@
(module+ test
{(example2^.fg.f 1 2) ≡ 1}
{(example2^.fg.g 1 2) ≡ 2}
{example2^.h ≡ 19})
{example2^.h ≡ 19}
;; Notice that cut works with nested dots
{(λ.example2^.h 'ignored) ≡ 19})
;; They are also def transformers and when used in that way, they
;; implicitly pass the binding on as the first argument to functions
@ -273,12 +275,25 @@
(def [example^ ee] 1)
(module+ test
{(ee.f 2) ≡ 1}
{(ee.g 2) ≡ 2}
;; Notice that cut works with nested dots
{(λ.example2^.h 'ignored) ≡ 19})
{(ee.g 2) ≡ 2})
;; This is especially useful inside of functions
(def (f-using-example [example^ ee])
(ee.f 2))
(module+ test
{(f-using-example 1) ≡ 1})
;; Sometimes a static-interface's binding's result is another
;; static-interface, rather than the binding itself. In that case, we
;; use the keyword #:is and specify another def transformer for
;; contexts where the value is in tail position.
(def [stx example3^]
(static-interface
;; NB Perhaps it would be more punny to us [def id]?
[fg example2-fg #:is example^]
[h example2-h]))
(def example2-fg 1)
(module+ test
{(example3^.fg.f 2) ≡ 1}
{(example3^.fg.g 2) ≡ 2}
{example3^.h ≡ 19})