suzanne.soy/backport-template-pr1514
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Beginning of an attempt to implement unsyntax in a ellipsis-preserving way (does not work)

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-26 16:16:54 +01:00
parent d8e8913904
commit 9a76ab551e
3 changed files with 115 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
experimental/template.rkt
View File

@ -443,6 +443,9 @@ instead of integers and integer vectors.
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide props-guide) (parse-t #'template depth esc?)])
(displayln drivers)
(displayln guide)
(displayln props-guide)
(values (dset-add drivers mf)
(vector 'metafun mf guide)
(cons-guide '_ props-guide)))]

94
template-unsyntax-ellipsis.rkt Normal file
View File

@ -0,0 +1,94 @@
#lang racket
(require (for-syntax phc-toolkit/untyped
racket/contract
racket/private/sc)
syntax/parse/experimental/template
(prefix-in backport: backport-template-pr1514/experimental/template))
(provide escape)
(begin-for-syntax
(require racket/syntax)
(define/with-syntax ooo #'(... ...)))
(define-syntax (mysyntax stx)
(syntax-case stx ()
[(_ v)
#'(syntax (ooo v))]))
(define-for-syntax (force-expand e)
(define e1 (local-expand e 'expression (list #'quote
#'syntax
#'template
#'backport:template)))
;(displayln (list (syntax->datum e) (syntax->datum e1)))
(syntax-case e1 (syntax template backport:template
begin quote set! #%plain-lambda
;; TODO:
case-lambda let-values
letrec-values if begin0 with-continuation-mark
letrec-syntaxes+values #%plain-app #%expression #%top
#%variable-reference)
[(begin _ ...)
(datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
[(set! _ ...)
(datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
[(#%plain-lambda args body ...)
(datum->syntax e1 (list (stx-car e1)
#'args
(stx-map force-expand #'(body ...)))
e1 e1)]
[(quote _)
e1]
[(syntax . rest)
(displayln (syntax->datum #'rest))
#`(quote-syntax #,e1)]
[(template . rest)
(displayln (syntax->datum #'rest))
#`(quote-syntax #,e1)]
[(backport:template . rest)
(displayln (syntax->datum #'rest))
#`(quote-syntax #,e1)]
[(_ ...)
(datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
[_
e1]))
;make-syntax-mapping syntax-pattern-variable?
;syntax-mapping-depth syntax-mapping-valvar
(define-syntax (escape stx)
(syntax-case stx ()
[(_ body)
(force-expand #'body)]))
;; Doesn't work.
#;(begin
(define-for-syntax exn-ellipses/c
(struct/c exn:fail:syntax
(regexp-match/c
#px"syntax: too few ellipses for pattern variable in template")
any/c
(list/c identifier?)))
(define-syntax (escape stx)
(syntax-case stx ()
[(_ body)
(let ()
(define used-pvars '())
(define (push-pvar! pvar)
(set! used-pvars (cons pvar used-pvars)))
;(let loop ([used-pvars '()])
(with-handlers ([exn-ellipses/c
(λ (exn)
;; Can't do syntax-local-value :-(
(displayln (syntax-local-value (car (exn:fail:syntax-exprs exn))))
(push-pvar! (car (exn:fail:syntax-exprs exn))))])
(local-expand #'body 'expression (list)))
;(displayln (syntax-pattern-variable? (syntax-local-value (car used-pvars))))
(with-handlers ([exn-ellipses/c
(λ (exn)
(push-pvar! (car (exn:fail:syntax-exprs exn))))])
(displayln (local-expand #'body 'expression (list))))
#'(void))])))

18
test-template-unsyntax-ellipsis.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket
(require "template-unsyntax-ellipsis.rkt"
syntax/stx
syntax/parse/experimental/template)
#;(syntax-case #'((1 2) (3 4)) ()
[((x ...) ...)
(escape (stx-map (λ (xᵢ) (+ (syntax-e xᵢ) 1))
(template (x ...))))])
(syntax-case #'((1 2) (3 4)) ()
[((x ...) ...)
(escape (stx-map (λ (xᵢ)
(define-syntax (a stx)
(datum->syntax stx (string->symbol xᵢ)))
(a)
(+ (syntax-e xᵢ) 1))
#'(x ...)))])