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

Support for ?? and ?@

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-01 09:57:23 +01:00
parent 5580d9ee2c
commit 762446fa42
3 changed files with 144 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
ddd-forms.rkt
View File

@ -3,7 +3,9 @@
define
let
(rename-out [begin #%intef-begin])
(rename-out [app #%app]))
(rename-out [app #%app])
??
?@)
(require subtemplate/ddd
stxparse-info/case
@ -91,15 +93,31 @@
(begin-for-syntax
(define-splicing-syntax-class arg
(pattern {~seq e:expr ooo*:ooo+}
#:with expanded (ddd* e ooo*))
#:with expanded #`(splicing-list #,(ddd* e ooo*)))
(pattern other
#:with expanded #'(#%app list other))))
;#:with expanded #'(#%app list other)
#:with expanded #'other)))
(define-syntax app
(syntax-parser
[(_ fn {~and arg {~not {~literal …}}} …)
#;[(_ fn {~and arg {~not {~literal …}}} …) ;; TODO: check for ?@ too
#'(#%app fn arg …)]
[{~and (_ fn arg:arg …)
{~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
#'(#%app apply fn (#%app append arg.expanded …))]
;#'(#%app apply fn (#%app append arg.expanded …))
#'(#%app apply fn (#%app splice-append arg.expanded …))]
[(_ arg:arg …) ;; shorthand for list creation
#'(#%app apply list (#%app append arg.expanded …))]))
;#'(#%app apply list (#%app append arg.expanded …))
#'(#%app apply list (#%app splice-append arg.expanded …))]))
(define (splice-append . l*) (splice-append* l*))
(define (splice-append* l*)
(cond
[(pair? l*)
(if (splicing-list? (car l*))
(append (splice-append* (splicing-list-l (car l*)))
(splice-append* (cdr l*)))
(cons (car l*) (splice-append* (cdr l*))))]
[(splicing-list? l*)
(splicing-list-l l*)]
[else ;; should be null.
l*]))

79
ddd.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(provide ddd)
(provide ddd ?? ?@ splicing-list splicing-list-l splicing-list?)
(require stxparse-info/current-pvars
phc-toolkit/untyped
@ -79,7 +79,7 @@
#`(let-values ()
(quote-syntax #,(x-pvar-present-marker #'present-variables))
body))
body)) ;;;;;;;;;;;;;;;;;;;;;; expanded-body
(define (=* . vs)
(if (< (length vs) 2)
@ -98,9 +98,9 @@
"incompatible ellipis counts for template"))
(apply map f l*))
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …)
(remove-duplicates
(define-for-syntax (current-pvars-shadowers)
(remove-duplicates
(map syntax-local-get-shadower
(map syntax-local-introduce
(filter (conjoin identifier?
@ -109,30 +109,63 @@
attribute-real-valvar)
(reverse (current-pvars)))))
bound-identifier=?))
(define-for-syntax (extract-present-variables expanded-form stx)
(define present-variables** (find-present-variables-vector expanded-form))
(define present-variables*
(and (vector? present-variables**)
(vector->list present-variables**)))
(unless ((listof (syntax/c boolean?)) present-variables*)
(displayln expanded-form)
(raise-syntax-error 'ddd
(string-append
"internal error: could not extract the vector of"
" pattern variables present in the body.")
stx))
(define present-variables (map syntax-e present-variables*))
present-variables)
(struct splicing-list (l))
;; TODO: dotted rest, identifier macro
#;(define-syntax-rule (?@ v ...)
(splicing-list (list v ...)))
(define ?@ (compose splicing-list list))
(define-syntax/case (?? a b) ()
(define/with-syntax (pvar …) (current-pvars-shadowers))
(define/with-syntax expanded-a
(local-expand #'(detect-present-pvars (pvar …) a) 'expression '()))
(define present-variables (extract-present-variables #'expanded-a stx))
(define/with-syntax (test-present-attribute …)
(for/list ([present? (in-list present-variables)]
[pv (in-syntax #'(pvar …))]
#:when present?
;; only attributes can have missing elements.
#:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
#`(attribute* #,pv)))
#'(if (and test-present-attribute …)
a
b))
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …) (current-pvars-shadowers))
(define-temp-ids "~aᵢ" (pvar …))
(define/with-syntax f
#`(#%plain-lambda (pvarᵢ …)
(shadow pvar pvarᵢ) … ;; TODO: find a way to make the variable marked as "missing" if it is #f ? So that it triggers an error if used outside of ??
(let-values ()
(detect-present-pvars (pvar …)
body))))
(shadow pvar pvarᵢ) …
(detect-present-pvars (pvar …)
body)))
;; extract all the variable ids present in f
(define/with-syntax expanded-f (local-expand #'f 'expression '()))
(begin
(define present-variables** (find-present-variables-vector #'expanded-f))
(define present-variables*
(and (vector? present-variables**)
(vector->list present-variables**)))
(unless ((listof (syntax/c boolean?)) present-variables*)
(raise-syntax-error 'ddd
(string-append
"internal error: could not extract the vector of"
" pattern variables present in the body.")
stx))
(define present-variables (map syntax-e present-variables*)))
(define present-variables (extract-present-variables #'expanded-f stx))
(unless (ormap identity present-variables)
(raise-syntax-error 'ddd
@ -146,7 +179,7 @@
[pv (in-syntax #'(pvar …))]
[pvᵢ (in-syntax #'(pvarᵢ …))])
(if present?
(match (attribute-info pv)
(match (attribute-info pv '(pvar attr))
[(list* _ _valvar depth _)
(if (> depth 0)
(list #t pv pvᵢ #t depth)
@ -231,4 +264,4 @@
(syntax-e (second present?+pvar))
(fifth present?+pvar)))
(filter fourth present?+pvars))
"\n "))))
"\n "))))

64
test/test-optional.rkt Normal file
View File

@ -0,0 +1,64 @@
#lang racket
(require subtemplate/ddd-forms
stxparse-info/case
stxparse-info/parse
rackunit
syntax/macro-testing
phc-toolkit/untyped)
;; TODO: allow the overridden ?? and ?@ in template.
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(?? x 'missing) …])
'(1 missing 3))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?@ 1 2 3))])
'(1 2 3))
(check-equal? (syntax-parse #'(1 2 3)
[(x …)
(list (x ...) 4 5)])
'((1 2 3) 4 5))
(check-equal? (syntax-parse #'(1 2 3)
[(x …)
(list (?@ x ...) 4 5)])
'(1 2 3 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?@ x) ... 4 5)])
'(1 #f 3 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list ((?@ x) ...) 4 5)])
'((1 #f 3) 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?@ 'x 'is x) ... 4 5)])
'(x is 1 x is #f x is 3 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list ((?@ 'x 'is x) ...) 4 5)])
'((x is 1 x is #f x is 3) 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?? (?@ 'x 'is x) 'nothing-here) ... 4 5)])
'(x is 1 nothing-here x is 3 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?? (?@ 'x 'is x) (?@ 'nothing 'here)) ... 4 5)])
'(x is 1 nothing here x is 3 4 5))
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?? (?@ 'x 'is x) (list 'nothing 'here)) ... 4 5)])
'(x is 1 (nothing here) x is 3 4 5))