commit 5d2f8cc5127cabef234ee3875c60bf589ada0dc4
parent 29c90350b223288fb5f47075ea666ad91fb6ca17
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 25 Jan 2017 01:33:15 +0100
Partially reverted previous commit.
Diffstat:
7 files changed, 14 insertions(+), 184 deletions(-)
diff --git a/parse/experimental/steal-box.rkt b/parse/experimental/steal-box.rkt
@@ -1,3 +0,0 @@
-(module steal-box '#%kernel
- (define-values (bx) (box #f))
- (#%provide bx))
-\ No newline at end of file
diff --git a/parse/experimental/steal-metafunction.rkt b/parse/experimental/steal-metafunction.rkt
@@ -1,59 +0,0 @@
-#lang racket
-
-;; Manages to grasp the template-metafunction via (namespace-mapped-symbols)
-;; within the eval.
-(module extracted-template-metafunction racket/base
- (require (for-syntax syntax/parse/experimental/template)
- (for-syntax racket/base)
- (for-meta 2 racket/base)
- (for-meta 2 stxparse-info/parse/experimental/steal-box))
- (define-syntax (fu stx)
- (syntax-case stx ()
- [(_ id-mf? id-mf-v)
- (let ()
- (eval #'(begin
- (require (for-syntax
- stxparse-info/parse/experimental/steal-box))
- (define-template-metafunction (mf stx)
- #'1)
- (define-syntax (extract stx)
- ;; Use 3D syntax to return the value:
- (displayln (namespace-mapped-symbols))
- ;(displayln (eval 'template-metafunction))
- (define ctor (namespace-variable-value
- (for/first ([sym (namespace-mapped-symbols)]
- #:when (regexp-match #rx"template-metafunction[0-9].*" (symbol->string sym)))
- sym)))
- (displayln (list ctor (ctor 5165163)))
- (displayln (template-metafunction? (syntax-local-value #'mf)))
- (set-box! bx template-metafunction?)
- #'(void)
- #;#`(values #,template-metafunction?
- #,template-metafunction-var))
- (extract))
- (module->namespace 'syntax/parse/experimental/template))
- #`(begin
- (define-for-syntax id-mf? 0)
- (define-for-syntax id-mf-v 1)))]))
- (fu out-id-mf? out-id-mf-v)
- (begin-for-syntax
- (define-for-syntax rsl bx))
-
- #;(begin-for-syntax
- (define-syntax (br stx)
- (displayln rsl)
- #'(void))
- (br))
- #;(begin-for-syntax
- (begin-for-syntax
- (displayln rsl)))
- (provide (for-meta 2 rsl #;out-id-mf? #;out-id-mf-v)))
-
-#;(require (rename-in (for-template 'extracted-template-metafunction)
- [out-id-mf? template-metafunction?]
- [out-id-mf-v template-metafunction-var]))
-(require (for-meta -2 'extracted-template-metafunction))
-(displayln rsl)
-
-#;(provide template-metafunction?
- template-metafunction-var)
diff --git a/parse/experimental/steal-metafunction2.rkt b/parse/experimental/steal-metafunction2.rkt
@@ -1,25 +0,0 @@
-#lang racket
-
-(require (for-syntax syntax/parse/experimental/template)
- (for-syntax racket/base)
- (for-meta 2 racket/base)
- (for-meta 2 stxparse-info/parse/experimental/steal-box))
-
-(begin-for-syntax
- (eval #'(begin (define-syntax (e2 stx)
- #`(begin
- (module #,(cdr (syntax-e stx)) racket
- (provide (for-syntax e4a e4b))
- ;(require syntax/parse/experimental/template)
- (define-for-syntax e4a #,template-metafunction?)
- (define-for-syntax e4b #,template-metafunction-var)
- (module* e5 racket/base
- (require (for-template (submod "..")))
- (provide e4a e4b)))))
- (e2 . e3))
- (module->namespace 'syntax/parse/experimental/template))
- (define e5a (dynamic-require '(submod 'e3 e5) 'e4a))
- (define e5b (dynamic-require '(submod 'e3 e5) 'e4b))
- (provide (rename-out [e5a template-metafunction?]
- [e5b template-metafunction-var])))
-
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -16,64 +16,6 @@
??
?@)
-;; This is a bit ugly. Also, we can't extract the constructor for some reason
-;; (probably because it is a transformer binding, not a variable),
-;; so we require the original `define-template-metafunction` from
-;; syntax/parse/experimental/template to fulfill the defintition below.
-(require (only-in syntax/parse/experimental/template
- define-template-metafunction))
-(begin-for-syntax
- (require "steal-metafunction.rkt")
- (provide template-metafunction?
- template-metafunction-var))
-#;(begin
- (require (only-in syntax/parse/experimental/template
- define-template-metafunction))
- (begin-for-syntax
- (module extracted-template-metafunction racket/base
- (require syntax/parse/experimental/template
- (for-syntax racket/base))
- (define-values (template-metafunction?
- ;template-metafunction
- template-metafunction-var)
- (eval #'(begin
- (define-syntax (extract stx)
- ;; Use 3D syntax to return the value:
- #`(values #,template-metafunction?
- ;; Doesn't work, probably because it's a macro:
- ;#,template-metafunction
- #,template-metafunction-var))
- (extract))
- (module->namespace 'syntax/parse/experimental/template)))
- (provide template-metafunction?
- ;template-metafunction
- template-metafunction-var))
-
- (require 'extracted-template-metafunction)
- (provide template-metafunction?
- template-metafunction-var)
-
- ;; Tests:
- #;(begin
- (require rackunit)
-
- (require 'extracted-template-metafunction)
- (require (for-meta 4 'extracted-template-metafunction))
- (check-equal? (format "~a" template-metafunction?)
- "#<procedure:template-metafunction?>")
-
- (require (for-meta 1 racket/base))
- (require (for-meta 2 racket/base))
- (require (for-meta 3 racket/base))
- (require (for-meta 4 racket/base))
- (begin-for-syntax
- (begin-for-syntax
- (begin-for-syntax
- (begin-for-syntax
- (require rackunit)
- (check-equal? (format "~a" template-metafunction?)
- "#<procedure:template-metafunction?>"))))))))
-
#|
To do:
- improve error messages
@@ -244,7 +186,10 @@ instead of integers and integer vectors.
;; ============================================================
-#;(define-syntax (define-template-metafunction stx)
+;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
+;; the exported prop:template-metafunction, template-metafunction? and
+;; template-metafunction-accessor.
+(define-syntax (define-template-metafunction stx)
(syntax-case stx ()
[(dsm (id arg ...) . body)
#'(dsm id (lambda (arg ...) . body))]
@@ -256,9 +201,7 @@ instead of integers and integer vectors.
(template-metafunction (quote-syntax internal-id)))))]))
(begin-for-syntax
- ;; This struct is not declared here, but instead extracted from the official
- ;; syntax/parse/experimental/template, at the top of this file.
- #;(struct template-metafunction (var)))
+ (struct template-metafunction (var)))
;; ============================================================
diff --git a/parse/experimental/test-steal.rkt b/parse/experimental/test-steal.rkt
@@ -1,14 +0,0 @@
-#lang racket
-(require syntax/parse/experimental/template
- stxparse-info/parse/experimental/steal-metafunction2)
-(define-template-metafunction (mf stx)
- #'1)
-(provide mf)
-
-(let ()
- (define-syntax (foo stx)
- (displayln
- (template-metafunction?
- (syntax-local-value #'mf)))
- #''ok)
- (foo))
-\ No newline at end of file
diff --git a/test/test-compatibility1.rkt b/test/test-compatibility1.rkt
@@ -1,8 +1,6 @@
#lang racket
-(require ;syntax/parse
- ;syntax/parse/experimental/template
- stxparse-info/parse
- stxparse-info/parse/experimental/template)
+(require syntax/parse
+ syntax/parse/experimental/template)
(provide mf original-template)
(define-template-metafunction (mf stx)
#'ok-metafunction-official-1)
diff --git a/test/test-compatibility2.rkt b/test/test-compatibility2.rkt
@@ -1,23 +1,16 @@
#lang racket
-(require ;syntax/parse
- ;syntax/parse/experimental/template
- stxparse-info/parse
+(require stxparse-info/parse
stxparse-info/parse/experimental/template
rackunit
- #;"test-compatibility1.rkt")
-(define-template-metafunction (mf stx)
- #'ok-metafunction-official-1)
+ "test-compatibility1.rkt")
+;; TODO: re-enable this, and do the test the other way round too
+;; (the official syntax/parse to from stxparse-info)
#;(check-equal? (syntax-parse #'(1 (2 3))
[(x {~optional y} ({~optional z} t))
- (list #;(syntax->datum
- (original-template (x (?? y no-y) (?? z no-z) t (mf))))
+ (list (syntax->datum
+ (original-template (x (?? y no-y) (?? z no-z) t (mf))))
(syntax->datum
(template (x (?? y no-y) (?? z no-z) t (mf)))))])
- '(#;(1 no-y 2 3 ok-metafunction-official-1)
+ '((1 no-y 2 3 ok-metafunction-official-1)
(1 no-y 2 3 ok-metafunction-official-1)))
-
-(syntax-parse #'(1 (2 3))
- [(x {~optional y} ({~optional z} t))
- (syntax->datum
- (template (x (?? y no-y) (?? z no-z) t (mf))))])
-\ No newline at end of file
