From f7f1a57334dfa419b4c4ebc09154ae6761319f20 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 28 Nov 2015 16:07:04 -0500 Subject: [PATCH] adding additional layer of static interfaces --- remix/data0.rkt | 66 ++++++++++++++++++++++++++++-------------- remix/stx0.rkt | 17 +++++++---- remix/tests/simple.rkt | 23 ++++++++++++--- 3 files changed, 74 insertions(+), 32 deletions(-) diff --git a/remix/data0.rkt b/remix/data0.rkt index f4b0757..41c68e7 100644 --- a/remix/data0.rkt +++ b/remix/data0.rkt @@ -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) ...)))))]))]))))]))) diff --git a/remix/stx0.rkt b/remix/stx0.rkt index 001391e..ec0ddfb 100644 --- a/remix/stx0.rkt +++ b/remix/stx0.rkt @@ -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 diff --git a/remix/tests/simple.rkt b/remix/tests/simple.rkt index d2744b1..f04fcca 100644 --- a/remix/tests/simple.rkt +++ b/remix/tests/simple.rkt @@ -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})