The get macro now works well, but needs a patch in typed/racket to fix a bug when providing promises which need to be wrapped in a contract.

graph/graph/__DEBUG_graph__.rkt

@@ -1,4 +1,4 @@
-#lang debug typed/racket
+#lang typed/racket
 
 #|
 (require "structure.lp2.rkt")
@@ -19,15 +19,21 @@
 |#
 
 (require (submod "graph3.lp2.rkt" test))
+(require "graph3.lp2.rkt")
 (require "graph4.lp2.rkt")
 (require "structure.lp2.rkt")
 (require "variant.lp2.rkt")
 (require "../lib/low.rkt")
+(require "../type-expander/type-expander.lp2.rkt")
 
-;(structure-get people)
+(structure-get (cadr (force g)) people)
-(structure-get (cadr g) people)
 (get g people)
 (get g streets cadr houses car owner name)
+((λget people) g)
+((λget owner name) (get g streets cadr houses car))
+;;((λget streets cadr houses car owner name) g)
+;;(map (λget houses car owner name) (get g streets))
+
 
 #|
 (define #:∀ (A) (map-force [l : (Listof (Promise A))])

graph/graph/__DEBUG_structure-supertype__.rkt

@@ -0,0 +1,27 @@
+#lang typed/racket
+
+(require "../type-expander/type-expander.lp2.rkt")
+
+(define-type-expander (CPairof stx)
+  (syntax-case stx ()
+    [(_ a) #'(curry Pairof a)]
+    [(_ a b) #'(Pairof a b)]))
+
+(ann (ann '(1 . "b") (CPairof Number String))
+     (Pairof Number String))
+
+(ann (ann '(1 . "c") ((CPairof Number) String))
+     (Pairof Number String))
+
+(require "structure.lp2.rkt")
+(require "../type-expander/type-expander.lp2.rkt")
+
+(define ab (structure [f-a 1] [f-b "b"]))
+(define abc (structure [f-a 1] [f-b "b"] [f-c 'c]))
+
+(define f
+  (λ ([x : (structure-supertype [f-a Number] [f-b String])])
+    x))
+
+(f ab)
+(f abc)

graph/graph/graph3.lp2.rkt

@@ -112,7 +112,9 @@ the root arguments as parameters.
 
 @chunk[<use-example>
        (define-graph make-g <example-variants>)
-       (define g (make-g <example-root>))]
+       #;(define g (make-g <example-root>))
+       (define g1 (make-g <example-root>))
+       (define g g1)]
 
 @subsection{More details on the semantics}
 
@@ -592,13 +594,13 @@ are replaced by tagged indices:
             (begin <define-incomplete>) …
             (begin <define-mapping-function>) …
 
-            (: name (→ root-param-type … root/with-promises-type))
+            (: name (→ root-param-type … (Promise root/with-promises-type)))
             (define (name root-param …)
               (match-let ([(list node/database …) <fold-queues>])
                 (begin <define-with-indices→with-promises>) …
-                ;(list node/with-indices→with-promises …)
+                (let ([root/with-promises (root/with-indices→with-promises
-                (root/with-indices→with-promises
+                                           (vector-ref root/database 0))])
-                 (vector-ref root/database 0))))))#|)|#)]
+                  (delay root/with-promises)))))))]
 
 @section{Conclusion}
 

graph/graph/graph4.lp2.rkt

@@ -14,7 +14,7 @@ is correctly taken into account. Note that @tc[car] would still work, because we
 also match identifiers with the @tc[c…r] syntax, as a fallback or for chains of
 more than 4 letters.
 
-@CHUNK[<c*r-syntax-class>
+@CHUNK[<c…r-syntax-class>
        (define-syntax-class c…r
          ;(pattern (~literal car) #:with (expanded …) #'(car))
          ;(pattern (~literal cdr) #:with (expanded …) #'(cdr))
@@ -85,12 +85,14 @@ otherwise throw an error:
 @chunk[<get-tagged>
        [((make-predicate (List Symbol Any)) v-cache)
         (get (structure-get (cadr v-cache) field) other-fields …)]]
+
 @chunk[<get-promise>
        [(promise? v-cache)
         (let ([f-cache (force v-cache)])
           (if ((make-predicate (List Symbol Any)) f-cache)
               (get (structure-get (cadr f-cache) field) other-fields …)
               (get (structure-get f-cache field) other-fields …)))]]
+
 @chunk[<get-plain-struct>
        [else
         (get (structure-get v-cache field) other-fields …)]]
@@ -98,6 +100,55 @@ otherwise throw an error:
 @chunk[<test-get>
        (check-equal? 'TODO 'TODO)]
 
+@section{@racket[λget]}
+
+@chunk[<λget>
+       (define-syntax (λget stx)
+         (syntax-parse stx
+           ;[(_ v:expr (~and c?r (~or (~lit car) (~lit cdr))) other-fields …)
+           ; #'(get (c?r v) other-fields …)]
+           ;[(_ v:expr c…r:c…r other-fields …)
+           ; #`(get v #,@(reverse (syntax->list #'(c…r.expanded …)))
+           ;        other-fields …)]
+           [(_ field:id …)
+            #'(ann (λ (v) (get v field …))
+                   (∀ (T) (→ (λget-type-helper T field …) T)))]))]
+
+The type for the function generated by @tc[λget] mirrors the cases from
+@tc[get].
+
+@; TODO: To avoid the n⁴ code size complexity (with n being the number of fields
+@; in the expression (λget f₁ … fₙ), maybe we should always wrap structures in a
+@; list with a dummy symbol as the first element, and wrap that in a promise
+@; that just returns the value. That way, we'll always fall in the
+@; @tc[(Promise (List <r>))] case. Using a named type of the form
+@; @tc[(define-type (maybe-wrapped S) (U S (List Symbol S)
+@;                                         (Promise (U S (List Symbol S)))))]
+@; won't work, because TR inlines these, unless they are recursive.
+@; We could otherwise try to make sure that the user never sees a Promise, and
+@; always force it when we return one (and node types would be
+@; @tc[(U with-fields=promises with-fields=with-promises)
+@; Or we could put in a fake piece of recursion to prevent TR from expanding the
+@; type, but that behaviour could change in the future:
+@; @tc[(define-type (maybe-wrapped S) (U S
+@;                                       (List Symbol S)
+@;                                       (Promise (U S (List Symbol S)))
+@;                                       (→ (maybe-wrapped S) unforgeable))))]
+
+@chunk[<λget-type-helper>
+       (define-type-expander (λget-type-helper stx)
+         (syntax-parse stx
+           [(_ T:expr)
+            #'T]
+           [(_ T:expr field:id other-fields:id …)
+            #;#'(U <r>
+                   (List Symbol <r>)
+                   (Promise (U <r> (List Symbol <r>))))
+            #'(Promise (List Symbol <r>))]))]
+
+@chunk[<r>
+       (structure-supertype [field (λget-type-helper T other-fields …)])]
+
 @section{Conclusion}
 
 @chunk[<module-main>
@@ -108,13 +159,17 @@ otherwise throw an error:
                   "../lib/low.rkt"
                   "structure.lp2.rkt"
                   "variant.lp2.rkt"
-                  "graph3.lp2.rkt")
+                  "graph3.lp2.rkt"
-         (provide get)
+                  "../type-expander/type-expander.lp2.rkt")
+         (provide get
+                  λget)
          
          (begin-for-syntax
-           <c*r-syntax-class>)
+           <c…r-syntax-class>)
          
-         <get>)]
+         <get>
+         <λget-type-helper>
+         <λget>)]
 
 @chunk[<module-test>
        (module* test typed/racket

graph/graph/remember.rkt

@@ -55,3 +55,17 @@
 (structure houses/with-promises-type sname/with-promises-type)
 (structure houses sname)
 (structure houses sname)
+(structure f-a f-b)
+(structure f-a f-b f-c)
+(structure people)
+(structure streets)
+(structure location)
+(structure streets)
+(structure streets)
+(structure x)
+(structure x)
+(structure x)
+(structure sname)
+(structure sname)
+(structure sname)
+(structure st)

graph/graph/structure.lp2.rkt

@@ -26,7 +26,7 @@ types, it wouldn't be clear what fields the remaining type parameters affect).
  (define-syntax-class field-descriptor
  (pattern
  (~or field:id
- [field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))}
+ [field:id (~maybe :colon type:expr) (~maybe value:expr)]))))}
 
 A call to @tc[(structure)] with no field, is ambiguous: it could return a
 constructor function, or an instance. We added two optional keywords,
@@ -41,10 +41,10 @@ handle the empty structure as a special case.
                (~seq #:constructor (~parse (field …) #'()))
                (~seq (~maybe #:constructor ~!)
                      (~or (~seq (~or-bug [field:id] field:id) …+)
-                          (~seq [field:id (~and C (~lit :)) type:expr] …+)))
+                          (~seq [field:id (~and C :colon) type:expr] …+)))
                (~seq (~maybe #:instance ~!)
                      (~or (~seq [field:id value:expr] …+)
-                          (~seq [field:id (~and C (~lit :)) type:expr
+                          (~seq [field:id (~and C :colon) type:expr
                                  value:expr] …+))))))]
 
 @chunk[<structure>
@@ -236,7 +236,7 @@ one low-level @tc[struct] is generated for them.
          (for/list ([s (remove-duplicates (map (λ (s) (sort s symbol<?))
                                                (get-remembered 'structure)))]
                     [i (in-naturals)])
-           `(,(string->symbol (format "struct-~a" i)) . ,s)))]
+           `(,(string->symbol (~a `(structure ,(~a "#|" i "|#") . ,s))) . ,s)))]
 
 We will also need utility functions to sort the fields when querying this
 associative list.
@@ -310,6 +310,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
            (stx-map sort-fields #'((all-field …) …)))
          (define/with-syntax ([[sorted-field sorted-pat …] …] …)
            (stx-map (curry stx-map
+                           ;; TODO: add (_ _ …) for the not-matched fields.
                            (λ (x) (multiassoc-syntax x #'([field pat …] …))))
                     #'((sorted-field1 …) …)))
          #'(or (name (and sorted-field sorted-pat …) …) …))]
@@ -317,10 +318,30 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
 @chunk[<structure-supertype>
        (define-multi-id structure-supertype
          #:type-expander
-         (λ/syntax-parse (_ field:id …)
+         (λ/syntax-parse (_ [field:id type:expr] …)
-           #`(U #,@(map cdr (fields→supertypes #'(field …)))))
+           (define/with-syntax ([(all-field …) . _] …)
+             (fields→supertypes #'(field …)))
+           (template
+            (U (structure
+                [all-field : (tmpl-cdr-assoc-syntax #:default Any
+                                                    all-field [field . type] …)]
+                …)
+               …)))
          #:match-expander <structure-supertype-match-expander>)]
 
+@chunk[<structure-supertype*>
+       (define-multi-id structure-supertype*
+         #:type-expander
+         (λ (stx)
+           (syntax-parse stx
+             [(_ T:expr)
+              #`T]
+             [(_ T:expr field:id other-fields:id …)
+              #`(structure-supertype
+                 [field (structure-supertype* T other-fields …)])]))
+         ;#:match-expander <structure-supertype-match-expander> ; TODO
+         )]
+
 @chunk[<fields→supertypes>
        (define-for-syntax (fields→supertypes stx-fields)
          (with-syntax ([(field …) stx-fields])
@@ -583,7 +604,8 @@ chances that we could write a definition for that identifier.
                     structure-get
                     λstructure-get
                     structure
-                    structure-supertype)
+                    structure-supertype
+                    structure-supertype*)
            
            (begin-for-syntax
              (provide structure-args-stx-class))
@@ -607,6 +629,7 @@ chances that we could write a definition for that identifier.
            
            <syntax-class-for-match>
            <structure-supertype>
+           <structure-supertype*>
            <match-expander>
            <type-expander>
            

graph/lib/low/multiassoc-syntax.rkt

@@ -8,16 +8,28 @@
          cdr-assoc-syntax
          tmpl-cdr-assoc-syntax)
 
+(require "../low.rkt") ;; For the identifier "…"
+
+;; TODO: cdr-stx-assoc is already defined in lib/low.rkt
+
 (define (multiassoc-syntax query alist)
   (map stx-cdr
        (filter (λ (xy) (free-identifier=? query (stx-car xy)))
                (syntax->list alist))))
 
 (define (cdr-assoc-syntax query alist)
-  (stx-cdr (findf (λ (xy) (free-identifier=? query (stx-car xy)))
+  (stx-cdr (assoc-syntax query alist)))
-                  (syntax->list alist))))
+
+(define (assoc-syntax query alist)
+  (findf (λ (xy) (free-identifier=? query (stx-car xy)))
+         (syntax->list alist)))
 
 (define-template-metafunction (tmpl-cdr-assoc-syntax stx)
   (syntax-parse stx
-    [(_ query [k . v] …)
+    [(_ (~optional (~seq #:default default)) query [k . v] …)
-     (cdr-assoc-syntax #'query #'([k . v] …))]))
+     (if (attribute default)
+         (let ([r (assoc-syntax #'query #'([k . v] …))])
+           (if r
+               (stx-cdr r)
+               #'default))
+         (cdr-assoc-syntax #'query #'([k . v] …)))]))

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

@@ -30,8 +30,8 @@ Match expanders are identified by the @tc[prop:type-expander]
                        get-prop:type-expander-value)
          (make-struct-type-property 'type-expander prop-guard))]
 
-The prop:type-expander property should either be the index of a field which will
+The @tc[prop:type-expander] property should either be the index of a field which
-contain the expander procedure, or directly an expander procedure.
+will contain the expander procedure, or directly an expander procedure.
 
 @chunk[<prop-guard>
        (define (prop-guard val struct-type-info-list)
@@ -101,12 +101,25 @@ else.
          (define-syntax-class type-expander
            (pattern (~var expander
                           (static has-prop:type-expander? "a type expander"))))
+         (define-syntax-class type-expander-nested-application
+           #:attributes (expanded-once)
+           (pattern (~and expander-call-stx (:type-expander . args))
+                    #:with expanded-once
+                    (apply-type-expander #'expander #'expander-call-stx))
+           (pattern (nested-application:type-expander-nested-application
+                     . args) ;; TODO: test
+                    #:with expanded-once
+                    #'(nested-application.expanded-once . args)))
+         
          (define-syntax-class fa (pattern (~or (~literal ∀) (~literal All))))
          (syntax-parse stx
            [:type-expander
             (expand-type (apply-type-expander #'expander #'expander))]
-           [(~and expander-call-stx (:type-expander . args))
+           [:type-expander-nested-application
-            (expand-type (apply-type-expander #'expander #'expander-call-stx))]
+            (expand-type #'expanded-once)]
+           ;; TODO: find a more elegant way to write anonymous type expanders
+           [(((~literal curry) T Arg1 …) . Args2)
+            (expand-type #'(T Arg1 … . Args2))]
            ;; TODO: handle the pattern (∀ (TVar ... ooo) T)
            [(∀:fa (TVar ...) T)
             #`(∀ (TVar ...) #,(expand-type (bind-type-vars #'(TVar ...) #'T)))]
@@ -117,8 +130,6 @@ else.
            [((~literal syntax) T) (expand-quasiquote 'syntax 1 #'T)]
            [((~literal quasisyntax) T) (expand-quasiquote 'quasisyntax 1 #'T)]
            [((~literal Struct) T)
-            (display #'(Struct T))
-            (displayln #`(Struct #,(expand-type #'(T))))
             #`(Struct #,(expand-type #'T))]
            [(T TArg ...)
             #`(T #,@(stx-map expand-type #'(TArg ...)))]
@@ -161,6 +172,28 @@ identifier.
        (test-expander (∀ (A) (→ A (id (double (id A)))))
                       (∀ (A) (→ A (Pairof A A))))]
 
+Curry expander arguments:
+
+@CHUNK[<test-expand-type>
+       (define-type-expander (CPairof stx)
+         (syntax-case stx ()
+           [(_ a) #'(curry Pairof a)]
+           [(_ a b) #'(Pairof a b)]))
+       
+       (test-expander (CPairof Number String)
+                      (Pairof Number String))
+       
+       (test-expander ((CPairof Number) String)
+                      (Pairof Number String))
+       
+       (check-equal?: (ann (ann '(1 . "b") (CPairof Number String))
+                           (Pairof Number String))
+                      '(1 . "b"))
+       
+       (check-equal?: (ann (ann '(1 . "c") ((CPairof Number) String))
+                           (Pairof Number String))
+                      '(1 . "c"))]
+
 Shadowing and @tc[∀] variables:
 
 @CHUNK[<test-expand-type>
@@ -945,17 +978,18 @@ To get around that problem, we define @tc[:] in a separate module, and
 Since our @tc[new-:] macro needs to call the @tc[type-expander], and the other
 forms too, we can't define @tc[type-expander] in the same module as these forms,
 it needs to be either in the same module as @tc[new-:], or in a separate module.
-Additionally, expand-type needs to be required @tc[for-syntax] by the forms, but
+Additionally, @tc[expand-type] needs to be required @tc[for-syntax] by the
-needs to be @tc[provide]d too, so it is much easier if it is defined in a
+forms, but needs to be @tc[provide]d too, so it is much easier if it is defined
-separate module (that should be used only @tc[for-syntax], so it will be written
+in a separate module (that will be used only by macros, so it will be written in
-in @tc[racket], not @tc[typed/racket]).
+@tc[racket], not @tc[typed/racket]).
 
 @chunk[<module-expander>
        (module expander racket
          (require racket
                   syntax/parse
                   syntax/stx
-                  racket/format)
+                  racket/format
+                  "../lib/low-untyped.rkt")
          
          (require (for-template typed/racket))
          
@@ -1050,7 +1084,7 @@ And, last but not least, we will add a @tc[test] module.
 |#
          ;<test-struct>
          <test-define-struct/exec>
-#|
+         #|
          <test-ann>
          <test-inst>
          <test-let>