Added uniform-get, fixed most uses of the new constructor representation.

graph-lib/graph/__DEBUG_graph6.rkt

@@ -6,8 +6,7 @@
          "get.lp2.rkt"
          "../type-expander/type-expander.lp2.rkt"
          "../type-expander/multi-id.lp2.rkt"
-         "structure.lp2.rkt" ; debug
+         "adt.lp2.rkt" ; debug
-         "variant.lp2.rkt" ; debug
          "fold-queues.lp2.rkt"; debug
          "rewrite-type.lp2.rkt"; debug
          "meta-struct.rkt"; debug
@@ -22,6 +21,8 @@
 |#
 
 
+(require "../lib/debug-syntax.rkt")
+
 (define-type blob String)
 (define-type-expander (bubble stx) #'String)
 
@@ -52,6 +53,8 @@
   : (Listof Street)
   (map Street snames)])
 
+#|
+
 #;(super-define-graph/rich-return
    grr3
    ([City [streets : (~> m-streets)]]
@@ -83,3 +86,4 @@
 (dg grr)
 (dg grra)
 |#
+|#

graph-lib/graph/__DEBUG_variant.rkt

@@ -21,7 +21,7 @@
                            (constructor dh1 Number String))
                       (constructor dh1 2 "y"))
        
-       (define-private-tagged txyz #:? txyz?
+       (define-tagged txyz #:private #:? txyz?
          [a Number]
          [b String])
        
@@ -32,7 +32,7 @@
        (begin 
          (module main typed/racket
            (require (for-syntax racket/list)
-                    "variant.lp2.rkt")
+                    "adt.lp2.rkt")
            <mainbody>)
          
          (require 'main)
@@ -43,6 +43,6 @@
                     "../lib/low.rkt"
                     "../type-expander/type-expander.lp2.rkt"
                     typed/rackunit
-                    "variant.lp2.rkt")
+                    "adt.lp2.rkt")
            
            <testbody>))]

graph-lib/graph/adt.lp2.rkt

@@ -10,21 +10,33 @@
 
 We define variants (tagged unions), with the following constraints:
 
-@itemlist[
+@; TODO: put a short usage example here
- @item{Unions are anonymous: two different unions can contain the same tag, and
-  there's no way to distinguish these two occurrences of the tag}
- @item{Callers can require an uninterned tag which inherits the interned tag, so
-  that @racket[(constructor #:uninterned tag Number)] is a subtype of
-  @racket[(constructor #:uninterned tag Number)], but not the reverse}
- @item{The tag can be followed by zero or more “fields”}
- @item{An instance of a variant only @racket[match]es with its constructor and
-  the same number of fields, with exact matching on the tag for uninterned
-  tags}]
 
-See @url{https://github.com/andmkent/datatype/} for an existing module providing
+@itemlist[
-Algebraic Data Types. The main difference with our library is that a given tag
+ @item{Unions are anonymous: two different unions can
-(i.e. constructor) cannot be shared by multiple unions, as can be seen in the
+  contain the same tag, and there's no way to distinguish
-example below where the second @tc[define-datatype] throws an error:
+  these two occurrences of the tag}
+ @item{Users can define an uninterned tag, i.e. one which
+  will not match against other uses of the same tag name. A
+  constructor using this uninterned tag is a subtype of the
+  constructor using the interned one, but not the reverse.
+  This means that 
+  @racket[(constructor #:uninterned tag Number)] is a
+  subtype of @racket[(constructor tag Number)], but not the
+  opposite. This allows testing if a constructor instance
+  was created by the rightful owner, or by some other code
+  which happens to use the same name.}
+ @item{The tag can be followed by zero or more “fields”}
+ @item{An instance of a variant only @racket[match]es with
+  its constructor and the same number of fields, with exact
+  matching on the tag for uninterned tags}]
+
+See @url{https://github.com/andmkent/datatype/} for an
+existing module providing Algebraic Data Types. The main
+difference is that unlike our library, a given constructor
+name cannot be shared by multiple unions, as can be seen in
+the example below where the second @tc[define-datatype]
+throws an error:
 
 @chunk[<datatype-no-sharing>
        (require datatype)
@@ -43,7 +55,7 @@ example below where the second @tc[define-datatype] throws an error:
 @section{Constructors, tagged, variants and structures}
 
 We first define @tc[structure] and @tc[constructor], the
-primitives allowing us to build instance, match against them
+primitives allowing us to build instances, match against them
 and express the type itself.
 
 @chunk[<require-modules>
@@ -51,7 +63,7 @@ and express the type itself.
        (require "constructor.lp2.rkt")]
 
 We then define @tc[tagged], which is a shorthand for
-manipulating constructors which single value is a promise
+manipulating constructors whose single value is a promise
 for a structure.
 
 @chunk[<require-modules>
@@ -66,7 +78,7 @@ thin wrapper against @tc[(U (~or constructor tagged) …)].
 The @tc[define-tagged] and @tc[define-constructor] forms
 also allow the @tc[#:uninterned] and @tc[#:private]
 keywords, to create uninterned constructors and tagged
-structures as described in @secref{ADT|introduction}.
+structures as described in the @secref{ADT|introduction}.
 
 @chunk[<require-modules>
        (require "define-adt.lp2.rkt")]
@@ -77,31 +89,39 @@ operate on @tc[tagged] structures. We also wrap the plain
 structure, using a common tag for all plain structures. This
 allows us to rely on the invariant that @tc[uniform-get]
 always operates on data with the same shape (a constructor
-which single value is a promise for a structure)@note{This
+whose single value is a promise for a structure)@note{This
  avoids the risk of combinatorial explosion for the intput
  type of @racket[uniform-get], when accessing a deeply nested
  field: allowing
  @racket[(U structure
             (constructor structure)
             (constructor (Promise structure)))]
- would result in a type of size @${n⁴}, with ${n} then depth
+ would result in a type of size @${n⁴}, with @${n} the depth
  of the accessed field.}
 
 @chunk[<require-modules>
-       (void)] @;(require "uniform-get.lp2.rkt")
+       (require "uniform-get.lp2.rkt")]
 
 @chunk[<*>
-       (void)
+       (begin
-       #;(begin
          (module main typed/racket
            <require-modules>
            (provide constructor
                     define-constructor
+                    ConstructorTop
+                    ConstructorTop?
+                    constructor?
+                    constructor-values
                     tagged
                     define-tagged
                     variant
                     define-variant
-                    (rename-out [wrapped-structure structure])
+                    (rename-out
+                     [wrapped-structure structure]
+                     [wrapped-structure-supertype structure-supertype]
+                     [structure plain-structure]
+                     [structure-supertype plain-structure-supertype]
+                     [define-structure define-plain-structure])
                     uniform-get))
          
          (require 'main)

graph-lib/graph/constructor.lp2.rkt

@@ -12,7 +12,7 @@ This file defines @tc[constructor], a form which allows
 tagging values, so that two otherwise identical values can
 be distinguished by the constructors used to wrapp them.
 
-@section[#:tag "variant|supertype"]{The @racket[ConstructorTop] supertype}
+@section[#:tag "constructor|supertype"]{The @racket[ConstructorTop] supertype}
 
 We define variants as instances of subtypes of the @tc[Tagged] structure:
 
@@ -43,12 +43,31 @@ For this, we use the @tc[remember] library:
 
 We pre-declare here in this file all the remembered constructors:
 
-@CHUNK[<constructor-declarations>
+@CHUNK[<declare-constructor-struct>
-       (struct (T)
+       (define-syntax (declare-constructor-struct stx)
-         constructor-name/struct
+         (syntax-case stx ()
+           [(_ name)
+            #`(struct (T)
+                name
                 #,(syntax-local-introduce #'ConstructorTop)
                 ()
-         #:transparent)
+                #:transparent)]))]
+
+@CHUNK[<declare-uninterned-constructor-struct>
+       (define-syntax (declare-uninterned-constructor-struct stx)
+         (syntax-parse stx
+           [(_ name)
+            (define/syntax-parse ((~maybe no-with-struct)) #'())
+            (with-constructor-name→stx-name
+                (parent no-with-struct #'name #'please-recompile stx)
+              #'(struct (T)
+                  name
+                  parent
+                  ()
+                  #:transparent))]))]
+
+@CHUNK[<constructor-declarations>
+       (declare-constructor-struct constructor-name/struct)
        …]
 
 We define an associative list which maps the constructor
@@ -214,7 +233,9 @@ instance:
                        stx)
            (template
             ((λ #:∀ (T …) ([arg : T] …)
-               : (constructor constructor-name T …)
+               : (constructor constructor-name
+                              (?? (?@ #:with-struct with-struct))
+                              T …)
                (stx-name (?? arg₀ (list argᵢ …))))
              value …))))]
 
@@ -238,13 +259,18 @@ instance:
                     (rename-out [ConstructorTop-values constructor-values]))
            
            <constructor-top>
+           <declare-constructor-struct>
            <remember-lib>
            <named-sorted-constructors>
            <declare-all-constructors>
            <with-constructor-name→stx-name>
+           <declare-uninterned-constructor-struct>
            
            <constructor>
-           <predicate>)
+           <predicate>
+           
+           (module+ private
+             (provide declare-constructor-struct)))
          
          (require 'main)
          (provide (all-from-out 'main))

graph-lib/graph/define-adt.lp2.rkt

@@ -9,20 +9,60 @@
 
 @section{Introduction}
 
+@section{@racket[uninterned] and @racket[private]}
+
+We wish to be able to declare tags and constructors only
+visible to the creator, unlike the default ones which can be
+instantiated and matched against anonymously.
+
+We will define two flavours. In the first case, 
+@tc[uninterned] constructors inherit the interned one. It
+means that the interned constructor is a supertype of the
+uninterned constructor (but not the converse). Two distinct
+uninterned constructors with the same name are unrelated
+too. The second possibility is to declare a @tc[private]
+constructor, where the private constructor inherits directly
+from @tc[ConstructorTop], the base structure described in
+section @secref{constructor|supertype}, and is therefore
+unrelated to the interned constructor (and is unrelated to
+the uninterned constructor too).
+
+The choice to declare an uninterned or private 
+
+@CHUNK[<uninterned+private>
+       (define/syntax-parse ((~maybe with-struct declare-uninterned/private))
+         (cond [(attribute uninterned)
+                #`(#,(syntax-local-introduce #'constructor-name)
+                   declare-uninterned-constructor-struct)]
+               [(attribute private)
+                #`(#,(syntax-local-introduce #'constructor-name)
+                   declare-constructor-struct)]
+               [else #'()]))]
+
+The above code binds @tc[declare-uninterned/private] to
+either @tc[declare-uninterned-constructor-struct] or 
+@tc[declare-constructor-struct], depending on the keyword
+used. The macro's expansion will use this to declare 
+@tc[with-struct].
+
+@chunk[<declare-uninterned-or-private-struct>
+       (?? (declare-uninterned/private with-struct))]
+
 @section{@racket{define-constructor}}
 
 @chunk[<define-constructor>
        (define-syntax/parse
            (define-constructor constructor-name:id
-             (~maybe #:with-struct with-struct)
+             (~maybe (~optkw #:uninterned) (~optkw #:private))
              (~maybe #:? name?)
              type …)
-         
          (define/with-syntax default-name? (format-id #'name "~a?" #'name))
          (define-temp-ids "pat" (type …))
          (define-temp-ids "value" (type …))
+         <uninterned+private>
          (template
           (begin
+            <declare-uninterned-or-private-struct>
             (define-multi-id constructor-name
               #:type-expand-once
               (constructor constructor-name
@@ -44,37 +84,220 @@
                               (?? (?@ #:with-struct with-struct)))))))]
 
 @chunk[<define-tagged>
-       (define-syntax/parse (define-tagged tag:id
+       (define-syntax/parse (define-tagged constructor-name:id
-                              (~maybe #:with-struct with-struct)
+                              (~maybe (~optkw #:uninterned) (~optkw #:private))
                               (~maybe #:? name?)
                               [field type] …)
          (define/with-syntax default-name? (format-id #'name "~a?" #'name))
          (define-temp-ids "pat" (type …))
          (define-temp-ids "value" (type …))
+         <uninterned+private>
          (template
           (begin
-            (define-multi-id tag
+            <declare-uninterned-or-private-struct>
+            (define-multi-id constructor-name
               #:type-expand-once
-              (tagged tag
+              (tagged constructor-name
                       (?? (?@ #:with-struct with-struct))
                       [field type] …)
               #:match-expander
               (λ/syntax-parse (_ pat …)
-                #'(tagged tag
+                #'(tagged constructor-name
                           (?? (?@ #:with-struct with-struct))
                           [field pat] …))
               #:call
               (λ/syntax-parse (_ value …)
                 #'(tagged #:instance
-                          tag
+                          constructor-name
                           (?? (?@ #:with-struct with-struct))
-                          value …)))
+                          [field value] …)))
             (define-multi-id (?? name? default-name?)
               #:else
-              #'(tagged? tag
+              #'(tagged? constructor-name
                          (?? (?@ #:with-struct with-struct))
                          field …)))))]
 
+@section{Tests}
+
+@chunk[<test-define-tagged>
+       (define-tagged tagged-s1)
+       (define-tagged tagged-s2 [f Fixnum] [g String])
+       (define-tagged tagged-s3 [g String] [f Fixnum])
+       (define-tagged tagged-s4 [f Fixnum] [g String])
+       
+       (check-equal?: (match (ann (tagged-s1) (tagged tagged-s1))
+                        [(tagged-s1) #t])
+                      #t)
+       
+       (check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2)
+                        [(tagged-s2 f g) (cons g f)])
+                      '("z" . 99))
+       
+       (let ()
+         (check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2)
+                          [(tagged-s2 f g) (cons g f)])
+                        '("in-let" . 99)))
+       
+       (define (test-match val)
+         (match val
+           [(tagged-s2 x y) (list 'found-s2 y x)]
+           [(tagged-s3 x y) (list 'found-s3 y x)]
+           [(tagged-s4 x y) (list 'found-s4 y x)]))
+       
+       (check-equal?:
+        (test-match (ann (tagged-s2 2 "flob")
+                         (tagged tagged-s2 [f Fixnum] [g String])))
+        '(found-s2 "flob" 2))
+       
+       (check-equal?:
+        (test-match (ann (tagged-s3 "flob" 2)
+                         (tagged tagged-s3 [g String] [f Fixnum])))
+        '(found-s3 2 "flob"))
+       
+       ;; g and f are inverted in the “ann”
+       (check-equal?:
+        (test-match (ann (tagged-s4 2 "flob")
+                         (tagged tagged-s4 [g String] [f Fixnum])))
+        '(found-s4 "flob" 2))
+       
+       (define (test-match-verbose val)
+         (match val
+           [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)]
+           [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)]
+           [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)]))
+       
+       (check-equal?:
+        (test-match (ann (tagged-s2 3 "flob")
+                         (tagged tagged-s2 [f Fixnum] [g String])))
+        '(found-s2 "flob" 3))
+       
+       ;; g and f are inverted in the “ann”
+       (check-equal?:
+        (test-match (ann (tagged-s3 "flob" 3)
+                         (tagged tagged-s3 [f Fixnum] [g String])))
+        '(found-s3 3 "flob"))
+       
+       (check-equal?:
+        (test-match (ann (tagged-s4 3 "flob")
+                         (tagged tagged-s4 [f Fixnum] [g String])))
+        '(found-s4 "flob" 3))
+       
+       (check-not-equal?: (tagged-s2 4 "flob")
+                          (tagged-s3 "flob" 4))
+       (check-not-equal?: (tagged-s2 4 "flob")
+                          (tagged-s4 4 "flob"))]
+
+@chunk[<test-define-constructor>
+       (define-constructor c1)
+       (define-constructor c2 Fixnum String)
+       (define-constructor c3 Fixnum String)
+       
+       (check-equal?: (match (ann (c1) (constructor c1))
+                        [(c1) #t])
+                      #t)
+       
+       (check-equal?: (match (ann (c2 99 "z") c2)
+                        [(c2 f g) (cons g f)])
+                      '("z" . 99))
+       
+       (let ()
+         (check-equal?: (match (ann (c2 99 "in-let") c2)
+                          [(c2 f g) (cons g f)])
+                        '("in-let" . 99)))
+       
+       (define (test-c-match val)
+         (match val
+           [(c1) (list 'found-c1)]
+           [(constructor c2 x y z) (list 'found-c2-xyz z y x)]
+           [(c2 x y) (list 'found-c2 y x)]
+           [(c3 x y) (list 'found-c3 y x)]))
+       
+       (check-equal?:
+        (test-c-match (ann (c2 2 "flob")
+                           (constructor c2 Fixnum String)))
+        '(found-c2 "flob" 2))
+       
+       (check-equal?:
+        (test-c-match (ann (c3 2 "flob")
+                           (constructor c3 Fixnum String)))
+        '(found-c3 "flob" 2))]
+
+@chunk[<test-private-tagged>
+       (define-syntax-rule (defp make mt)
+         (begin
+           (define-tagged txyz #:private #:? 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-tagged txyz #:private #:? 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)]
+
+@chunk[<test-private-constructor>
+       (define-syntax-rule (defpc makec mtc)
+         (begin
+           (define-constructor cxyz #:private #:? cxyz? Number String)
+           
+           (define (makec) (cxyz 1 "b"))
+           
+           (define (mtc v)
+             (match v
+               ((cxyz x y) (list 'macro y x))
+               (_ #f)))))
+       
+       (defpc makec mtc)
+
+       (define-constructor cxyz #:private #:? cxyz? Number String)
+       
+       (check-equal?: (match (makec)
+                        ((constructor cxyz e f) (list 'out f e))
+                        (_ #f))
+                      #f)
+       
+       (check-equal?: (mtc (constructor cxyz 1 "b"))
+                      #f)
+       
+       (check-equal?: (mtc (makec))
+                      '(macro "b" 1))
+       
+       (check-not-equal?: (makec) (cxyz 1 "b"))
+       (check-equal?: (match (makec)
+                        ((cxyz e f) (list 'out f e))
+                        (_ #f))
+                      #f)
+       
+       (check-equal?: (mtc (cxyz 1 "b"))
+                      #f)]
+
 @section{Conclusion}
 
 @chunk[<*>
@@ -86,10 +309,16 @@
                                 racket/syntax
                                 (submod "../lib/low.rkt" untyped))
                     (for-meta 2 racket/base)
+                    "constructor.lp2.rkt"
+                    (submod "constructor.lp2.rkt" main private)
+                    "tagged.lp2.rkt"
                     "../lib/low.rkt"
                     "../type-expander/multi-id.lp2.rkt"
                     "../type-expander/type-expander.lp2.rkt")
            
+           (provide define-constructor
+                    define-tagged)
+           
            <define-constructor>
            <define-tagged>)
          
@@ -98,5 +327,12 @@
          
          (module* test typed/racket
            (require (submod "..")
+                    "constructor.lp2.rkt"
+                    "tagged.lp2.rkt"
                     "../lib/low.rkt"
-                    "../type-expander/type-expander.lp2.rkt")))]
+                    "../type-expander/type-expander.lp2.rkt")
+           
+           <test-define-constructor>
+           <test-define-tagged>
+           <test-private-constructor>
+           <test-private-tagged>))]

graph-lib/graph/get.lp2.rkt

@@ -103,14 +103,15 @@ otherwise throw an error:
                     l))
                  v)]
              [(_ v:expr field other-fields:id …)
-              #'(let ([v-cache v])
+              #'(get (uniform-get v field) other-fields …)
+              #;#'(let ([v-cache v])
                   (cond <get-tagged>
                         <get-promise>
                         <get-plain-struct>))])))]
 
 @chunk[<get-tagged>
        [((make-predicate (List Symbol Any)) v-cache)
-        (get (structure-get (cadr v-cache) field) other-fields …)]]
+        (get (uniform-get v-cache field) other-fields …)]]
 
 @chunk[<get-promise>
        [(promise? v-cache)
@@ -177,9 +178,9 @@ The type for the function generated by @tc[λget] mirrors the cases from
 
 @chunk[<type-for-get-field>
        [(_ T:expr field:id other-fields:id …)
-        #'(Promise
+        #'(ConstructorTop
-           (List Symbol
+           (Promise
-                 (structure-supertype [field : (has-get T other-fields …)])))]]
+            (plain-structure-supertype [field : (has-get T other-fields …)])))]]
 
 @chunk[<result-type-for-get>
        (λ (stx)
@@ -203,8 +204,7 @@ The type for the function generated by @tc[λget] mirrors the cases from
                               racket/syntax
                               (submod "../lib/low.rkt" untyped))
                   "../lib/low.rkt"
-                  "structure.lp2.rkt"
+                  "adt.lp2.rkt"
-                  "variant.lp2.rkt"
                   "graph.lp2.rkt"
                   "../type-expander/multi-id.lp2.rkt"
                   "../type-expander/type-expander.lp2.rkt"

graph-lib/graph/graph-6-rich-returns.lp2.rkt

@@ -110,6 +110,7 @@ plain list.
          (define-temp-ids "~a/node-marker" (mapping …))
          (define-temp-ids "~a/from-first-pass" (node …))
          ;(define/with-syntax id-~> (datum->syntax #'name '~>))
+         (define/with-syntax introduced-~> (datum->syntax #'name '~>))
          <inline-temp-nodes>
          (quasitemplate/debug debug
            (begin
@@ -150,7 +151,7 @@ plain list.
 
 @chunk[<replace-in-instance>
        (tmpl-replace-in-instance
-        (Let ~> second-step-marker-expander field-type)
+        (Let (introduced-~> second-step-marker-expander) field-type)
         <second-pass-replace>)]
 
 @chunk[<second-pass-type-expander>
@@ -276,8 +277,7 @@ encapsulating the result types of mappings.
                   "get.lp2.rkt"
                   "../type-expander/type-expander.lp2.rkt"
                   "../type-expander/multi-id.lp2.rkt"
-                  "structure.lp2.rkt" ; debug
+                  "adt.lp2.rkt" ; debug
-                  "variant.lp2.rkt" ; debug
                   "fold-queues.lp2.rkt"; debug
                   "rewrite-type.lp2.rkt"; debug
                   "meta-struct.rkt"; debug

graph-lib/graph/graph.lp2.rkt

@@ -562,15 +562,11 @@ the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type
 library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for
 that node's @tc[with-promises] type.
 
-@; TODO: use a type-expander here, instead of a template metafunction.
-
-@; TODO: use a private-constructor here (single field, no need to use a
-@; structure with define-private-tagged).
 @CHUNK[<define-promise-type/first-step>
-       (define-private-constructor node/promise-type
+       (define-constructor node/promise-type #:private
          (Promise node/with-promises))]
 @CHUNK[<define-with-promises>
-       (define-structure node/with-promises
+       (define-plain-structure node/with-promises
          [field <field/with-promises-type>] …)]
 
 @CHUNK[<field/with-promises-type>
@@ -599,6 +595,7 @@ library. We replace all occurrences of a @tc[node] name with its
 
 @chunk[<define-field/incomplete-type>
        (define-type field/incomplete-type <field/incomplete-type>)]
+
 @chunk[<field/incomplete-type>
        (tmpl-replace-in-type field-type
          [node node/placeholder-type] …)]
@@ -766,11 +763,9 @@ We will be able to use this type expander in function types, for example:
          x)
        (check-equal?:
         (let* ([v1 (car
-                    (structure-get (force (Tagged-value g))
+                    (uniform-get g streets))]
-                                   streets))]
                [v2 (ann (type-example v1) (gr Street))]
-               [v3 (structure-get (force (Tagged-value v2))
+               [v3 (uniform-get v2 sname)])
-                                  sname)])
           v3)
         : String
         "Ada Street")]
@@ -791,8 +786,7 @@ We will be able to use this type expander in function types, for example:
                   "fold-queues.lp2.rkt"
                   "rewrite-type.lp2.rkt"
                   "../lib/low.rkt"
-                  "structure.lp2.rkt"
+                  "adt.lp2.rkt"
-                  "variant.lp2.rkt"
                   "../type-expander/type-expander.lp2.rkt"
                   "../type-expander/multi-id.lp2.rkt"
                   "meta-struct.rkt")
@@ -815,27 +809,8 @@ not match the one from @tc[typed/racket]
        (module* test typed/racket
          (require (submod "..")
                   (only-in "../lib/low.rkt" cars cdrs check-equal?:)
-                  (only-in "structure.lp2.rkt" structure-get)
+                  (only-in "adt.lp2.rkt" uniform-get)
-                  "../type-expander/type-expander.lp2.rkt"
+                  "../type-expander/type-expander.lp2.rkt")
-                  typed/rackunit
-                  ;;DEBUG:
-                  (for-syntax syntax/parse
-                              racket/syntax
-                              syntax/parse/experimental/template
-                              racket/sequence
-                              racket/pretty
-                              "rewrite-type.lp2.rkt"
-                              (submod "../lib/low.rkt" untyped)
-                              "meta-struct.rkt")
-                  racket/splicing
-                  "fold-queues.lp2.rkt"
-                  "rewrite-type.lp2.rkt"
-                  "../lib/low.rkt"
-                  "structure.lp2.rkt"
-                  "variant.lp2.rkt"
-                  "../type-expander/type-expander.lp2.rkt"
-                  "../type-expander/multi-id.lp2.rkt"
-                  "meta-struct.rkt")
          
          (provide g)
          <use-example>

graph-lib/graph/remember.rkt

@@ -160,3 +160,11 @@
 (constructor . Number)
 (constructor . String)
 (constructor . Number)
+(constructor . c1)
+(constructor . c2)
+(constructor . c3)
+(constructor . wrapped-structure)
+(constructor . structure)
+(constructor . structure)
+(constructor . wstructure)
+(constructor . wstructure)

graph-lib/graph/rewrite-type.lp2.rkt

@@ -519,7 +519,17 @@ functions is undefined.
            [((~literal quote) a)
             #'(inst values 'a acc-type)]
            [x:id
-            #'(inst values x acc-type)]))]
+            #'(inst values x acc-type)]
+           [_
+            (raise-syntax-error 'recursive-replace-4
+                                (format (string-append "Syntax-parse failed\n"
+                                                       "  ~a\n"
+                                                       "  expanded to ~a")
+                                        (syntax->datum type)
+                                        (syntax->datum (expand-type type)))
+                                `(recursive-replace-4 ,(current-replacement))
+                                #f
+                                (list type))]))]
 
 @subsection{Union types}
 
@@ -648,8 +658,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
                          (only-in "../type-expander/type-expander.lp2.rkt"
                                   expand-type)
                          "meta-struct.rkt")
-             "structure.lp2.rkt"
-             "variant.lp2.rkt"
              "../type-expander/multi-id.lp2.rkt"
              "../type-expander/type-expander.lp2.rkt"
              "../lib/low.rkt")
@@ -683,8 +691,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
          (module* test typed/racket
            (require (submod "..")
                     typed/rackunit
-                    "structure.lp2.rkt"
-                    "variant.lp2.rkt"
                     "../type-expander/multi-id.lp2.rkt"
                     "../type-expander/type-expander.lp2.rkt")
            

graph-lib/graph/tagged.lp2.rkt

@@ -32,8 +32,9 @@ for a structure.
                           . structure-type)
          (quasitemplate
           (constructor tag (?? (?@ #:with-struct with-struct))
+                       (Promise
                         #,(syntax/loc #'structure-type
-                           (structure . structure-type)))))]
+                            (structure . structure-type))))))]
 
 @subsection{@racket[match-expander]}
 
@@ -42,8 +43,10 @@ for a structure.
                           . structure-pat)
          (quasitemplate
           (constructor tag (?? (?@ #:with-struct with-struct))
+                       (? promise?
+                          (app force
                                #,(syntax/loc #'structure-pat
-                           (structure . structure-pat)))))]
+                                   (structure . structure-pat)))))))]
 
 @subsection{@racket[instance creation]}
 
@@ -62,30 +65,39 @@ for a structure.
          (define-temp-ids "~a/arg" (sa.field …))
          (define/with-syntax c
            (if (attribute sa.type)
-               (quasitemplate
+               (quasitemplate <make-instance-with-types>)
-                (λ ([sa.field/arg : sa.type] …)
+               (quasitemplate <make-instance-infer>)))
-                  : (constructor tag (?? (?@ #:with-struct with-struct))
-                                 #,(syntax/loc #'fields
-                                     (structure [sa.field sa.type] …)))
-                  (constructor tag (?? (?@ #:with-struct with-struct))
-                               #,(syntax/loc #'fields
-                                   (structure #:instance
-                                              [sa.field : sa.type sa.field/arg]
-                                              …)))))
-               (quasitemplate
-                (λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …)
-                  : (constructor tag (?? (?@ #:with-struct with-struct))
-                                 #,(syntax/loc #'fields
-                                     (structure [sa.field sa.field/TTemp] …)))
-                  (constructor tag (?? (?@ #:with-struct with-struct))
-                               #,(syntax/loc #'fields
-                                   (structure #:instance
-                                              [sa.field sa.field/arg] …)))))))
          (if (attribute sa.value)
              #'(c sa.value …)
              #'c))]
 
-@subsection{@racket[predicate]}
+@CHUNK[<make-instance-with-types>
+       (λ ([sa.field/arg : sa.type] …)
+         : (constructor tag (?? (?@ #:with-struct with-struct))
+                        (Promise
+                         #,(syntax/loc #'fields
+                             (structure [sa.field sa.type] …))))
+         (constructor tag (?? (?@ #:with-struct with-struct))
+                      #,(syntax/loc #'fields
+                          (delay
+                            (structure #:instance
+                                       [sa.field : sa.type sa.field/arg]
+                                       …)))))]
+
+
+@CHUNK[<make-instance-infer>
+       (λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …)
+         : (constructor tag (?? (?@ #:with-struct with-struct))
+                        (Promise
+                         #,(syntax/loc #'fields
+                             (structure [sa.field sa.field/TTemp] …))))
+         (constructor tag (?? (?@ #:with-struct with-struct))
+                      #,(syntax/loc #'fields
+                          (delay
+                            (structure #:instance
+                                       [sa.field sa.field/arg] …)))))]
+
+@subsection{Predicate}
 
 @CHUNK[<tagged-top?>
        (define-multi-id TaggedTop?

graph-lib/graph/uniform-get.lp2.rkt

@@ -0,0 +1,78 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types: @racket[uniform-get]}
+
+@(table-of-contents)
+
+@section{Introduction}
+
+@section{Wrapped structures}
+
+@chunk[<wrapped-structure>
+       ;; Pre-declare the tag.
+       (let ()
+         (tagged #:instance wstructure)
+         (void))
+       
+       (define-multi-id wrapped-structure
+         #:type-expander
+         (λ/syntax-parse (_ . rest)
+           #'(tagged wstructure (structure . rest)))
+         #:match-expander
+         (λ/syntax-parse (_ . rest)
+           #'(tagged wstructure (structure . rest)))
+         #:call
+         (λ/syntax-parse (_ . rest)
+           #'(tagged wstructure (structure . rest))))
+
+       (define-type-expander (wrapped-structure-supertype stx)
+         (syntax-case stx ()
+           [(_ . rest)
+            #'(constructor wstructure
+                           (Promise
+                            (structure-supertype . rest)))]))]
+
+@section{@racket[uniform-get]}
+
+@racket[uniform-get] operates on tagged structures. It
+retrieves the desired field from the structure.
+
+@chunk[<uniform-get>
+       (define-syntax-rule (uniform-get v field)
+         (structure-get (force (constructor-values v)) field))]
+
+@section{Conclusion}
+
+@chunk[<*>
+       (begin
+         (module main typed/racket
+           (require (for-syntax racket/list
+                                syntax/parse
+                                syntax/parse/experimental/template
+                                racket/syntax
+                                (submod "../lib/low.rkt" untyped))
+                    "../lib/low.rkt"
+                    "../type-expander/multi-id.lp2.rkt"
+                    "../type-expander/type-expander.lp2.rkt"
+                    "constructor.lp2.rkt"
+                    "tagged.lp2.rkt"
+                    "structure.lp2.rkt"
+                    "define-adt.lp2.rkt")
+           
+           (provide wrapped-structure
+                    wrapped-structure-supertype
+                    uniform-get)
+           
+           <wrapped-structure>
+           <uniform-get>)
+         
+         (require 'main)
+         (provide (all-from-out 'main))
+         
+         (module* test typed/racket
+           (require (submod "..")
+                    "../lib/low.rkt"
+                    "../type-expander/type-expander.lp2.rkt")
+           ))]

graph-lib/graph/variant.lp2.rkt

@@ -1,330 +0,0 @@
-#lang scribble/lp2
-@(require "../lib/doc.rkt")
-@doc-lib-setup
-
-@title[#:style manual-doc-style]{Variants}
-
-@(table-of-contents)
-
-@section{@racket[tagged]}
-
-@section{@racket[define-tagged]}
-
-@chunk[<define-tagged>
-       (define-syntax/parse (define-tagged tag:id
-                              (~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))
-         (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 Boolean))
-            (define ((?? tag? default-tag?) x)
-              (and (Tagged-predicate? tag x)
-                   ((structure? field …) (Tagged-value x)))))))]
-
-@chunk[<test-define-tagged>
-       (define-tagged tagged-s1)
-       (define-tagged tagged-s2 [f Fixnum] [g String])
-       (define-tagged tagged-s3 [g String] [f Fixnum])
-       (define-tagged tagged-s4 [f Fixnum] [g String])
-       
-       (check-equal?: (match (ann (tagged-s1) (tagged tagged-s1))
-                        [(tagged-s1) #t])
-                      #t)
-       
-       (check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2)
-                        [(tagged-s2 f g) (cons g f)])
-                      '("z" . 99))
-       
-       (let ()
-         (check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2)
-                          [(tagged-s2 f g) (cons g f)])
-                        '("in-let" . 99)))
-       
-       (define (test-match val)
-         (match val
-           [(tagged-s2 x y) (list 'found-s2 y x)]
-           [(tagged-s3 x y) (list 'found-s3 y x)]
-           [(tagged-s4 x y) (list 'found-s4 y x)]))
-       
-       (check-equal?:
-        (test-match (ann (tagged-s2 2 "flob")
-                         (tagged tagged-s2 [f Fixnum] [g String])))
-        '(found-s2 "flob" 2))
-       
-       (check-equal?:
-        (test-match (ann (tagged-s3 "flob" 2)
-                         (tagged tagged-s3 [g String] [f Fixnum])))
-        '(found-s3 2 "flob"))
-       
-       ;; g and f are inverted in the “ann”
-       (check-equal?:
-        (test-match (ann (tagged-s4 2 "flob")
-                         (tagged tagged-s4 [g String] [f Fixnum])))
-        '(found-s4 "flob" 2))
-       
-       (define (test-match-verbose val)
-         (match val
-           [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)]
-           [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)]
-           [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)]))
-       
-       (check-equal?:
-        (test-match (ann (tagged-s2 3 "flob")
-                         (tagged tagged-s2 [f Fixnum] [g String])))
-        '(found-s2 "flob" 3))
-       
-       ;; g and f are inverted in the “ann”
-       (check-equal?:
-        (test-match (ann (tagged-s3 "flob" 3)
-                         (tagged tagged-s3 [f Fixnum] [g String])))
-        '(found-s3 3 "flob"))
-       
-       (check-equal?:
-        (test-match (ann (tagged-s4 3 "flob")
-                         (tagged tagged-s4 [f Fixnum] [g String])))
-        '(found-s4 "flob" 3))
-       
-       (check-not-equal?: (tagged-s2 4 "flob")
-                          (tagged-s3 "flob" 4))
-       (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 (~optional (~and C :colon)) 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[<define-uninterned-constructor>
-       (define-syntax/parse
-           (define-private-constructor tag:id
-             (~maybe #:? tag?)
-             T:expr …)
-         (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
-         (define-temp-ids "~a/struct" tag)
-         (define-temp-ids "~a/arg" (T …))
-         (define-temp-ids "~a/pat" (T …))
-         (define/syntax-parse (~or ([T₀:expr arg₀ pat₀])
-                                   ([Tᵢ:expr argᵢ patᵢ] …))
-           #'([T T/arg T/pat] …))
-         (template
-          (begin
-            (struct (X) tag/struct Tagged ()) ; Private
-            ;(struct (X) tag/struct interned ()) ; Uninterned
-            (define-multi-id tag
-              #:type-expand-once
-              (tag/struct (?? T₀ (List Tᵢ …)))
-              #:match-expander
-              (λ/syntax-parse (_ . (~and pats (?? ((~and pat₀ :expr))
-                                                  ((~and patᵢ :expr) …))))
-                (quasitemplate
-                 (and (? (make-predicate (tag/struct Any)))
-                      (app Tagged-value
-                           #,(syntax/loc #'pats
-                               (?? pat₀ (list patᵢ …)))))))
-              #:call
-              (λ/syntax-parse (_ . (~and args (?? ((~and arg₀ :expr))
-                                                  ((~and argᵢ :expr) …))))
-                (quasitemplate
-                 (tag/struct #,(syntax/loc #'args
-                                 (?? arg₀ (list argᵢ …)))))))
-            (: (?? tag? default-tag?) (→ Any Boolean : (tag/struct Any)))
-            (define ((?? tag? default-tag?) x)
-              ((make-predicate (tag/struct Any)) 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)]
-
-@chunk[<test-uninterned-constructor>
-       (define-syntax-rule (defpc makec mtc)
-         (begin
-           (define-private-constructor cxyz #:? cxyz? Number String)
-           
-           (define (makec) (cxyz 1 "b"))
-           
-           (define (mtc v)
-             (match v
-               ((cxyz x y) (list 'macro y x))
-               (_ #f)))))
-       
-       (defpc makec mtc)
-       
-       (define-private-constructor cxyz #:? cxyz? Number String)
-       
-       (check-equal?: (match (makec)
-                        ((constructor cxyz e f) (list 'out f e))
-                        (_ #f))
-                      #f)
-       
-       (check-equal?: (mtc (constructor cxyz 1 "b"))
-                      #f)
-       
-       (check-equal?: (mtc (makec))
-                      '(macro "b" 1))
-       
-       (check-not-equal?: (makec) (cxyz 1 "b"))
-       (check-equal?: (match (makec)
-                        ((cxyz e f) (list 'out f e))
-                        (_ #f))
-                      #f)
-       
-       (check-equal?: (mtc (cxyz 1 "b"))
-                      #f)]
-
-@section{Conclusion}
-
-@chunk[<*>
-       (begin
-         (module main typed/racket
-           (require (for-syntax racket/list
-                                syntax/parse
-                                syntax/parse/experimental/template
-                                racket/syntax
-                                (submod "../lib/low.rkt" untyped))
-                    "../lib/low.rkt"
-                    "../type-expander/multi-id.lp2.rkt"
-                    "../type-expander/type-expander.lp2.rkt"
-                    "structure.lp2.rkt")
-           (provide (rename-out [Tagged-predicate? Tagged?]
-                                [Tagged-type TaggedTop])
-                    Tagged-value
-                    constructor
-                    define-variant
-                    define-private-tagged
-                    define-private-constructor)
-           
-           <variant-supertype>
-           <remember-tags>
-           <named-sorted-tags>
-           <declare-all-tags>
-           <tag-name→stx-name>
-           
-           <predicate>
-           <constructor>
-           <define-variant>
-           <tagged>
-           <define-tagged>
-           <define-uninterned-tagged>
-           <define-uninterned-constructor>
-           
-           (module+ test-helpers
-             #;(provide Tagged-value)))
-         
-         (require 'main)
-         (provide (all-from-out 'main))
-         
-         (module* test typed/racket
-           (require (submod "..")
-                    (submod ".." main test-helpers)
-                    typed/rackunit
-                    "../lib/low.rkt"
-                    "../type-expander/type-expander.lp2.rkt")
-           
-           <test-constructor>
-           <test-define-variant>
-           <test-tagged>
-           <test-define-tagged>
-           <test-uninterned-tagged>
-           <test-uninterned-constructor>))]

graph-lib/graph/variant.lp2.rkt.old

@@ -0,0 +1,61 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@section{Uninterned tags}
+
+@section{Conclusion}
+
+@chunk[<*>
+       (begin
+         (module main typed/racket
+           (require (for-syntax racket/list
+                                syntax/parse
+                                syntax/parse/experimental/template
+                                racket/syntax
+                                (submod "../lib/low.rkt" untyped))
+                    "../lib/low.rkt"
+                    "../type-expander/multi-id.lp2.rkt"
+                    "../type-expander/type-expander.lp2.rkt"
+                    "structure.lp2.rkt")
+           (provide (rename-out [Tagged-predicate? Tagged?]
+                                [Tagged-type TaggedTop])
+                    Tagged-value
+                    constructor
+                    define-variant
+                    define-private-tagged
+                    define-private-constructor)
+           
+           <variant-supertype>
+           <remember-tags>
+           <named-sorted-tags>
+           <declare-all-tags>
+           <tag-name→stx-name>
+           
+           <predicate>
+           <constructor>
+           <define-variant>
+           <tagged>
+           <define-tagged>
+           <define-uninterned-tagged>
+           <define-uninterned-constructor>
+           
+           (module+ test-helpers
+             #;(provide Tagged-value)))
+         
+         (require 'main)
+         (provide (all-from-out 'main))
+         
+         (module* test typed/racket
+           (require (submod "..")
+                    (submod ".." main test-helpers)
+                    typed/rackunit
+                    "../lib/low.rkt"
+                    "../type-expander/type-expander.lp2.rkt")
+           
+           <test-constructor>
+           <test-define-variant>
+           <test-tagged>
+           <test-define-tagged>
+           <test-uninterned-tagged>
+           <test-uninterned-constructor>))]

graph-lib/lib.rkt

@@ -10,8 +10,7 @@
 (r/p "lib/low.rkt"
      "type-expander/multi-id.lp2.rkt"
      "type-expander/type-expander.lp2.rkt"
-     "graph/structure.lp2.rkt"
+     "graph/adt.lp2.rkt"
-     "graph/variant.lp2.rkt"
      "graph/graph.lp2.rkt"
      "graph/get.lp2.rkt"
      "graph/map.rkt"

graph-lib/lib/doc/example.lp2.rkt

@@ -18,7 +18,9 @@ In section @secref{doc/example|foo} we present, blah blah.
 
 @subsection[#:tag "doc/example|foo"]{My subsection}
 
-@$${\frac{2x}{x^2}}
+@$${\frac{\href{//jsmaniac.github.io}{2x}}{\class{some-css-class}{x^2}}}
+
+
 @(colorize (filled-ellipse 30 15) "blue")
 @; Line comment
 

graph-lib/main.rkt

@@ -6,7 +6,7 @@
 
 (require "type-expander/type-expander.lp2.rkt")
 (require "type-expander/multi-id.lp2.rkt")
-(require "graph/variant.lp2.rkt")
+(require "graph/adt.lp2.rkt")
 |#
 
 #|
@@ -109,7 +109,7 @@
 (module m typed/racket
   (provide ma)
   (require "type-expander/type-expander.lp2.rkt")
-  (require "graph/variant.lp2.rkt")
+  (require "graph/adt.lp2.rkt")
   
   ;(let ()
   ;(define-tagged ma (fav String))

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

@@ -83,6 +83,8 @@ else.
 
 @chunk[<apply-type-expander>
        (define (apply-type-expander type-expander-stx stx)
+         (displayln type-expander-stx)
+         (displayln (syntax->datum type-expander-stx))
          (let ([type-expander (syntax-local-value type-expander-stx)])
            (((get-prop:type-expander-value type-expander) type-expander) stx)))]
 
@@ -133,9 +135,15 @@ else.
                      . args) ;; TODO: test
                     #:with expanded-once
                     #'(nested-application.expanded-once . args))
-           (pattern (~datum ~>)
+           (pattern (~and xxx (~datum ~>))
                     #:with expanded-once #'()
-                    #:when (displayln (format "dict = ~a" (dict->list env)))
+                    #:when (display (format "dict =\n  "))
+                    #:when (displayln (dict->list env))
+                    #:when (displayln #'xxx)
+                    #:when (newline)
+                    #:when (pretty-write (map syntax-debug-info
+                                              (map car (dict->list env))))
+                    #:when (pretty-write (syntax-debug-info #'xxx))
                     #:when #f))
          
          (define-syntax-class fa (pattern (~or (~literal ∀) (~literal All))))
@@ -155,7 +163,8 @@ else.
                  #,(expand-type #'T (bind-type-vars #'(TVar ...) env)))]
            [((~literal Rec) R:id T:expr)
             #`(Rec R #,(expand-type #'T (bind-type-vars #'(R) env)))]
-           [((~datum Let) [V:id E:id] T:expr);; TODO: ~literal instead of ~datum
+           [((~commit (~datum Let)) [V:id E:id] T:expr)
+            ;; TODO: ~literal instead of ~datum
             ;; TODO: ~commit  when we find Let, so that syntax errors are not
             ;; interpreted as an arbitrary call.
             ;; TODO : for now we only allow aliasing (which means E is an id),