From 41013e5ef404e853e89e9490eedcfc874aef1a06 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Wed, 5 Oct 2016 18:54:43 +0200
Subject: [PATCH] Nearly finished subtemplate.

---
 info.rkt                  |   3 +-
 subtemplate.rkt           | 162 +++++++++++++++++++++++++++++
 test/test-subtemplate.rkt | 208 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 372 insertions(+), 1 deletion(-)
 create mode 100644 subtemplate.rkt
 create mode 100644 test/test-subtemplate.rkt

diff --git a/info.rkt b/info.rkt
index d2d4da1..1ec3f81 100644
--- a/info.rkt
+++ b/info.rkt
@@ -7,7 +7,8 @@
                "type-expander"
                "hyper-literate"
                "scribble-enhanced"
-               "typed-racket-lib"))
+               "typed-racket-lib"
+               "srfi-lite-lib"))
 (define build-deps '("scribble-lib"
                      "racket-doc"
                      "remember"
diff --git a/subtemplate.rkt b/subtemplate.rkt
new file mode 100644
index 0000000..c5bf232
--- /dev/null
+++ b/subtemplate.rkt
@@ -0,0 +1,162 @@
+#lang racket
+(require phc-toolkit/untyped
+         racket/stxparam
+         syntax/parse
+         syntax/parse/experimental/template
+         syntax/id-table
+         racket/syntax
+         (for-syntax syntax/parse
+                     racket/private/sc
+                     racket/syntax
+                     racket/list
+                     racket/function
+                     phc-toolkit/untyped
+                     srfi/13
+                     racket/contract))
+
+(provide (rename-out [new-syntax-parse syntax-parse]
+                     [new-syntax-case syntax-case])
+         subtemplate
+         quasisubtemplate
+         (for-syntax find-subscript-binder)) ;; for testing only
+
+(define-syntax-parameter maybe-syntax-pattern-variable-ids '())
+(define-syntax-parameter pvar-values-id #f)
+
+(define-syntax/parse (new-syntax-parse . rest)
+  (quasisyntax/top-loc (stx-car stx)
+    (let ([the-pvar-values (make-free-id-table)])
+      (syntax-parameterize ([maybe-syntax-pattern-variable-ids
+                             (cons '#,(remove-duplicates
+                                       (filter symbol?
+                                               (flatten
+                                                (syntax->datum #'rest))))
+                                   (syntax-parameter-value
+                                    #'maybe-syntax-pattern-variable-ids))]
+                            [pvar-values-id (make-rename-transformer
+                                             #'the-pvar-values)])
+        (syntax-parse . rest))
+      #;(syntax-parse option …
+          [clause-pat
+           ;; HERE insert a hash table, to cache the uses
+           ;; lifting the define-temp-ids is not likely to work, as they
+           ;; need to define syntax pattern variables so that other macros
+           ;; can recognize them. Instead, we only lift the values, but still
+           ;; do the bindings around the subtemplate.
+           #:do (define #,(lifted-scope (syntax-local-introduce #'pvar-values)
+                                        'add)
+                  (make-free-id-table))
+           . clause-rest]
+          …))))
+
+(define-syntax/case (new-syntax-case . rest) ()
+  (quasisyntax/top-loc (stx-car stx)
+    (syntax-parameterize ([maybe-syntax-pattern-variable-ids
+                           (cons '#,(remove-duplicates
+                                     (filter symbol?
+                                             (flatten
+                                              (syntax->datum #'rest))))
+                                 (syntax-parameter-value
+                                  #'maybe-syntax-pattern-variable-ids))])
+      (syntax-case . rest))))
+
+(begin-for-syntax
+  (define/contract (string-suffix a b)
+    (-> string? string? string?)
+    (define suffix-length (string-suffix-length a b))
+    (substring a
+               (- (string-length a) suffix-length)))
+
+  (define/contract (subscript-binder? bound binder)
+    (-> identifier? identifier? (or/c #f string?))
+    (and (syntax-pattern-variable?
+          (syntax-local-value binder
+                              (thunk #f)))
+         (let* ([bound-string (symbol->string (syntax-e bound))]
+                [binder-string (symbol->string (syntax-e binder))]
+                [suffix (string-suffix bound-string binder-string)]
+                [subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
+           (and subs (car subs)))))
+
+  (define/contract (find-subscript-binder bound [fallback bound])
+    (->* (identifier?) (any/c) (or/c identifier? any/c))
+    (define result/scopes
+      (for/list ([scope (in-list
+                         (syntax-parameter-value
+                          #'maybe-syntax-pattern-variable-ids))])
+        (define result
+          (for*/list ([sym (in-list scope)]
+                      #:unless (string=? (symbol->string sym)
+                                         (identifier->string bound))
+                      [binder (in-value (datum->syntax bound sym))]
+                      [subscripts (in-value (subscript-binder? bound
+                                                               binder))]
+                      #:when subscripts)
+            (cons binder subscripts)))
+        (and (not (null? result))
+             (car (argmax (∘ string-length cdr) result)))))
+    (or (ormap identity result/scopes)
+        fallback))
+
+  (define/contract (nest-ellipses id n)
+    (-> identifier? exact-nonnegative-integer? syntax?)
+    (if (= n 0)
+        id
+        #`(#,(nest-ellipses id (sub1 n))
+           (… …)))))
+
+(define-syntax/case (derive bound binder stx-depth) ()
+  (define depth (syntax-e #'stx-depth))
+  (define/with-syntax bound-ddd (nest-ellipses #'bound depth))
+  (define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound))
+  (define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
+                                                       (syntax-e #'tmp-id))))
+  (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
+  (define/with-syntax binder-ddd (nest-ellipses #'binder depth))
+  ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
+  ;; that we retrieve the cached ones, so that two subtemplate within the same
+  ;; syntax-case or syntax-parse clause use the same derived ids.
+  ;; TODO: mark specially those bindings bound by (derive …) so that they are
+  ;; not seen as original bindings in nested subtemplates (e.g. with an
+  ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
+  ;; (syntax-parse #'(a b c)
+  ;;   [(xᵢ …)
+  ;;    (quasisubtemplate (yᵢ …
+  ;;                       #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
+  ;;                       zᵢ …))])
+  ;; the test above is not exactly right (zᵢ will still have the correct
+  ;; binding), but it gives the general idea.
+
+  #`(begin (define-temp-ids tmp-str binder-ddd)
+           (define cached (free-id-table-ref! pvar-values-id
+                                              (quote-syntax bound)
+                                              #'tmp-ddd))
+           (define/with-syntax bound-ddd cached)))
+
+(define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
+  (define acc '())
+  (define result
+    (quasisyntax/top-loc #'self
+      (#,tmpl-form
+       . #,(fold-syntax (λ (stx rec)
+                          (if (identifier? stx)
+                              (let ([binder (find-subscript-binder stx #f)])
+                                (when binder
+                                  (let ([depth (syntax-mapping-depth
+                                                (syntax-local-value binder))])
+                                    (set! acc `((,stx ,binder ,depth) . ,acc))))
+                                stx)
+                              (rec stx)))
+                        #'tmpl))))
+  ;; Make sure that we remove duplicates, otherwise we'll get errors if we use
+  ;; the same derived id twice.
+  (define/with-syntax ([bound binder depth] …)
+    (remove-duplicates acc free-identifier=? #:key car))
+  
+  #`(let ()
+      (derive bound binder depth)
+      …
+      #,result))
+
+(define-syntax subtemplate (sub*template #'template))
+(define-syntax quasisubtemplate (sub*template #'quasitemplate))
\ No newline at end of file
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
new file mode 100644
index 0000000..eb55a48
--- /dev/null
+++ b/test/test-subtemplate.rkt
@@ -0,0 +1,208 @@
+#lang racket
+(require "../subtemplate.rkt"
+         phc-toolkit/untyped
+         rackunit)
+
+(define-syntax (tst stx)
+  (syntax-case stx ()
+    [(_ tt)
+     #`'#,(find-subscript-binder #'tt #f)]))
+
+(check-false (syntax-case #'(a b) ()
+               [(_ x)
+                (tst x)]))
+
+(check-equal? (syntax-parse
+                  #'(a b c)
+                [(_ x yᵢ)
+                 (list (tst x)
+                       (tst wᵢ))])
+              '(#f yᵢ))
+
+(check-equal? (syntax->datum (syntax-parse #'(a b c d)
+                               [(_ xⱼ zᵢ …)
+                                (subtemplate foo)]))
+              'foo)
+
+(syntax-parse (syntax-parse #'(a b c d)
+                [(_ xⱼ zᵢ …)
+                 (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
+                       (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
+  [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
+    ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
+   (check free-identifier=? #'x1 #'x2)
+   (check free-identifier=? #'w1 #'w2)
+   (check free-identifier=? #'foo1 #'foo2)
+   (check free-identifier=? #'z1 #'z2)
+   (check free-identifier=? #'p1 #'p2)
+   (check free-identifier=? #'zz1 #'zz2)
+   (check free-identifier=? #'pp1 #'pp2)
+
+   (check free-identifier=? #'x1 #'b)
+   (check free-identifier=? #'z1 #'c)
+   (check free-identifier=? #'zz1 #'d)
+   
+   (check free-identifier=? #'x2 #'b)
+   (check free-identifier=? #'z2 #'c)
+   (check free-identifier=? #'zz2 #'d)
+
+   ;; The *1 are all different:
+   (check free-identifier=? #'x1 #'x1)
+   (check (∘ not free-identifier=?) #'x1 #'w1)
+   (check (∘ not free-identifier=?) #'x1 #'foo1)
+   (check (∘ not free-identifier=?) #'x1 #'z1)
+   (check (∘ not free-identifier=?) #'x1 #'p1)
+   (check (∘ not free-identifier=?) #'x1 #'zz1)
+   (check (∘ not free-identifier=?) #'x1 #'pp1)
+   
+   (check (∘ not free-identifier=?) #'w1 #'x1)
+   (check free-identifier=? #'w1 #'w1)
+   (check (∘ not free-identifier=?) #'w1 #'foo1)
+   (check (∘ not free-identifier=?) #'w1 #'z1)
+   (check (∘ not free-identifier=?) #'w1 #'p1)
+   (check (∘ not free-identifier=?) #'w1 #'zz1)
+   (check (∘ not free-identifier=?) #'w1 #'pp1)
+
+   (check (∘ not free-identifier=?) #'foo1 #'x1)
+   (check (∘ not free-identifier=?) #'foo1 #'w1)
+   (check free-identifier=? #'foo1 #'foo1)
+   (check (∘ not free-identifier=?) #'foo1 #'z1)
+   (check (∘ not free-identifier=?) #'foo1 #'p1)
+   (check (∘ not free-identifier=?) #'foo1 #'zz1)
+   (check (∘ not free-identifier=?) #'foo1 #'pp1)
+
+   (check (∘ not free-identifier=?) #'z1 #'x1)
+   (check (∘ not free-identifier=?) #'z1 #'w1)
+   (check (∘ not free-identifier=?) #'z1 #'foo1)
+   (check free-identifier=? #'z1 #'z1)
+   (check (∘ not free-identifier=?) #'z1 #'p1)
+   (check (∘ not free-identifier=?) #'z1 #'zz1)
+   (check (∘ not free-identifier=?) #'z1 #'pp1)
+
+   (check (∘ not free-identifier=?) #'p1 #'x1)
+   (check (∘ not free-identifier=?) #'p1 #'w1)
+   (check (∘ not free-identifier=?) #'p1 #'foo1)
+   (check (∘ not free-identifier=?) #'p1 #'z1)
+   (check free-identifier=? #'p1 #'p1)
+   (check (∘ not free-identifier=?) #'p1 #'zz1)
+   (check (∘ not free-identifier=?) #'p1 #'pp1)
+
+   (check (∘ not free-identifier=?) #'zz1 #'x1)
+   (check (∘ not free-identifier=?) #'zz1 #'w1)
+   (check (∘ not free-identifier=?) #'zz1 #'foo1)
+   (check (∘ not free-identifier=?) #'zz1 #'z1)
+   (check (∘ not free-identifier=?) #'zz1 #'p1)
+   (check free-identifier=? #'zz1 #'zz1)
+   (check (∘ not free-identifier=?) #'zz1 #'pp1)
+
+   (check (∘ not free-identifier=?) #'pp1 #'x1)
+   (check (∘ not free-identifier=?) #'pp1 #'w1)
+   (check (∘ not free-identifier=?) #'pp1 #'foo1)
+   (check (∘ not free-identifier=?) #'pp1 #'z1)
+   (check (∘ not free-identifier=?) #'pp1 #'p1)
+   (check (∘ not free-identifier=?) #'pp1 #'zz1)
+   (check free-identifier=? #'pp1 #'pp1)
+
+   ;; The *2 are all different:
+   (check free-identifier=? #'x2 #'x2)
+   (check (∘ not free-identifier=?) #'x2 #'w2)
+   (check (∘ not free-identifier=?) #'x2 #'foo2)
+   (check (∘ not free-identifier=?) #'x2 #'z2)
+   (check (∘ not free-identifier=?) #'x2 #'p2)
+   (check (∘ not free-identifier=?) #'x2 #'zz2)
+   (check (∘ not free-identifier=?) #'x2 #'pp2)
+   
+   (check (∘ not free-identifier=?) #'w2 #'x2)
+   (check free-identifier=? #'w2 #'w2)
+   (check (∘ not free-identifier=?) #'w2 #'foo2)
+   (check (∘ not free-identifier=?) #'w2 #'z2)
+   (check (∘ not free-identifier=?) #'w2 #'p2)
+   (check (∘ not free-identifier=?) #'w2 #'zz2)
+   (check (∘ not free-identifier=?) #'w2 #'pp2)
+
+   (check (∘ not free-identifier=?) #'foo2 #'x2)
+   (check (∘ not free-identifier=?) #'foo2 #'w2)
+   (check free-identifier=? #'foo2 #'foo2)
+   (check (∘ not free-identifier=?) #'foo2 #'z2)
+   (check (∘ not free-identifier=?) #'foo2 #'p2)
+   (check (∘ not free-identifier=?) #'foo2 #'zz2)
+   (check (∘ not free-identifier=?) #'foo2 #'pp2)
+
+   (check (∘ not free-identifier=?) #'z2 #'x2)
+   (check (∘ not free-identifier=?) #'z2 #'w2)
+   (check (∘ not free-identifier=?) #'z2 #'foo2)
+   (check free-identifier=? #'z2 #'z2)
+   (check (∘ not free-identifier=?) #'z2 #'p2)
+   (check (∘ not free-identifier=?) #'z2 #'zz2)
+   (check (∘ not free-identifier=?) #'z2 #'pp2)
+
+   (check (∘ not free-identifier=?) #'p2 #'x2)
+   (check (∘ not free-identifier=?) #'p2 #'w2)
+   (check (∘ not free-identifier=?) #'p2 #'foo2)
+   (check (∘ not free-identifier=?) #'p2 #'z2)
+   (check free-identifier=? #'p2 #'p2)
+   (check (∘ not free-identifier=?) #'p2 #'zz2)
+   (check (∘ not free-identifier=?) #'p2 #'pp2)
+
+   (check (∘ not free-identifier=?) #'zz2 #'x2)
+   (check (∘ not free-identifier=?) #'zz2 #'w2)
+   (check (∘ not free-identifier=?) #'zz2 #'foo2)
+   (check (∘ not free-identifier=?) #'zz2 #'z2)
+   (check (∘ not free-identifier=?) #'zz2 #'p2)
+   (check free-identifier=? #'zz2 #'zz2)
+   (check (∘ not free-identifier=?) #'zz2 #'pp2)
+
+   (check (∘ not free-identifier=?) #'pp2 #'x2)
+   (check (∘ not free-identifier=?) #'pp2 #'w2)
+   (check (∘ not free-identifier=?) #'pp2 #'foo2)
+   (check (∘ not free-identifier=?) #'pp2 #'z2)
+   (check (∘ not free-identifier=?) #'pp2 #'p2)
+   (check (∘ not free-identifier=?) #'pp2 #'zz2)
+   (check free-identifier=? #'pp2 #'pp2)])
+
+(syntax-parse (syntax-parse #'(a b c)
+                [(xᵢ …)
+                 (define flob (quasisubtemplate (zᵢ …)))
+                 (quasisubtemplate (yᵢ …
+                                    #,flob
+                                    zᵢ …))])
+  [(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
+   (check free-identifier=? #'a2 #'a3)
+   (check free-identifier=? #'b2 #'b3)
+   (check free-identifier=? #'c2 #'c3)
+   (check (∘ not free-identifier=?) #'a1 #'a2)
+   (check (∘ not free-identifier=?) #'b1 #'b2)
+   (check (∘ not free-identifier=?) #'c1 #'c2)])
+
+(syntax-parse (syntax-parse #'(a b c)
+                [(xᵢ …)
+                 (quasisubtemplate (yᵢ …
+                                    ;; must be from xᵢ, not yᵢ
+                                    #,(quasisubtemplate (zᵢ …))
+                                    zᵢ …))])
+  [(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
+   (check free-identifier=? #'a2 #'a3)
+   (check free-identifier=? #'b2 #'b3)
+   (check free-identifier=? #'c2 #'c3)
+   (check (∘ not free-identifier=?) #'a1 #'a2)
+   (check (∘ not free-identifier=?) #'b1 #'b2)
+   (check (∘ not free-identifier=?) #'c1 #'c2)])
+;; the test above is not exactly right (zᵢ will still have the correct
+;; binding), but it gives the general idea.
+
+(syntax->datum
+ (syntax-parse #'(a b c)
+   [(xᵢ …)
+    (define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
+    (quasisubtemplate (yᵢ …
+                       ;; must be from xᵢ, not yᵢ
+                       #,flob
+                       zᵢ …))]))
+
+(syntax->datum
+ (syntax-parse #'(a b c)
+   [(xᵢ …)
+    (quasisubtemplate (yᵢ …
+                       ;; must be from xᵢ, not yᵢ
+                       #,(syntax-parse #'d [d (quasisubtemplate (zᵢ …))])
+                       zᵢ …))]))