From e7e60b1da9696abc6eb9a4de4614cdc346e1f5dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 3 Feb 2017 11:54:40 +0100
Subject: [PATCH] More ?operations

---
 ddd-forms.rkt          |   8 ++-
 ddd.rkt                |  70 ++++++++++++++++++------
 test/test-optional.rkt |   4 +-
 test/test-or.rkt       |  45 ++++++++++++++++
 test/test-splice.rkt   |  21 ++++----
 unsyntax-preparse.rkt  | 119 +++++++++++++++++++++++++++++++----------
 6 files changed, 208 insertions(+), 59 deletions(-)
 create mode 100644 test/test-or.rkt

diff --git a/ddd-forms.rkt b/ddd-forms.rkt
index dd84fa4..2d63fb0 100644
--- a/ddd-forms.rkt
+++ b/ddd-forms.rkt
@@ -5,7 +5,11 @@
          (rename-out [begin #%intef-begin])
          (rename-out [app #%app])
          ??
+         ?if
+         ?cond
+         ?attr
          ?@
+         ?@@
          splice-append
          splice-append*
          splicing-list?
@@ -94,8 +98,8 @@
 (define-syntax/parse (begin stmt:stmt …)
   (template (-begin (?@ stmt.expanded) …)))
 
-(define-syntax/parse (let ([var . val] …) . body)
-  (template (-let ([var (begin . val)] …) (begin . body))))
+(define-syntax/parse (let {~optional name:id} ([var . val] …) . body)
+  (template (-let (?? name) ([var (begin . val)] …) (begin . body))))
 
 (begin-for-syntax
   (define-splicing-syntax-class arg
diff --git a/ddd.rkt b/ddd.rkt
index 2ca8ba9..419cd21 100644
--- a/ddd.rkt
+++ b/ddd.rkt
@@ -1,6 +1,7 @@
 #lang racket
 
-(provide ddd ?? ?@ splicing-list splicing-list-l splicing-list?)
+(provide ddd ?? ?if ?cond ?attr ?@ ?@@
+         splicing-list splicing-list-l splicing-list?)
 
 (require stxparse-info/current-pvars
          phc-toolkit/untyped
@@ -38,8 +39,8 @@
     (if (syntax-local-value valvar (λ () #f)) ;; is it a macro-ish thing?
         (begin
           (log-warning
-           (string-append "Could not extract the plain variable corresponding to"
-                          " the pattern variable or attribute ~a"
+           (string-append "Could not extract the plain variable corresponding"
+                          " to the pattern variable or attribute ~a"
                           (syntax-e attr)))
           #f)
         valvar)))
@@ -54,7 +55,9 @@
 
   (define/with-syntax expanded-body
     (local-expand #`(let-values ()
-                      (quote-syntax #,(stx-map x-pvar-scope #'(pvar-real-valvar …)) #:local)
+                      (quote-syntax #,(stx-map x-pvar-scope
+                                               #'(pvar-real-valvar …))
+                                    #:local)
                       body)
                   'expression
                   '()))
@@ -132,20 +135,24 @@
 #;(define-syntax-rule (?@ v ...)
     (splicing-list (list v ...)))
 (define (?@ . vs) (splicing-list vs))
+(define (?@@ . vs) (map splicing-list vs))
 
-(define-syntax (?? stx)
+(define-for-syntax ((?* mode) stx)
   (define (parse stx)
     (syntax-case stx ()
-      [(self a)
-       (parse (datum->syntax stx `(,#'self ,#'a ,#'(?@)) stx stx))]
-      [(_ a b)
+      [(self condition a)
+       (?* (datum->syntax stx `(,#'self ,#'c ,#'a ,#'(?@)) stx stx))]
+      [(_ condition a b)
        (let ()
          (define/with-syntax (pvar …) (current-pvars-shadowers))
 
-         (define/with-syntax expanded-a
-           (local-expand #'(detect-present-pvars (pvar …) a) 'expression '()))
+         (define/with-syntax expanded-condition
+           (local-expand #'(detect-present-pvars (pvar …) condition)
+                         'expression
+                         '()))
 
-         (define present-variables (extract-present-variables #'expanded-a stx))
+         (define present-variables
+           (extract-present-variables #'expanded-condition stx))
 
          (define/with-syntax (test-present-attribute …)
            (for/list ([present? (in-list present-variables)]
@@ -154,13 +161,46 @@
                       ;; only attributes can have missing elements.
                       #:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
              #`(attribute* #,pv)))
-             
-
-         #'(if (and test-present-attribute …)
-               a
+         
+         #`(if (and test-present-attribute …)
+               #,(if (eq? mode 'if) #'a #'condition)
                b))]))
   (parse stx))
 
+(define-syntax ?if (?* 'if))
+
+(define-syntax (?cond stx)
+  (syntax-case stx (else)
+    [(self) #'(raise-syntax-error '?cond
+                                  "all branches contain omitted elements"
+                                  self)]
+    [(self [else]) #'(?@)]
+    [(self [else . v]) #'(begin . v)]
+    [(self [condition v . vs] . rest)
+     (not (free-identifier=? #'condition #'else))
+     (let ([else (datum->syntax stx `(,#'self . ,#'rest) stx stx)])
+       (datum->syntax stx
+                      `(,#'?if ,#'condition ,#'(begin v . vs) . ,else)
+                      stx
+                      stx))]))
+
+(define-syntax (?attr stx)
+  (syntax-case stx ()
+    [(self condition)
+     (datum->syntax stx `(,#'?if ,#'condition #t #f) stx stx)]))
+
+(define-syntax (?? stx)
+  (define (parse stx)
+    (syntax-case stx ()
+      [(self a)
+       ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'(?@)) stx stx))]
+      [(self a b)
+       ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'b) stx stx))]
+      [(self a b c . rest)
+       (let ([else (datum->syntax stx `(,#'self ,#'b ,#'c . ,#'rest) stx stx)])
+         (datum->syntax stx `(,#'self ,#'a ,else) stx stx))]))
+  (parse stx))
+
 (define-syntax/case (ddd body) ()
   (define/with-syntax (pvar …) (current-pvars-shadowers))
   
diff --git a/test/test-optional.rkt b/test/test-optional.rkt
index ba790dd..a7df09f 100644
--- a/test/test-optional.rkt
+++ b/test/test-optional.rkt
@@ -6,8 +6,6 @@
          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) …])
@@ -61,4 +59,4 @@
 (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
+              '(x is 1 (nothing here) x is 3 4 5))
diff --git a/test/test-or.rkt b/test/test-or.rkt
new file mode 100644
index 0000000..1f27115
--- /dev/null
+++ b/test/test-or.rkt
@@ -0,0 +1,45 @@
+#lang racket
+
+(require subtemplate/ddd
+         subtemplate/unsyntax-preparse
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit)
+
+(define (test-??-all v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean}
+       {~optional d:keyword})
+      (quasitemplate-ddd (?? a b c d))])))
+
+(check-equal? (test-??-all #'(1 x #f #:kw)) '1)
+(check-equal? (test-??-all #'(x #f #:kw)) 'x)
+(check-equal? (test-??-all #'(#f #:kw)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+(check-equal? (test-??-all #'(1)) '1)
+(check-equal? (test-??-all #'(x)) 'x)
+(check-equal? (test-??-all #'(#f)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+(define (test-?cond v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean}
+       {~optional d:keyword})
+      (quasitemplate-ddd (?cond [a 10] [b 20] [c 30] [d 40]))])))
+
+(check-equal? (test-?cond #'(1 x #f #:kw)) 10)
+(check-equal? (test-?cond #'(x #f #:kw)) 20)
+(check-equal? (test-?cond #'(#f #:kw)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
+
+(check-equal? (test-?cond #'(1)) 10)
+(check-equal? (test-?cond #'(x)) 20)
+(check-equal? (test-?cond #'(#f)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
diff --git a/test/test-splice.rkt b/test/test-splice.rkt
index 5ea123a..93d9057 100644
--- a/test/test-splice.rkt
+++ b/test/test-splice.rkt
@@ -1,13 +1,12 @@
 #lang racket
 
-(require subtemplate/top-subscripts
-         subtemplate/ddd-forms
-         subtemplate/unsyntax-preparse
-         subtemplate/template-subscripts
-         (except-in subtemplate/override ?? ?@)
-         stxparse-info/case
-         stxparse-info/parse
-         rackunit
-         syntax/macro-testing
-         phc-toolkit/untyped
-         (only-in racket/base [... …]))
\ No newline at end of file
+(require subtemplate/ddd-forms
+         rackunit)
+
+(check-equal? (let ([l '(4 5 6)])
+                (vector (?@ 1 2 3 . l)))
+              #(1 2 3 4 5 6))
+
+(check-equal? (let ([l '(4 5 6)])
+                (vector (?@ 1 2 3 (?@ . l) 7 8 9)))
+              #(1 2 3 4 5 6 7 8 9))
\ No newline at end of file
diff --git a/unsyntax-preparse.rkt b/unsyntax-preparse.rkt
index 53e4bf6..90b8574 100644
--- a/unsyntax-preparse.rkt
+++ b/unsyntax-preparse.rkt
@@ -11,6 +11,7 @@
          (only-in racket/base [... …])
          stxparse-info/parse
          stxparse-info/case
+         syntax/stx
          (for-syntax racket/base
                      racket/list
                      racket/syntax
@@ -20,7 +21,7 @@
 
 (define-for-syntax lifted (make-parameter #f))
 
-(define-for-syntax (pre-parse-unsyntax tmpl depth escapes)
+(define-for-syntax (pre-parse-unsyntax tmpl depth escapes quasi? form)
   ;; TODO: a nested quasisubtemplate should escape an unsyntax!
   (define (ds e)
     ;; TODO: should preserve the shape of the original stx
@@ -28,13 +29,12 @@
     (datum->syntax tmpl e tmpl tmpl))
   (define-syntax-class ooo
     (pattern {~and ooo {~literal ...}}))
-  (define (recur t) (pre-parse-unsyntax t depth escapes))
+  (define (recur t) (pre-parse-unsyntax t depth escapes quasi? form))
   (define (stx-length stx) (length (syntax->list stx)))
   (define (lift! e) (set-box! (lifted) (cons e (unbox (lifted)))))
   (syntax-parse tmpl
     #:literals (unsyntax unsyntax-splicing unquote unquote-splicing
-                         quasitemplate ?? ?@)
-    [:id tmpl]
+                         quasitemplate ?? ?if ?cond ?attr ?@ ?@@)
     [({~and u unsyntax} (unquote e)) ;; full unquote with #,,
      (ds `(,#'u ,#'e))]
     [({~and u unsyntax-splicing} (unquote e)) ;; full unquote with #,@,
@@ -42,59 +42,122 @@
     [({~and u unsyntax} (unquote-splicing e)) ;; full unquote with #,,@
      (ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))]
     [({~and u unsyntax} e)
-     #:when (= escapes 0)
+     #:when (and (= escapes 0) quasi?)
      (with-syntax ([tmp (generate-temporary #'e)]
                    [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
        (lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*))
        (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))]
     [({~and u unsyntax-splicing} e)
-     #:when (= escapes 0)
+     #:when (and (= escapes 0) quasi?)
      (with-syntax ([tmp (generate-temporary #'e)]
                    [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
        (lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*))
        #'(stxparse:?@ . tmp))]
     [({~and u {~or unsyntax unsyntax-splicing}} e)
-     ;; when escapes ≠ 0
-     (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes))))]
+     ;; when escapes ≠ 0 (or quasi? is #false)
+     (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes) quasi? form)))]
     [(quasitemplate t . opts)
-     (ds `(,#'quasitemplate ,(pre-parse-unsyntax #'t depth (add1 escapes))
-                            . ,#'opts))]
-    [({~var mf (static template-metafunction? "template metafunction")} . args)
-     (ds `(,#'mf . ,(recur #'args)))]
+     (ds `(,#'quasitemplate
+           ,(pre-parse-unsyntax #'t depth (add1 escapes) quasi? form)
+           . ,#'opts))]
+    [({~and self ?if} condition a b)
+     (with-syntax ([tmp (generate-temporary #'self)]
+                   [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+       (lift! #`(begin (define/with-syntax tmp (?if #,(form (recur #'condition))
+                                                    #,(form (recur #'(a)))
+                                                    #,(form (recur #'(b)))))
+                       . ooo*))
+       #'(stxparse:?@ . tmp))]
+    [({~and self ?cond} [{~and condition {~not {~literal else}}} . v] . rest)
+     (recur (ds `(,#'?if ,#'condition
+                         ,(ds `(,#'?@ . ,#'v))
+                         ,(ds `(,#'self . ,#'rest)))))]
+    [({~and self ?cond} [{~literal else}] . rest)
+     #'(stxparse:?@)]
+    [({~and self ?cond} [{~literal else} . v] . rest)
+     (recur #'(?@ . v))]
+    [({~and self ?@@} . e)
+     (with-syntax ([tmp (generate-temporary #'self)]
+                   [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+       (lift! #`(begin (define/with-syntax tmp
+                         (append* (stx-map*syntax->list #,(form #'e))))
+                       . ooo*))
+       #'(stxparse:?@ . tmp))]
+    [({~and self ?attr} condition)
+     (recur (ds `(,#'?if ,#'condition
+                         #t
+                         #f)))]
     [(:ooo t)
      tmpl] ;; fully escaped, do not change
-    [(?? . args)
-     (ds `(,#'stxparse:?? . ,(recur #'args)))]
+    [({~and self ??} a b c . rest)
+     (ds `(,#'stxparse:?? ,(recur #'a)
+                          ,(recur (ds `(,#'self ,#'b ,#'c . ,#'rest)))))]
+    [(?? a b)
+     (ds `(,#'stxparse:?? ,(recur #'a) ,(recur #'b)))]
+    [(?? a)
+     (ds `(,#'stxparse:?? ,(recur #'a)))]
     [(?@ . args)
      (ds `(,#'stxparse:?@ . ,(recur #'args)))]
+    [({~var mf (static template-metafunction? "template metafunction")} . args)
+     (ds `(,#'mf . ,(recur #'args)))]
     [(hd :ooo ...+ . tl)
-     (ds `(,(pre-parse-unsyntax #'hd (+ depth (stx-length #'(ooo …))) escapes)
+     (ds `(,(pre-parse-unsyntax #'hd
+                                (+ depth (stx-length #'(ooo …)))
+                                escapes
+                                quasi?
+                                form)
            ,@(syntax->list #'(ooo ...))
            . ,(recur #'tl)))]
     [(hd . tl)
      (ds `(,(recur #'hd) . ,(recur #'tl)))]
     [#(t …)
      (ds (list->vector (stx-map recur #'(t …))))]
-    [()
-     tmpl]))
+    ;; other ids, empty list, numbers, strings, chars, …
+    [_ tmpl]))
 
-(define-for-syntax ((quasi*template-ddd form) stx)
+(define (check-single-result result stx form)
+  (unless (and (stx-pair? result) (stx-null? (stx-cdr result)))
+    (raise-syntax-error form
+                        (string-append "the outer ?@ in the template produced"
+                                       " more than one syntax object")
+                        stx))
+  (stx-car result))
+
+(define-for-syntax ((*template-ddd quasi? form) stx)
   (syntax-case stx ()
     [(_ tmpl . opts)
      (parameterize ([lifted (box '())])
-       (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0)])
+       (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0 quasi?
+                                           (λ (e) #`(#,form #,e . opts)))])
          (if (null? (unbox (lifted)))
              (datum->syntax stx
                             `(,form ,new-tmpl . ,#'opts)
                             stx
                             stx)
-             (quasisyntax/top-loc stx
-               (let-values ()
-                 #,@(unbox (lifted))
-                 #,(datum->syntax stx
-                                  `(,form ,new-tmpl . ,#'opts)
-                                  stx
-                                  stx))))))]))
+             ((λ (~)
+                ;(local-require racket/pretty)
+                ;(pretty-write (syntax->datum ~))
+                ~)
+              (quasisyntax/top-loc stx
+                (let-values ()
+                  #,@(reverse (unbox (lifted)))
+                  (define result
+                    #,(datum->syntax stx
+                                     `(,form (,new-tmpl) . ,#'opts)
+                                     stx
+                                     stx))
+                  (check-single-result result (quote-syntax stx) 'form)))))))]))
 
-(define-syntax quasitemplate-ddd (quasi*template-ddd #'quasitemplate))
-(define-syntax quasisubtemplate-ddd (quasi*template-ddd #'quasisubtemplate))
+(define-syntax quasitemplate-ddd (*template-ddd #t #'quasitemplate))
+(define-syntax quasisubtemplate-ddd (*template-ddd #t #'quasisubtemplate))
+(define-syntax template-ddd (*template-ddd #t #'template))
+(define-syntax subtemplate-ddd (*template-ddd #t #'subtemplate))
+
+(define (stx-map*syntax->list e)
+  (let loop ([l (syntax->list e)])
+    (cond
+      [(null? l) l]
+      [(pair? l) (cons (syntax->list (car l)) (loop (cdr l)))]
+      ;; Special treatment for the last element of e: it does not need to
+      ;; be a list (as long as ?@ is used in tail position).
+      [else l])))
\ No newline at end of file