Implements FB case 116 "Allow declaring private (i.e. unique) variants, which inherit the more general shared ones with the same tag"

graph-lib/graph/__DEBUG_variant.rkt

@@ -21,6 +21,10 @@
                            (constructor dh1 Number String))
                       (constructor dh1 2 "y"))
        
+       (define-private-tagged txyz #:? txyz?
+         [a Number]
+         [b String])
+       
        (ann (constructor dk1 2 "y")
             (constructor dk1 Number String))]
 

graph-lib/graph/remember.rkt

@@ -145,3 +145,5 @@
 (variant . dj1)
 (variant . dk1)
 (variant . dl1)
+(structure x y)
+(variant . txyz)

graph-lib/graph/variant.lp2.rkt

@@ -39,7 +39,7 @@ example below where the second @tc[define-datatype] throws an error:
          [Var (Symbol)]
          [Lambda (Symbol Expr)])]
 
-@section{The @racket[Variant] supertype}
+@section[#:tag "variant|supertype"]{The @racket[Variant] supertype}
 
 We define variants as instances of subtypes of the @tc[Tagged] structure:
 
@@ -334,9 +334,9 @@ number of name collisions.
 @section{@racket[define-tagged]}
 
 @chunk[<define-tagged>
-       (define-syntax/parse (define-tagged tag:id [field type] …
+       (define-syntax/parse (define-tagged tag:id
-                              (~optional #:type-noexpand)
+                              (~maybe #:? tag?)
-                              (~maybe #:? tag?))
+                              [field type] …)
          (define/with-syntax (pat …) (generate-temporaries #'(field …)))
          (define/with-syntax (value …) (generate-temporaries #'(field …)))
          (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
@@ -424,6 +424,103 @@ number of name collisions.
        (check-not-equal?: (tagged-s2 4 "flob")
                           (tagged-s4 4 "flob"))]
 
+@section{Uninterned tags}
+
+We wish to be able to declare tags only visible to the
+creator, unlike the ones above which are visible
+everywhere.
+
+We will define two flavours: one where uninterned tags
+inherit the interned tag, os that the interned @tc[tag] is a
+supertype of the uninterned @tc[tag] (but not the converse),
+and a second, which we will call private tags, where the
+private tag inherits directly from @tc[Tagged], the base
+structure described in section @secref{variant|supertype},
+and is therefore unrelated to the interned @tc[tag] (nor to
+the uninterned @tc[tag] either).
+
+@; TODO: this should be integrated a bit better with other function, for example
+@; Tagged-predicate? (provided as Tagged?) is likely to not work on uninterned
+@; tags.
+
+@chunk[<define-uninterned-tagged>
+       (define-syntax/parse (define-private-tagged tag:id
+                              (~maybe #:? tag?)
+                              . (~and structure-type ([field type] …)))
+         (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
+         (define-temp-ids "~a/struct" tag)
+         (define-temp-ids "~a/arg" (field …))
+         (define-temp-ids "~a/pat" (field …))
+         (template
+          (begin
+            (struct (T) tag/struct Tagged ()) ; Private
+            ;(struct (T) tag/struct interned ()) ; Uninterned
+            (define-multi-id tag
+              #:type-expand-once
+              (tag/struct (structure . structure-type))
+              #:match-expander
+              (λ/syntax-parse (_ . (~and structure-pat
+                                         ((~and field/pat :expr) …)))
+                (quasitemplate
+                 (and (? (make-predicate (tag/struct Any)))
+                      (app Tagged-value
+                           #,(syntax/loc #'structure-pat
+                               (structure [field field/pat] …))))))
+              #:call
+              (λ/syntax-parse (_ . (~and args ((~and field/arg :expr) …)))
+                (quasitemplate
+                 (tag/struct #,(syntax/loc #'args
+                                 (structure #:instance
+                                            [field : type field/arg] …))))))
+            ;; TODO: the return type is not precise enough, it should be:
+            ;; #:+ (tag/struct (structure Any …))
+            ;; #:- (! (tag/struct (structure Any …)))
+            (: (?? tag? default-tag?) (→ Any Boolean :
+                                         #:+ (tag/struct Any)))
+            (define ((?? tag? default-tag?) x)
+              (and ((make-predicate (tag/struct Any)) x)
+                   ((structure? field …) (Tagged-value x)))))))]
+
+@chunk[<test-uninterned-tagged>
+       (define-syntax-rule (defp make mt)
+         (begin
+           (define-private-tagged txyz #:? txyz?
+             [a Number]
+             [b String])
+           
+           (define (make) (txyz 1 "b"))
+           
+           (define (mt v)
+             (match v
+               ((txyz x y) (list 'macro y x))
+               (_ #f)))))
+       
+       (defp make mt)
+       
+       (define-private-tagged txyz #:? txyz?
+         [a Number]
+         [b String])
+       
+       (check-equal?: (match (make)
+                        ((tagged txyz x y) (list 'out y x))
+                        (_ #f))
+                      #f)
+       
+       (check-equal?: (mt (tagged txyz [x 1] [y "b"]))
+                      #f)
+       
+       (check-equal?: (mt (make))
+                      '(macro "b" 1))
+       
+       (check-not-equal?: (make) (txyz 1 "b"))
+       (check-equal?: (match (make)
+                        ((txyz x y) (list 'out y x))
+                        (_ #f))
+                      #f)
+       
+       (check-equal?: (mt (txyz 1 "b"))
+                      #f)]
+
 @section{Conclusion}
 
 @chunk[<*>
@@ -444,6 +541,7 @@ number of name collisions.
                     define-variant
                     tagged
                     define-tagged
+                    define-private-tagged
                     any-tagged)
            
            <variant-supertype>
@@ -457,6 +555,7 @@ number of name collisions.
            <define-variant>
            <tagged>
            <define-tagged>
+           <define-uninterned-tagged>
            
            (module+ test-helpers
              (provide Tagged-value)))
@@ -474,4 +573,5 @@ number of name collisions.
            <test-constructor>
            <test-define-variant>
            <test-tagged>
-           <test-define-tagged>))]
+           <test-define-tagged>
+           <test-uninterned-tagged>))]

graph-lib/lib/low/syntax-parse.rkt

@@ -2,22 +2,25 @@
 (require "typed-untyped.rkt")
 
 (module m-stx-identifier racket
-    (require racket/stxparam)
+  (require racket/stxparam)
   
-    (provide stx)
+  (provide stx)
   
-    (define-syntax-parameter stx
+  (define-syntax-parameter stx
-      (lambda (call-stx)
+    (lambda (call-stx)
-        (raise-syntax-error
+      (raise-syntax-error
-         (syntax-e call-stx)
+       (syntax-e call-stx)
-         "Can only be used in define-syntax/parse or λ/syntax-parse"
+       "Can only be used in define-syntax/parse or λ/syntax-parse"
-         call-stx))))
+       call-stx))))
 
 (define-typed/untyped-modules #:no-test
   (provide stx
            define-syntax/parse
            λ/syntax-parse
            ~maybe
+           ~maybe*
+           ~optkw
+           ~kw
            ~lit
            ~or-bug
            define-simple-macro
@@ -33,7 +36,7 @@
            syntax/parse/experimental/template
            (for-syntax racket/syntax
                        racket/stxparam)
-           (for-meta 2 racket/base)
+           (for-meta 2 racket/base racket/syntax)
            racket/stxparam)
   
   (define-syntax ~maybe
@@ -44,6 +47,34 @@
           (define (s stx) (datum->syntax #'self stx stx stx))
           #`(#,(s #'~optional) (#,(s #'~seq) pat ...))]))))
   
+  (define-syntax ~maybe*
+    (pattern-expander
+     (λ (stx)
+       (syntax-parse stx
+         [(self name pat ...)
+          (define (s stx) (datum->syntax #'self stx stx stx))
+          #`(#,(s #'~and) name (#,(s #'~optional) (#,(s #'~seq) pat ...)))]))))
+  
+  (define-syntax ~optkw
+    (pattern-expander
+     (λ (stx)
+       (syntax-parse stx
+         [(self kw:keyword)
+          (define (s stx) (datum->syntax #'self stx stx stx))
+          (define/with-syntax name
+            (format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
+          #`(#,(s #'~optional) (#,(s #'~and) name kw))]))))
+  
+  (define-syntax ~kw
+    (pattern-expander
+     (λ (stx)
+       (syntax-parse stx
+         [(self kw:keyword)
+          (define (s stx) (datum->syntax #'self stx stx stx))
+          (define/with-syntax name
+            (format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
+          #`(#,(s #'~and) name kw)]))))
+  
   ;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in
   ;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
   (define-syntax ~or-bug