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 define
let let
(rename-out [begin #%intef-begin]) (rename-out [begin #%intef-begin])
(rename-out [app #%app])) (rename-out [app #%app])
??
?@)
(require subtemplate/ddd (require subtemplate/ddd
stxparse-info/case stxparse-info/case
@ -91,15 +93,31 @@
(begin-for-syntax (begin-for-syntax
(define-splicing-syntax-class arg (define-splicing-syntax-class arg
(pattern {~seq e:expr ooo*:ooo+} (pattern {~seq e:expr ooo*:ooo+}
#:with expanded (ddd* e ooo*)) #:with expanded #`(splicing-list #,(ddd* e ooo*)))
(pattern other (pattern other
#:with expanded #'(#%app list other)))) ;#:with expanded #'(#%app list other)
#:with expanded #'other)))
(define-syntax app (define-syntax app
(syntax-parser (syntax-parser
[(_ fn {~and arg {~not {~literal …}}} …) #;[(_ fn {~and arg {~not {~literal …}}} …) ;; TODO: check for ?@ too
#'(#%app fn arg …)] #'(#%app fn arg …)]
[{~and (_ fn arg:arg …) [{~and (_ fn arg:arg …)
{~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a … {~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 [(_ 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*]))

71
ddd.rkt
View File

@ -1,6 +1,6 @@
#lang racket #lang racket
(provide ddd) (provide ddd ?? ?@ splicing-list splicing-list-l splicing-list?)
(require stxparse-info/current-pvars (require stxparse-info/current-pvars
phc-toolkit/untyped phc-toolkit/untyped
@ -79,7 +79,7 @@
#`(let-values () #`(let-values ()
(quote-syntax #,(x-pvar-present-marker #'present-variables)) (quote-syntax #,(x-pvar-present-marker #'present-variables))
body)) body)) ;;;;;;;;;;;;;;;;;;;;;; expanded-body
(define (=* . vs) (define (=* . vs)
(if (< (length vs) 2) (if (< (length vs) 2)
@ -98,8 +98,8 @@
"incompatible ellipis counts for template")) "incompatible ellipis counts for template"))
(apply map f l*)) (apply map f l*))
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …) (define-for-syntax (current-pvars-shadowers)
(remove-duplicates (remove-duplicates
(map syntax-local-get-shadower (map syntax-local-get-shadower
(map syntax-local-introduce (map syntax-local-introduce
@ -110,29 +110,62 @@
(reverse (current-pvars))))) (reverse (current-pvars)))))
bound-identifier=?)) bound-identifier=?))
(define-temp-ids "~aᵢ" (pvar …)) (define-for-syntax (extract-present-variables expanded-form stx)
(define/with-syntax f (define present-variables** (find-present-variables-vector expanded-form))
#`(#%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))))
;; 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* (define present-variables*
(and (vector? present-variables**) (and (vector? present-variables**)
(vector->list present-variables**))) (vector->list present-variables**)))
(unless ((listof (syntax/c boolean?)) present-variables*) (unless ((listof (syntax/c boolean?)) present-variables*)
(displayln expanded-form)
(raise-syntax-error 'ddd (raise-syntax-error 'ddd
(string-append (string-append
"internal error: could not extract the vector of" "internal error: could not extract the vector of"
" pattern variables present in the body.") " pattern variables present in the body.")
stx)) stx))
(define present-variables (map syntax-e present-variables*))) (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ᵢ) …
(detect-present-pvars (pvar …)
body)))
;; extract all the variable ids present in f
(define/with-syntax expanded-f (local-expand #'f 'expression '()))
(define present-variables (extract-present-variables #'expanded-f stx))
(unless (ormap identity present-variables) (unless (ormap identity present-variables)
(raise-syntax-error 'ddd (raise-syntax-error 'ddd
@ -146,7 +179,7 @@
[pv (in-syntax #'(pvar …))] [pv (in-syntax #'(pvar …))]
[pvᵢ (in-syntax #'(pvarᵢ …))]) [pvᵢ (in-syntax #'(pvarᵢ …))])
(if present? (if present?
(match (attribute-info pv) (match (attribute-info pv '(pvar attr))
[(list* _ _valvar depth _) [(list* _ _valvar depth _)
(if (> depth 0) (if (> depth 0)
(list #t pv pvᵢ #t depth) (list #t pv pvᵢ #t depth)

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))