commit 762446fa4253c46c806600d59383944d26fc9168
parent 5580d9ee2cf2ac131301648f8363f58cf3dd74ad
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 1 Feb 2017 09:57:23 +0100
Support for ?? and ?@
Diffstat:
| M | ddd-forms.rkt | | | 31 | +++++++++++++++++++++++++------ |
| M | ddd.rkt | | | 80 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------ |
| A | test/test-optional.rkt | | | 65 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
3 files changed, 146 insertions(+), 30 deletions(-)
diff --git a/ddd-forms.rkt b/ddd-forms.rkt
@@ -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*]))
+\ No newline at end of file
diff --git a/ddd.rkt b/ddd.rkt
@@ -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 "))))
-\ No newline at end of file
+ "\n "))))
diff --git a/test/test-optional.rkt b/test/test-optional.rkt
@@ -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))
+\ No newline at end of file
