Changed graph3.lp2.rkt so that it uses tagged structures (from variant.lp2.rkt), made the “get” macro work on variants.

graph/graph/__DEBUG_graph__.rkt

@@ -1,5 +1,6 @@
 #lang debug typed/racket
 
+#|
 (require "structure.lp2.rkt")
 (require "variant.lp2.rkt")
 (require "../type-expander/type-expander.lp2.rkt")
@@ -12,14 +13,23 @@
 (tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"])
 (tagged t [a 1] [b 'b] [c "c"])
 
-#|
+(tagged t [a 1] [b 'b] [c "c"])
+
+(define-tagged tabc t [a 1] [b 'b] [c "c"])
+|#
+
 (require (submod "graph3.lp2.rkt" test))
+(require "structure.lp2.rkt")
 (require "../lib/low.rkt")
 (require racket/list)
 
 (define #:∀ (A) (map-force [l : (Listof (Promise A))])
   (map (inst force A) l))
 
+(map-force (get g people))
+(map-force (get g streets))
+
+#|
 (let ()
   (map-force (second g))
   (cars (map-force (second g)))

graph/graph/fold-queues.lp2.rkt

@@ -12,10 +12,10 @@
 
 @chunk[<fold-queues-signature>
        (fold-queues root-value
-                    [(name [element (~literal :) Element-Type]
-                           [Δ-queues (~literal :) Δ-Queues-Type-Name]
+                    [(name [element :colon Element-Type]
+                           [Δ-queues :colon Δ-Queues-Type-Name]
                            enqueue)
-                     (~literal :) Result-Type
+                     :colon Result-Type
                      . body]
                     …
                     (~parse (root-name . _) #'(name …)))]
@@ -279,7 +279,8 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable].
                               racket/syntax
                               racket/pretty; DEBUG
                               "../lib/low-untyped.rkt")
-                  "../lib/low.rkt")
+                  "../lib/low.rkt"
+                  "../type-expander/type-expander.lp2.rkt")
          
          (provide fold-queues)
          

graph/graph/graph3.lp2.rkt

@@ -30,7 +30,7 @@ these constructors:
 
 @chunk[<example-variants>
        [City [streets : (Listof Street)] [people : (Listof Person)] <m-city>]
-       [Street [name : String] [houses : (Listof House)] <m-street>]
+       [Street [sname : String] [houses : (Listof House)] <m-street>]
        [House [owner : Person] [location : Street] <m-house>]
        [Person [name : String] <m-person>]]
 
@@ -161,12 +161,12 @@ wrapper macros.
 Where @tc[<field-signature>] is:
 
 @chunk[<field-signature>
-       [field:id (~literal :) field-type:expr]]
+       [field:id :colon field-type:expr]]
 
 And @tc[<mapping-declaration>] is:
 
 @chunk[<mapping-declaration>
-       ((mapping:id [param:id (~literal :) param-type:expr] …)
+       ((mapping:id [param:id :colon param-type:expr] …)
         . mapping-body)]
 
 @subsection{The different types of a node}
@@ -229,7 +229,9 @@ We derive identifiers for these based on the @tc[node] name:
        
        (define-temp-ids "~a/mapping-function" (node …))
        
-       (define-temp-ids "~a/database" (node …) #:first-base root)]
+       (define-temp-ids "~a/database" (node …) #:first-base root)
+       
+       (define-temp-ids "~a/value" ((field …) …))]
 
 @subsection{Overview}
 
@@ -372,13 +374,15 @@ that node's @tc[with-promises] type.
        …
        
        (define-type node/with-promises-type
-         (List 'node/with-promises-tag
-               field/with-promises-type …))
+         (tagged node/with-promises-tag
+                 [field : field/with-promises-type] …))
        
        (: node/make-with-promises (→ field/with-promises-type …
                                      node/with-promises-type))
-       (define (node/make-with-promises field …)
-         (list 'node/with-promises-tag field …))]
+       (define (node/make-with-promises field/value …)
+         (tagged node/with-promises-tag
+                 [field : field/with-promises-type field/value]
+                 …))]
 
 @subsection{Making incomplete nodes}
 
@@ -616,7 +620,10 @@ are replaced by tagged indices:
                   alexis/util/threading; DEBUG
                   "fold-queues.lp2.rkt"
                   "rewrite-type.lp2.rkt"
-                  "../lib/low.rkt")
+                  "../lib/low.rkt"
+                  "structure.lp2.rkt"
+                  "variant.lp2.rkt"
+                  "../type-expander/type-expander.lp2.rkt")
          
          ;(begin-for-syntax
          ;<multiassoc-syntax>)
@@ -624,12 +631,20 @@ are replaced by tagged indices:
          (provide define-graph)
          <define-graph>)]
 
+In @tc[module-test], we have to require @tc[type-expander] because it provides a
+@tc[:] macro which is a different identifier than the one from typed/racket,
+therefore the @tc[:] bound in the @tc[graph] macro with @tc[:colon] would
+not match the one from @tc[typed/racket]
+
 @chunk[<module-test>
        (module* test typed/racket
          (require (submod "..")
                   "fold-queues.lp2.rkt"; DEBUG
                   "rewrite-type.lp2.rkt"; DEBUG
                   "../lib/low.rkt"; DEBUG
+                  "structure.lp2.rkt"; DEBUG
+                  "variant.lp2.rkt"; DEBUG
+                  "../type-expander/type-expander.lp2.rkt"
                   typed/rackunit)
          
          (provide g)

graph/graph/remember.rkt

@@ -39,4 +39,19 @@
 (structure fba fbv)
 (structure fav)
 (structure a)
-(structure a)
+(structure a)
+(structure people/with-promises-type streets/with-promises-type)
+(structure houses/with-promises-type name/with-promises-type)
+(structure location/with-promises-type owner/with-promises-type)
+(structure name/with-promises-type)
+(structure people streets)
+(structure people streets)
+(structure houses name)
+(structure houses name)
+(structure location owner)
+(structure location owner)
+(structure name)
+(structure name)
+(structure houses/with-promises-type sname/with-promises-type)
+(structure houses sname)
+(structure houses sname)

graph/graph/structure.lp2.rkt

@@ -103,21 +103,29 @@ handle the empty structure as a special case.
 @chunk[<define-structure>
        (define-syntax (define-structure stx)
          (syntax-parse stx
-           [(_ name [field type] ...)
+           [(_ name [field type] ... (~maybe #:? name?))
             (define/with-syntax ([sorted-field sorted-type] ...)
               (sort-car-fields #'([field type] ...)))
             (define/with-syntax (pat ...) (generate-temporaries #'(field ...)))
-            #'(define-multi-id name
-                #:type-expand-once
-                (structure [field type] ...)
-                #:match-expander
-                (λ (stx2)
-                  (syntax-case stx2 ()
-                    [(_ pat ...) #'(structure [field pat] ...)]))
-                #:else
-                (if (not (stx-null? #'(type …)))
-                    #'(inst (make-structure-constructor field ...) type ...)
-                    #'(make-structure-constructor field ...)))]))]
+            (define/with-syntax default-name? (format-id #'name "~a?" #'name))
+            (template
+             (begin
+               (define-multi-id name
+                 #:type-expand-once
+                 (structure [field type] ...)
+                 #:match-expander
+                 (λ (stx2)
+                   (syntax-case stx2 ()
+                     [(_ pat ...) #'(structure [field pat] ...)]))
+                 #:else
+                 (if (not (stx-null? #'(type …)))
+                     #'(inst (make-structure-constructor field ...) type ...)
+                     #'(make-structure-constructor field ...)))
+               (: (?? name? default-name?) (→ Any Any))
+               (define ((?? name? default-name?) x)
+                 (match x
+                   [(structure [field _] …) #t]
+                   [_ #f]))))]))]
 
 
 @chunk[<test-define-structure>
@@ -135,10 +143,10 @@ Test constructor:
 Test constructor, as id:
 
 @chunk[<test-define-structure>
-       (check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
-                      : String "y")
-       (check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
-                      : String "e")]
+       (check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) : String
+                      "y")
+       (check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) : String
+                      "e")]
 
 Test the type-expander:
 
@@ -293,21 +301,44 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
 @subsection{Accessor}
 
 @CHUNK[<get-field2>
-       (define-syntax/parse (get v field:id)
-         (define structs (filter (λ (s)
-                                   (member (syntax->datum #'field) (car s)))
-                                 fields→stx-name-alist))
-         (define/with-syntax (name? ...)
-           (map (λ (s) <get-predicate>) structs))
-         (define/with-syntax (name-field ...)
-           (map (λ (s) <get-field-accessor>) structs))
-         #`(let ([v-cache v])
-             (cond
-               [(name? v-cache)
-                (let ([accessor name-field])
-                  (accessor v-cache))]; cover does not see the call otherwise?
-               ...
-               [else (typecheck-fail #,stx #:covered-id v-cache)])))]
+       (define-syntax (get stx)
+         (syntax-parse stx
+           [(_ v field:id)
+            (define struct-names
+              (filter (λ (s)
+                        (member (syntax->datum #'field) (car s)))
+                      fields→stx-name-alist))
+            (define/with-syntax (name? ...)
+              (map (λ (s) <get-predicate>) struct-names))
+            (define/with-syntax (name-field ...)
+              (map (λ (s) <get-field-accessor>) struct-names))
+            #`(let ([v-cache v])
+                (cond
+                  [(name? v-cache)
+                   (let ([accessor name-field])
+                     (accessor v-cache))]; cover doesn't see the call otherwise?
+                  …
+                  ;; For variants:
+                  ;; If we hit the bug where refinements cause loss of precision
+                  ;; in later clauses, then just use separate functions, forming
+                  ;; a BTD:
+                  ;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x)))
+                  [(and (pair? v-cache)
+                        (symbol? (car v-cache))
+                        (null? (cddr v-cache))
+                        (name? (cadr v-cache)))
+                   (let ([accessor name-field])
+                     (accessor (cadr v-cache)))]
+                  …
+                  [else (typecheck-fail #,stx #:covered-id v-cache)]))]
+           [(_ field:id)
+            (define/with-syntax (struct-name …)
+              (filter (λ (s)
+                        (member (syntax->datum #'field) (car s)))
+                      fields→stx-name-alist))
+              #'(λ ([v : (U struct-name …
+                            (List Symbol struct-name) …)])
+                  (get v field))]))]
 
 @chunk[<get-predicate>
        (my-st-type-info-predicate (get-struct-info stx (cdr s)))]
@@ -418,7 +449,7 @@ instead of needing an extra recompilation.
                     (sort-fields #'(field …)))
                   (fields→stx-name #'(field …)))
                 (remember-all-errors #'U stx #'(field ...)))]
-           [(_ (~seq [field:id type:expr] …))
+           [(_ (~seq [field:id (~optional :colon) type:expr] …))
             (if (check-remember-fields #'(field ...))
                 (let ()
                   (define/with-syntax ([sorted-field sorted-type] ...)

graph/graph/variant.lp2.rkt

@@ -78,8 +78,20 @@ twice, and it is likely that a constructor will have the same identifier as an
 existing variable or function.
 
 @chunk[<define-variant>
-       (define-syntax/parse (define-variant name [tag:id type:expr ...] ...)
-         #'(define-type name (U (constructor tag type ...) ...)))]
+       (define-syntax/parse (define-variant name [tag:id type:expr ...] ...
+                              (~maybe #:? name?))
+         (define/with-syntax default-name? (format-id #'name "~a?" #'name))
+         (define-temp-ids "pat" ((type …) …))
+         (template
+          (begin
+            (define-type name (U (constructor tag type ...) ...))
+            ;; TODO: for now, we don't check properly, it could be any list with
+            ;; that symbol as the first element.
+            (define ((?? name? default-name?) [x : Any])
+              (match x
+                [(constructor tag pat …) #t]
+                …
+                [_ #f])))))]
 
 @chunk[<test-define-variant>
        (define-variant v1 [x Number String] [y String Number] [z Number String])
@@ -161,18 +173,27 @@ number of name collisions.
 
 @chunk[<define-tagged>
        (define-syntax/parse (define-tagged tag:id [field type] ...
-                              (~optional #:type-noexpand))
+                              (~optional #:type-noexpand)
+                              (~maybe #:? tag?))
          (define/with-syntax (pat ...) (generate-temporaries #'(field ...)))
          (define/with-syntax (value ...) (generate-temporaries #'(field ...)))
-         #'(define-multi-id tag
-             #:type-expand-once
-             (tagged tag [field type] ...)
-             #:match-expander
-             (λ/syntax-parse (_ pat ...)
-               #'(tagged tag [field pat] ...))
-             #:call
-             (λ/syntax-parse (_ value ...)
-               #'(tagged tag #:instance [field value] ...))))]
+         (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
+         (template
+          (begin
+            (define-multi-id tag
+              #:type-expand-once
+              (tagged tag [field type] ...)
+              #:match-expander
+              (λ/syntax-parse (_ pat ...)
+                #'(tagged tag [field pat] ...))
+              #:call
+              (λ/syntax-parse (_ value ...)
+                #'(tagged tag #:instance [field value] ...)))
+            (: (?? tag? default-tag?) (→ Any Any))
+            (define ((?? tag? default-tag?) x)
+              (match x
+                [(tagged tag [field _] …) #t]
+                [_ #f])))))]
 
 @chunk[<test-define-tagged>
        (define-tagged tagged-s1)
@@ -248,6 +269,7 @@ number of name collisions.
        (begin
          (module main typed/racket
            (require (for-syntax syntax/parse
+                                syntax/parse/experimental/template
                                 racket/syntax
                                 "../lib/low-untyped.rkt")
                     "../lib/low.rkt"

graph/lib/low.rkt

@@ -746,7 +746,6 @@
       
       [(_ format:simple-format
           base:dotted
-          (~optional (~seq #:first-base first-base))
           (~optional (~seq #:first first)))
        (let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))])
          (define/with-syntax pat
@@ -790,14 +789,33 @@
                             (syntax-local-introduce #'format)
                             (attribute format.right-start)
                             (attribute format.right-len))
-                    '())))
-         )]
-      [(_ format (base:id (~literal ...)))
+                    '()))))]
+      [(_ format base:dotted)
        #:when (string? (syntax-e #'format))
-       (with-syntax ([pat (format-id #'base (syntax-e #'format) #'base)])
-         #'(define/with-syntax (pat (... ...))
-             (format-temp-ids format #'(base (... ...)))))]
-      [(_ name:expr format:expr . vs)
+       #:when (regexp-match #rx"^[^~]*$" (syntax-e #'format))
+       (define/with-syntax pat (format-id #'base (syntax-e #'format)))
+       (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
+       (define/with-syntax format-temp-ids*
+           ((attribute base.wrap) #'(λ (x)
+                                      (car (format-temp-ids
+                                            (string-append format "~a")
+                                            "")))
+                                  (λ (x deepest?)
+                                    (if deepest?
+                                        x
+                                        #`(curry stx-map #,x)))))
+       (syntax-cons-property
+        #'(define/with-syntax pat-dotted
+            (format-temp-ids* #'base))
+        'sub-range-binders
+        (list (vector (syntax-local-introduce #'pat)
+                      0
+                      (string-length (syntax-e #'format))
+                      
+                      (syntax-local-introduce #'format)
+                      1
+                      (string-length (syntax-e #'format)))))]
+      [(_ name:id format:expr . vs)
        #`(define/with-syntax name (format-temp-ids format . vs))])))
 
 (module+ test

graph/type-expander/type-expander.lp2.rkt

@@ -305,7 +305,7 @@ them.
 
 @CHUNK[<syntax-classes>
        (define-syntax-class colon
-         (pattern (~literal new-:)))
+         (pattern (~or (~literal new-:) (~literal :))))
        
        (define-splicing-syntax-class (new-maybe-kw-type-vars)
          #:attributes (vars maybe)
@@ -1012,7 +1012,9 @@ We can finally define the overloaded forms, as well as the extra
          
          (begin-for-syntax
            <template-metafunctions>
-           <syntax-classes>)
+           <syntax-classes>
+
+           (provide colon))
          
          <define-type>
          <define>