WIP.

graph-lib/graph/__DEBUG_graph5.rkt

@@ -49,7 +49,7 @@
          (for-syntax syntax/parse))
 
 (define-graph/multi-ctor gm ([a [b1 : b] [b2 : b] [s : String] [v : Number]]
-                             [b [a : a] [s : String] [v : Number]])
+                             [b [a1 : a] [s : String] [v : Number]])
   [(r [v : Integer] [w : String])
    : a
    (printf "r ~a ~a\n" v w)
@@ -70,6 +70,6 @@
 (check-equal?: (get gmi v) 3)
 (check-equal?: (get gmi b1 v) 2)
 (check-equal?: (get gmi b1 s) "x")
-(check-equal?: (get gmi b1 a v) 2)
+(check-equal?: (get gmi b1 a1 v) 2)
-;(check-equal?: (get gmi b1 a b1 a v) 1)
+;(check-equal?: (get gmi b1 a1 b1 a1 v) 1)
-;(check-equal?: (get gmi b1 a b1 a b1 v) 1)
+;(check-equal?: (get gmi b1 a1 b1 a1 b1 v) 1)

graph-lib/graph/graph-modify.lp2.rkt

@@ -0,0 +1,699 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Graph library}
+
+@(table-of-contents)
+
+@; TODO: allow a mapping to return a new placeholder, in order to act as a
+@; redirect. All references to the old placeholder will act as if they were to
+@; the new placeholder.
+
+@section{Introduction}
+
+This module provides a @tc[graph] macro which helps constructing immutable
+graphs (using lambdas to defer potentially cyclic references).
+
+@subsection{Example usage}
+
+We will start with a running example, which will help us both show the macro's
+syntax, and see some of the key advantages offered by this graph library.
+
+@subsection{The graph's type}
+
+Each node type in the graph is a variant's constructor, tagged with the node
+name. For example, a graph representing a city and its inhabitants could use
+these constructors:
+
+@chunk[<example-variants>
+       [City [streets : (Listof Street)] [people : (Listof Person)] <m-city>]
+       [Street [sname : String] [houses : (Listof House)] <m-street>]
+       [House [owner : Person] [location : Street] <m-house>]
+       [Person [name : String] <m-person>]]
+
+Notice the cycle in the type: a street contains houses, which are located on the
+same street.
+
+@subsubsection{A seed from which to unravel the graph: the root parameters}
+
+In order to build a graph with that type, we start from the root parameters.
+Here, we will take a representation of the city as a list of
+@tc[(street-name . person-name)] pairs, and will convert it to a more convenient
+graph representation. Our single root parameter will thus be the whole list:
+
+@chunk[<example-root>
+       '(["Amy" . "Ada Street"]
+         ["Jack" . "J Street"]
+         ["Anabella" . "Ada Street"])]
+
+We will then provide a mapping from the root parameter to the root node, in our
+case @tc[City]. When processing the root parameter, one can call other mappings
+that will create their corresponding nodes.
+
+@subsubsection{Mapping the root parameters to the root node}
+
+Here is the root mapping for our example. It maps over the list of names and
+street names @tc[c], and calls for each element the @tc[m-street] and
+@tc[m-person] mappings.
+
+@; Would be nicer with (map (∘ (curry street c) car) c)), but that doesn't
+@; typecheck (yet).
+@chunk[<m-city>
+       [(m-city [c : (Listof (Pairof String String))])
+        (City (remove-duplicates (map (curry m-street c) (cdrs c)))
+              (remove-duplicates (map m-person (cars c))))]]
+
+@subsubsection{More mappings}
+
+Next, we write the @tc[m-street] mapping, which takes a street name and the
+whole city @tc[c] in list form, and creates a @tc[Street] node.
+
+@chunk[<m-street>
+       [(m-street [c : (Listof (Pairof String String))] [s : String])
+        (Street s (map (curry (curry m-house s) c)
+                       (cars (filter (λ ([x : (Pairof String String)])
+                                       (equal? (cdr x) s))
+                                     c))))]]
+
+The @tc[m-house] mapping defined below calls back the @tc[m-street] mapping, to
+store for each house a reference to the containing street. Normally, this would
+cause infinite recursion in an eager language, like @tc[typed/racket]. However,
+the mappings aren't called directly, and instead, in the body of @tc[m-house],
+@tc[m-street] is shadowed by a function which returns a placeholder. This allows
+us to not worry about mutually recursive mappings: a mapping can be called any
+number of times with the same data, it will actually only be run once.
+
+The @tc[define-graph] macro will post-process the result of each mapping, and
+replace the placeholders with promises for the the result of the mapping. The
+promises are not available during graph construction, so there is no risk of
+forcing one before it is available.
+
+We can now write the @tc[m-house] and @tc[m-person] mappings.
+
+@chunk[<m-house>
+       [(m-house [s : String]
+                 [c : (Listof (Pairof String String))]
+                 [p : String])
+        (House (m-person p) (m-street c s))]]
+
+@chunk[<m-person>
+       [(m-person [p : String])
+        (Person p)]]
+
+@subsubsection{Creating an instance of the graph}
+
+For now, we will supply directly the root arguments to the @tc[define-graph]
+macro, as well as the node types and mappings. We can later curry the macro, so
+that it first takes the node types and mappings, and produces a lambda taking
+the root arguments as parameters.
+
+@chunk[<use-example>
+       (define-graph gr <example-variants>)
+       #;(define g (gr <example-root>))
+       (define g1 (gr <example-root>))
+       (define g g1)]
+
+@subsection{More details on the semantics}
+
+Let's take a second look at the root mapping:
+
+@chunk[<m-city-2>
+       [(m-city [c : (Listof (Pairof String String))])
+        (City (remove-duplicates (map (curry m-street c) (cars c)))
+              (remove-duplicates (map m-person (cdrs c))))]]
+
+As this example shows, we can use @tc[m-street] as any other function, passing
+it to @tc[curry], and calling @tc[remove-duplicates] on the results. Note that
+each placeholder returned by @tc[m-street] will contain all information passed
+to it, here a street name and @tc[c]. Two placeholders for @tc[m-street] will
+therefore be @tc[equal?] if and only if all the arguments passed to
+@tc[m-street] are @tc[equal?]. The placeholders also include a symbol specifying
+which mapping was called, so two placeholders for two different mappings will
+not be @tc[equal?], even if identical parameters were supplied.
+
+The node type allowing placeholders is derived from the ideal type given above.
+Here, the type for @tc[Person] is @tc[[Person [name : String]]], so there are no
+substitutions to make. Conversely, the type for @tc[City], originally expressed
+as @tc[[(Listof Street) (Listof Person)]], will be rewritten as
+@tc[[(Listof Street/placeholder-type) (Listof Person/placeholder-type)]].
+
+The @tc[rewrite-type] module, which we use to derive types with placeholders
+from the ideal ones, only handles a handful of the types offered by
+@tc[typed/racket]. In particular, it does not handle recursive types described
+with @tc[Rec] yet.
+
+@section{Implementation}
+
+In this section, we will describe how the @tc[define-graph] macro is
+implemented.
+
+@subsection{The macro's syntax}
+
+We use a simple syntax for @tc[define-graph], and make it more flexible through
+wrapper macros.
+
+@chunk[<signature>
+       (define-graph name
+         (~optional (~and debug #:debug))
+         (~maybe #:definitions (extra-definition:expr …))
+         [node <field-signature> … <mapping-declaration>]
+         …)]
+
+Where @tc[<field-signature>] is:
+
+@chunk[<field-signature>
+       [field:id :colon field-type:expr]]
+
+And @tc[<mapping-declaration>] is:
+
+@chunk[<mapping-declaration>
+       ((mapping:id [param:id :colon param-type:expr] …)
+        . mapping-body)]
+
+@subsection{The different types of a node}
+
+A single node name can refer to several types:
+
+@itemlist[
+ @item{The @emph{ideal} type, expressed by the user, for example
+  @racket[[City (Listof Street) (Listof Person)]], it is never used as-is in
+  practice}
+ @item{The @emph{placeholder} type, type and constructor, which just store the
+  arguments for the mapping along with a tag indicating the node name}
+ @item{The @emph{incomplete} type, in which references to other node types are
+  allowed to be either actual (@racket[incomplete]) instances, or placeholders.
+  For example, @racket[[City (Listof (U Street Street/placeholder-type))
+                        (Listof (U Person Person/placeholder-type))]].}
+ @item{The @emph{with-indices} type, in which references to other node types
+  must be replaced by an index into the results list for the target node's
+  @racket[with-promises] type. For example,
+  @racket[[City (Listof (List 'Street/with-indices-tag2 Index))
+           (Listof (List 'Person/with-indices-tag2 Index))]].}
+ @item{The @emph{with-promises} type, in which references to other node types
+  must be replaced by a @racket[Promise] for the target node's
+  @racket[with-promises] type. For example,
+  @racket[[City (Listof (Promise Street/with-promises-type))
+           (Listof (Promise Person/with-promises-type))]].}
+ @item{The @emph{mapping function}, which takes some parameters and
+  returns a node (using the code provided by the user)}]
+
+We derive identifiers for these based on the @tc[node] name:
+
+@;;;;
+@chunk[<define-ids>
+       (define/with-syntax ((root-param …) . _) #'((param …) …))
+       (define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
+       
+       (define-temp-ids "~a/main-constructor" name)
+       (define-temp-ids "~a/constructor" (node …) #:first-base root)
+       (define-temp-ids "~a/make-placeholder" (node …) #:first-base root)
+       (define-temp-ids "~a/placeholder-struct" (node …))
+       (define-temp-ids "~a/placeholder-type" (node …))
+       (define-temp-ids "~a/placeholder-queue" (node …))
+       
+       (define-temp-ids "~a/incomplete-type" (node …))
+       (define-temp-ids "~a/make-incomplete" (node …))
+       (define-temp-ids "~a/incomplete-tag" (node …))
+       
+       (define-temp-ids "~a/with-indices-type" (node …))
+       (define-temp-ids "~a/make-with-indices" (node …))
+       (define-temp-ids "~a/with-indices-tag" (node …))
+       (define-temp-ids "~a/with-indices-tag2" (node …))
+       (define-temp-ids "~a/index-type" (node …))
+       (define-temp-ids "~a/with-indices→with-promises" (node …)
+         #:first-base root)
+       
+       (define-temp-ids "~a/with-promises-type" (node …) #:first-base root)
+       (define-temp-ids "~a/make-with-promises" (node …))
+       (define-temp-ids "~a/with-promises-tag" (node …))
+       
+       (define-temp-ids "~a/mapping-function" (node …))
+       
+       (define-temp-ids "~a/database" (node …) #:first-base root)
+       
+       (define-temp-ids "~a/value" ((field …) …))]
+
+@subsection{Overview}
+
+The macro relies heavily on two sidekick modules: @tc[rewrite-type], and
+@tc[fold-queue]. The former will allow us to derive from the ideal type of a
+node the incomplete type and the with-promises type. It will also allow us to
+search inside instances of incomplete nodes, in order to extract the
+placehoders, and replace these parts with promises. The latter, @tc[fold-queue],
+will be used to process all the pending placeholders, with the possibility to
+enqueue more as new placeholders are discovered inside incomplete nodes.
+
+When the graph constructor is called with the arguments for the root parameters,
+it is equivalent to make and then resolve an initial placeholder. We will use a
+function from the @tc[fold-queue] library to process the queues of pending
+placeholders, starting with a queue containing only that root placeholder.
+We will have one queue for each placeholder type.@note{It we had only one queue,
+ we would have only one collection of results, and would need a @racket[cast]
+ when extracting nodes from the collection of results.} The element types of the
+queues will therefore be these placeholder types.
+
+@chunk[<fold-queue-type-element>
+       node/placeholder-type]
+
+The return type for each queue will be the corresponding with-indices type. The
+fold-queues function will therefore return a vector of with-indices nodes for
+each node type.
+
+@chunk[<fold-queue-type-result>
+       node/with-indices-type]
+
+
+@; Problem: how do we ensure we return the right type for the root?
+@; How do we avoid casts when doing look-ups?
+@; We need several queues, handled in parallel, with distinct element types.
+@; * Several result aggregators, one for each type, so we don't have to cast
+@; * Several queues, so that we can make sure the root node is of the expected
+@;   type.
+
+@; TODO: clarity.
+@; The @tc[fold-queues] function allows us to associate each element with a tag,
+@; so that, inside the processing function and outside, we can refer to an
+@; element using this tag, which can be more lightweight than keeping a copy of
+@; the element.
+@; 
+@; We will tag our elements with an @tc[Index], which prevents memory leakage:
+@; if we kept references to the original data added to the queue, a graph's
+@; representation would hold references to its input, which is not the case when
+@; using simple integers to refer to other nodes, instead of using the input for
+@; these nodes. Also, it makes lookups in the database much faster, as we will
+@; be able to use an array instead of a hash table.
+
+@subsection{The queues of placeholders}
+
+The fold-queues macro takes a root element, in our case the root placeholder,
+which it will insert into the first queue. The next clauses are the queue
+handlers, which look like function definitions of the form
+@tc[(queue-name [element : element-type] Δ-queues enqueue) : result-type]. The
+@tc[enqueue] argument is a function used to enqueue elements and get a tag in
+return, which can later be used to retrieve the processed element.
+
+Since the @tc[enqueue] function is pure, it takes a parameter of the same type
+as @tc[Δ-queues] representing the already-enqueued elements, and returns a
+modified copy, in addition to the tag. The queue's processing body should return
+two values: the result of processing the element, and the latest version of
+@tc[Δ-queues], which stores the new elements to be added to the queue.
+
+@chunk[<fold-queues>
+       (fold-queues #:root queue-name
+                    placeholder
+                    [(node/placeholder-queue [e : <fold-queue-type-element>]
+                                             [Δ-queues : Δ-Queues]
+                                             enqueue)
+                     : <fold-queue-type-result>
+                     <fold-queue-body>]
+                    ...)]
+
+@subsection{Making placeholders for nodes}
+
+We start creating the root placeholder which we provide to @tc[fold-queues].
+
+@chunk[<root-placeholder>
+       (root/make-placeholder root-param …)]
+
+To make the placeholder, we will need a @tc[node/make-placeholder] function for
+each @tc[node]. We first define the type of each placeholder (a list of
+arguments, tagged with the @tc[node]'s name):
+
+@; TODO: maybe replace node types with placeholder types
+
+@chunk[<define-placeholder-type>
+       (struct (A) node/placeholder-struct ([f : A]))
+       (define-type node/placeholder-type
+         (node/placeholder-struct (List param-type …)))]
+
+@; TODO: just use (variant [mapping param-type ...] ...)
+
+Then we define the @tc[node/make-placeholder] function:
+
+@chunk[<define-make-placeholder>
+       (: node/make-placeholder (→ param-type … node/placeholder-type))
+       (define (node/make-placeholder param …)
+         ((inst node/placeholder-struct (List param-type …)) (list param …)))]
+
+@subsection{Making with-indices nodes}
+
+We derive the @tc[with-indices] type from each @emph{ideal} node type using the
+@tc[tmpl-replace-in-type] template metafunction from the rewrite-type library.
+We replace all occurrences of a @tc[node] name with an @tc[Index], which
+indicates at which index in the queue's results the successor can be found.
+
+@; TODO: use a type-expander here, instead of a template metafunction.
+
+@CHUNK[<define-with-indices>
+       (define-type node/index-type (List 'node/with-indices-tag2 Index))
+       
+       (define-type node/with-indices-type
+         (List 'node/with-indices-tag <field/with-indices-type> …))
+       
+       (: node/make-with-indices (→ <field/with-indices-type> …
+                                    node/with-indices-type))
+       (define (node/make-with-indices field …)
+         (list 'node/with-indices-tag field …))]
+
+@CHUNK[<field/with-indices-type>
+       (tmpl-replace-in-type field-type [node node/index-type] …)]
+
+@subsection{Making with-promises nodes}
+
+We derive the @tc[with-promises] type from each @emph{ideal} node type using
+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.
+
+@CHUNK[<define-with-promises>
+       (define-type node/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/value …)
+         (tagged node/with-promises-tag
+                 [field : <field/with-promises-type> field/value]
+                 …))]
+
+@CHUNK[<field/with-promises-type>
+       (tmpl-replace-in-type field-type
+                             [node (Promise node/with-promises-type)] …)]
+
+@subsection{Making incomplete nodes}
+
+We derive the @tc[incomplete] type from each @emph{ideal} node type using
+the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type
+library. We replace all occurrences of a @tc[node] name with its
+@tc[placeholder] type.
+
+@; TODO: use a type-expander here, instead of a template metafunction.
+
+@CHUNK[<define-incomplete>
+       (define-type node/incomplete-type
+         (List 'node/incomplete-tag <field/incomplete-type> …))
+       
+       (: node/make-incomplete (→ <field/incomplete-type> …
+                                  node/incomplete-type))
+       (define (node/make-incomplete field …)
+         (list 'node/incomplete-tag field …))]
+
+@CHUNK[<field/incomplete-type>
+       (tmpl-replace-in-type field-type
+                             [node node/placeholder-type] …)]
+
+@subsection{Converting incomplete nodes to with-indices ones}
+
+@; TODO: we don't need that many annotations
+@chunk[<placeholder→with-indices-function>
+       (λ ([p : node/placeholder-type] [Δ-acc : Δ-Queues])
+         : (values (List 'node/with-indices-tag2 Index) Δ-Queues)
+         (% index new-Δ-acc = (enqueue 'node/placeholder-queue p Δ-acc)
+            (values (list 'node/with-indices-tag2 index)
+                    new-Δ-acc)))]
+
+@chunk[<placeholder→with-indices-clause>
+       [node/placeholder-type
+        (List 'node/with-indices-tag2 Index)
+        (struct-predicate node/placeholder-struct)
+        <placeholder→with-indices-function>]]
+
+@subsubsection{Processing the placeholders}
+
+@; TODO: also allow returning a placeholder (which means we should then
+@; process that placeholder in turn). The placeholder should return the
+@; same node type, but can use a different mapping?
+@; Or maybe we can do this from the ouside, using a wrapper macro?
+
+@; TODO: we don't need that many let etc., use % instead once everything works.
+@CHUNK[<fold-queue-body>
+       (let ([mapping-result
+              (apply node/mapping-function
+                     ((struct-accessor node/placeholder-struct 0) e))]
+             [f (tmpl-fold-instance (List <field-incomplete-type> …)
+                                    Δ-Queues
+                                    <placeholder→with-indices-clause> …)])
+         (let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)])
+           (values (apply node/make-with-indices r)
+                   new-Δ-queues)))]
+
+Where @tc[<field-incomplete-type>] is the @tc[field-type] in which node types
+are replaced by placeholder types:
+
+@chunk[<field-incomplete-type>
+       (tmpl-replace-in-type field-type
+                             [node node/placeholder-type] …)]
+
+@subsection{The mapping functions}
+
+We define the mapping functions as they are described by the user, with an
+important change: Instead of returning an @emph{ideal} node type, we expect them
+to return an @emph{incomplete} node type.
+
+@chunk[<define-mapping-function>
+       (: node/mapping-function (→ param-type … node/incomplete-type))
+       (define node/mapping-function
+         (let ([mapping node/make-placeholder]
+               …
+               [node node/make-incomplete]
+               …)
+           (λ ([param : param-type] …) : node/incomplete-type
+             . mapping-body)))]
+
+@subsection{Returning a with-promises nodes}
+
+We will return a with-promises version of the root node, which contains promises
+for its successors. The user can then force one of these to obtain the
+with-promises version of the desired successor.
+
+@; TODO: put a diagram here, or an example at least
+
+This use of promises is safe, since their resolution depends only on the vectors
+returned by fold-queues, which are already fully computed when we create the
+root with-promises node. We therefore have no risk of forcing a promise that
+can't be resolved, or that would depend on itself, causing an infinite loop.
+
+@subsubsection{Why use promises?}
+
+We use promises because we would like to only use immutable data structures.
+Resolving the links in the graph would require mutating the nodes, so instead,
+when extracting the @emph{placeholders} from an @emph{incomplete} node, we
+produce a @emph{with-indices} node, which, instead of direct references to the
+successors, just stores a tag and index. Later, the successors are processed,
+and stored at the corresponding index in the queue for that tag.
+
+We then wrap each tagged index with a lambda, which also holds a reference to
+the vectors returned by fold-queue, which containin all the with-indices nodes.
+When calling the lambda, it extracts the with-indices node for that tag and
+index, further replaces the tagged indices within, and returns a brand new
+with-promises node.
+
+We could leave it as that, having the with-promises nodes contain lambdas
+instead of actual references to their successors. However, when an immutable
+function (like one of these lambdas) is called twice with the same arguments (in
+this case none), @tc[typed/racket]'s occurrence typing currently does not infer
+that the result will always be the same. This means that pattern-matching using
+the @tc[match] macro won't work properly, for example. We therefore wrap these
+functions into promises. The occcurrence typing mechanism in @tc[typed/racket]
+knows that a promise will always return the same value when forced multiple
+times. By default, promises use mutable data structures under the hood, to cache
+their result, but we do not rely on that. We could use @tc[delay/name], which
+doesn't cache the return value, but it was removed from @tc[typed/racket]
+because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it
+ caused type safety problems}.
+
+@subsubsection{Creating with-promises nodes from with-indices ones}
+
+@chunk[<index→promise-clause>
+       [node/index-type
+        (Promise node/with-promises-type)
+        (λ (x) (and (pair? x)
+                    (eq? (car x) 'node/with-indices-tag2)))
+        (λ ([tagged-index : node/index-type] [acc : Void])
+          : (values (Promise node/with-promises-type) Void)
+          (values <index→promise> acc))]]
+
+TODO: check what we are closing over in that promise.
+I think we are closing over the successor-with-index (but not its whole
+database), as well as everything that the with-indices→with-promises function
+closes over.
+
+@chunk[<index→promise>
+       (let ([successor-with-index (vector-ref node/database
+                                               (cadr tagged-index))])
+         (delay (node/with-indices→with-promises successor-with-index)))]
+
+@chunk[<define-with-indices→with-promises>
+       (: node/with-indices→with-promises (→ node/with-indices-type
+                                             node/with-promises-type))
+       (define (node/with-indices→with-promises n)
+         (define f (tmpl-fold-instance (List <field-with-indices-type> …)
+                                       Void
+                                       <index→promise-clause> …))
+         (apply node/make-with-promises (first-value (f (cdr n) (void)))))]
+
+Where @tc[<field-with-indices-type>] is the @tc[field-type] in which node types
+are replaced by tagged indices:
+
+@chunk[<field-with-indices-type>
+       (tmpl-replace-in-type field-type [node node/index-type] …)]
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+@section{Referencing the type of nodes}
+
+The identifier defined by @tc[define-graph] will both act as a constuctor for
+graph instances, and as a type-expander, that we will use to reference the node
+types. We will thus be able to refer to the type of Street nodes in our example
+via @tc[(g Street)].
+
+@chunk[<graph-type-expander>
+       (λ (stx)
+         (syntax-parse stx
+           [(_ (~datum node)) #'node/with-promises-type] …
+           [(_ #:incomplete (~datum node)) #'node/incomplete-type] …
+           [(_ #:make-incomplete (~datum node))
+            #'(→ <field/incomplete-type> … node/incomplete-type)] …
+           [(_ #:incomplete (~datum node) fld)
+            (syntax-parse #'fld
+              [(~datum field) #'<field/incomplete-type>] …)] …
+           [(_ #:make-placeholder (~datum node))
+            #'(→ param-type … node/placeholder-type)] …
+           [(_ #:placeholder (~datum node)) #'node/placeholder-type] …))]
+
+We will be able to use this type expander in function types, for example:
+
+@chunk[<type-example>
+       (define (type-example [x : (gr Street)])
+         : (gr Street)
+         x)
+       (check-equal?: (let* ([v1 (car (structure-get (cadr (force g)) streets))]
+                             [v2 (ann (type-example (force v1)) (gr Street))]
+                             [v3 (structure-get (cadr v2) sname)])
+                        v3)
+                      : String
+                      "Ada Street")]
+
+@section{Putting it all together}
+
+@chunk[<define-graph>
+       (define-syntax/parse <signature>
+         <define-ids>
+         ((λ (x)
+            (when (attribute debug)
+              (pretty-write (syntax->datum x)))
+            x)
+          (template
+           ;(let ()
+           (begin
+             (define-multi-id name
+               #:type-expander <graph-type-expander>
+               #:call (λ (stx)
+                        (syntax-parse stx
+                          ;; TODO: move this to a dot expander, so that writing
+                          ;; g.a gives a constructor for the a node of g, and
+                          ;; (g.a foo bar) or (let ((c .g.a)) (c foo bar)) both
+                          ;; call it
+                          [(_ #:λroot (~datum node))
+                           #'node/constructor]
+                          …
+                          [(_ #:root (~datum node) . rest)
+                           (syntax/loc stx (node/constructor . rest))]
+                          …
+                          [(_ . rest)
+                           (syntax/loc stx (root/constructor . rest))]))
+               #:id (λ (stx) #'root/constructor))
+             
+             (?? (splicing-let ([mapping node/make-placeholder]
+                                …
+                                [node node/make-incomplete]
+                                …)
+                   extra-definition
+                   …))
+             
+             (begin <define-placeholder-type>) …
+             (begin <define-make-placeholder>) …
+             (begin <define-with-indices>) …
+             (begin <define-with-promises>) …
+             (begin <define-incomplete>) …
+             
+             (begin <define-mapping-function>) …
+             
+             (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type
+                             (List (Vectorof node/with-indices-type) …))
+                          …))
+             (define (fq queue-name placeholder)
+               <fold-queues>)
+             
+             <constructors>))))]
+
+@chunk[<constructors>
+       (begin
+         (: node/constructor (→ param-type … (Promise node/with-promises-type)))
+         (define (node/constructor param …)
+           (match-let ([(list node/database …)
+                        (fq 'node/placeholder-queue
+                            (node/make-placeholder param …))])
+             (begin <define-with-indices→with-promises>) …
+             (delay (node/with-indices→with-promises
+                     (vector-ref node/database 0))))))
+       …]
+
+@chunk[<module-main>
+       (module main typed/racket
+         (require (for-syntax syntax/parse
+                              racket/syntax
+                              syntax/stx
+                              syntax/parse/experimental/template
+                              racket/sequence
+                              racket/pretty
+                              "rewrite-type.lp2.rkt"
+                              "../lib/low-untyped.rkt"
+                              "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")
+         
+         ;(begin-for-syntax
+         ;<multiassoc-syntax>)
+         
+         (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 "..")
+                  (only-in "../lib/low.rkt" cars cdrs check-equal?:)
+                  (only-in "structure.lp2.rkt" structure-get)
+                  "../type-expander/type-expander.lp2.rkt"
+                  typed/rackunit)
+         
+         (provide g)
+         <use-example>
+         <type-example>)]
+
+The whole file, finally:
+
+@chunk[<*>
+       (begin
+         <module-main>
+         
+         (require 'main)
+         (provide (all-from-out 'main))
+         
+         <module-test>)]

graph-lib/graph/graph.lp2.rkt

@@ -208,8 +208,8 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/main-constructor" name)
        (define-temp-ids "~a/constructor" (node …) #:first-base root)
        (define-temp-ids "~a/make-placeholder" (node …) #:first-base root)
+       (define-temp-ids "~a/placeholder-struct" (node …))
        (define-temp-ids "~a/placeholder-type" (node …))
-       (define-temp-ids "~a/placeholder-tag" (node …))
        (define-temp-ids "~a/placeholder-queue" (node …))
        
        (define-temp-ids "~a/incomplete-type" (node …))
@@ -226,7 +226,7 @@ We derive identifiers for these based on the @tc[node] name:
        
        (define-temp-ids "~a/with-promises-type" (node …) #:first-base root)
        (define-temp-ids "~a/make-with-promises" (node …))
-       (define-temp-ids "~a/with-promises-tag" (node …))
+       (define-temp-ids "~a/with-promises-struct" (node …))
        
        (define-temp-ids "~a/mapping-function" (node …))
        
@@ -323,9 +323,9 @@ arguments, tagged with the @tc[node]'s name):
 @; TODO: maybe replace node types with placeholder types
 
 @chunk[<define-placeholder-type>
+       (struct (A) node/placeholder-struct ([f : A]))
        (define-type node/placeholder-type
-         (List 'node/placeholder-tag
+         (node/placeholder-struct (List param-type …)))]
-               param-type …))]
 
 @; TODO: just use (variant [mapping param-type ...] ...)
 
@@ -334,7 +334,7 @@ Then we define the @tc[node/make-placeholder] function:
 @chunk[<define-make-placeholder>
        (: node/make-placeholder (→ param-type … node/placeholder-type))
        (define (node/make-placeholder param …)
-         (list 'node/placeholder-tag param …))]
+         ((inst node/placeholder-struct (List param-type …)) (list param …)))]
 
 @subsection{Making with-indices nodes}
 
@@ -369,9 +369,11 @@ that node's @tc[with-promises] type.
 @; TODO: use a type-expander here, instead of a template metafunction.
 
 @CHUNK[<define-with-promises>
+       (struct (A) node/with-promises-struct ([f : A]))
        (define-type node/with-promises-type
-         (tagged node/with-promises-tag
+         (node/with-promises-struct (List [field : <field/with-promises-type>] …))
-                 [field : <field/with-promises-type>] …))
+         #;(tagged node/with-promises-tag
+                 ))
        
        (: node/make-with-promises (→ <field/with-promises-type> …
                                      node/with-promises-type))
@@ -419,8 +421,7 @@ library. We replace all occurrences of a @tc[node] name with its
 @chunk[<placeholder→with-indices-clause>
        [node/placeholder-type
         (List 'node/with-indices-tag2 Index)
-        (λ (x) (and (pair? x)
+        (struct-predicate node/placeholder-struct)
-                    (eq? (car x) 'node/placeholder-tag)))
         <placeholder→with-indices-function>]]
 
 @subsubsection{Processing the placeholders}
@@ -432,13 +433,15 @@ library. We replace all occurrences of a @tc[node] name with its
 
 @; TODO: we don't need that many let etc., use % instead once everything works.
 @CHUNK[<fold-queue-body>
-       (let ([mapping-result (apply node/mapping-function (cdr e))])
+       (let ([mapping-result
-         (let ([f (tmpl-fold-instance (List <field-incomplete-type> …)
+              (apply node/mapping-function
+                     ((struct-accessor node/placeholder-struct 0) e))]
+             [f (tmpl-fold-instance (List <field-incomplete-type> …)
                                     Δ-Queues
                                     <placeholder→with-indices-clause> …)])
          (let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)])
            (values (apply node/make-with-indices r)
-                     new-Δ-queues))))]
+                   new-Δ-queues)))]
 
 Where @tc[<field-incomplete-type>] is the @tc[field-type] in which node types
 are replaced by placeholder types:
@@ -589,14 +592,6 @@ We will be able to use this type expander in function types, for example:
           (template
            ;(let ()
            (begin
-             (begin <define-placeholder-type>) …
-             (begin <define-make-placeholder>) …
-             (begin <define-with-indices>) …
-             (begin <define-with-promises>) …
-             (begin <define-incomplete>) …
-             
-             (begin <define-mapping-function>) …
-             
              (define-multi-id name
                #:type-expander <graph-type-expander>
                #:call (λ (stx)
@@ -622,6 +617,14 @@ We will be able to use this type expander in function types, for example:
                    extra-definition
                    …))
              
+             (begin <define-placeholder-type>) …
+             (begin <define-make-placeholder>) …
+             (begin <define-with-indices>) …
+             (begin <define-with-promises>) …
+             (begin <define-incomplete>) …
+             
+             (begin <define-mapping-function>) …
+             
              (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type
                              (List (Vectorof node/with-indices-type) …))
                           …))
@@ -651,7 +654,8 @@ We will be able to use this type expander in function types, for example:
                               racket/sequence
                               racket/pretty
                               "rewrite-type.lp2.rkt"
-                              "../lib/low-untyped.rkt")
+                              "../lib/low-untyped.rkt"
+                              "meta-struct.rkt")
                   racket/splicing
                   "fold-queues.lp2.rkt"
                   "rewrite-type.lp2.rkt"
@@ -659,7 +663,8 @@ We will be able to use this type expander in function types, for example:
                   "structure.lp2.rkt"
                   "variant.lp2.rkt"
                   "../type-expander/type-expander.lp2.rkt"
-                  "../type-expander/multi-id.lp2.rkt")
+                  "../type-expander/multi-id.lp2.rkt"
+                  "meta-struct.rkt")
          
          ;(begin-for-syntax
          ;<multiassoc-syntax>)

graph-lib/graph/meta-struct.rkt

@@ -0,0 +1,131 @@
+#lang racket
+
+(require syntax/parse/experimental/template
+         syntax/parse
+         (for-syntax racket/syntax))
+
+(provide meta-struct?
+         (struct-out meta-struct-info)
+         get-meta-struct-info
+         ;; More provided by `shorthand` in the code below
+         meta-struct-subtype?
+         struct-predicate
+         struct-constructor
+         struct-accessor)
+
+(module info racket
+  (require racket/struct-info)
+  
+  (provide meta-struct?
+           (struct-out meta-struct-info)
+           get-meta-struct-info)
+  
+  (define (meta-struct? s)
+    (and (identifier? s)
+         (let ([v (syntax-local-value s (λ _ #f))])
+           (and v (struct-info? v)))))
+  
+  (struct meta-struct-info
+    (type-descriptor
+     constructor
+     predicate
+     accessors
+     mutators
+     super-type)
+    #:transparent)
+  
+  (define (get-meta-struct-info s #:srcloc [srcloc #f])
+    (if (meta-struct? s)
+        (apply meta-struct-info (extract-struct-info (syntax-local-value s)))
+        (raise-syntax-error 'get-struct-info
+                            "not a structure definition"
+                            (or srcloc s)
+                            s))))
+
+(require 'info
+         (for-syntax 'info))
+
+(define-syntax (shorthand stx)
+  (syntax-case stx ()
+    [(_ base)
+     (with-syntax ([name (format-id #'base "meta-struct-~a" #'base)]
+                   [accessor (format-id #'base "meta-struct-info-~a" #'base)]
+                   [tmpl (format-id #'base "tmpl-struct-~a" #'base)])
+       #'(begin
+           (provide name tmpl)
+           (define-template-metafunction (tmpl stx)
+             (syntax-parse stx
+               [(_ s (~optional (~seq #:srcloc srcloc)))
+                (accessor
+                 (get-meta-struct-info #'s #:srcloc (attribute srcloc)))]))
+           (define (name s #:srcloc [srcloc #f])
+             (accessor
+              (get-meta-struct-info s #:srcloc srcloc)))))]))
+
+(shorthand type-descriptor)
+(shorthand constructor)
+(shorthand predicate)
+(shorthand accessors)
+(shorthand mutators)
+(shorthand super-type)
+
+(define-syntax (struct-predicate stx)
+  (syntax-case stx ()
+    [(_ s) (meta-struct-info-predicate (get-meta-struct-info #'s))]))
+(define-syntax (struct-constructor stx)
+  (syntax-case stx ()
+    [(_ s) (meta-struct-info-constructor (get-meta-struct-info #'s))]))
+(define-syntax (struct-accessor stx)
+  (syntax-case stx ()
+    [(_ s i) (list-ref (meta-struct-info-accessors (get-meta-struct-info #'s))
+                       (syntax-e #'i))]))
+
+(define (meta-struct-subtype? sub super)
+  (or (equal? (meta-struct-type-descriptor sub)
+              (meta-struct-type-descriptor super))
+      (let ((up (meta-struct-super-type sub)))
+        (and (meta-struct? up)
+             (meta-struct-subtype? up super)))))
+
+(module* test racket
+  (require (for-syntax (submod ".."))
+           rackunit)
+  
+  (define-syntax (test-subtype? stx)
+    (syntax-case stx ()
+      [(_ sub super)
+       #`#,(if (meta-struct-subtype? #'sub #'super)
+               #t
+               #f)]))
+  
+  (module m1 racket
+    (struct sa ())
+    (provide (struct-out sa)))
+  (module m2 racket
+    (require (submod ".." m1))
+    (struct sb sa ())
+    (provide (rename-out [sa sa2]))
+    (provide (struct-out sb)))
+  (require 'm1)
+  (require 'm2)
+  (struct sc sb ())
+  
+  (check-true (test-subtype? sa sa))
+  (check-true (test-subtype? sa2 sa))
+  (check-true (test-subtype? sb sa))
+  (check-true (test-subtype? sc sa))
+  
+  (check-true (test-subtype? sa sa2))
+  (check-true (test-subtype? sa2 sa2))
+  (check-true (test-subtype? sb sa2))
+  (check-true (test-subtype? sc sa2))
+  
+  (check-false (test-subtype? sa sb))
+  (check-false (test-subtype? sa2 sb))
+  (check-true (test-subtype? sb sb))
+  (check-true (test-subtype? sc sb))
+  
+  (check-false (test-subtype? sa sc))
+  (check-false (test-subtype? sa2 sc))
+  (check-false (test-subtype? sb sc))
+  (check-true (test-subtype? sc sc)))

graph-lib/graph/remember.rkt

@@ -87,3 +87,10 @@
 (structure ab v)
 (structure a c)
 (structure a c)
+(structure a1 s v)
+(structure a1 s v)
+(structure a1 s v)
+(structure returned)
+(structure returned)
+(structure returned)
+(structure returned)

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

@@ -87,7 +87,7 @@ calls itself on the components of the type.
        (define-for-syntax (replace-in-type t r)
          (define (recursive-replace new-t) (replace-in-type new-t r))
          (define/with-syntax ([from to] ...) r)
-         (syntax-parse t
+         (syntax-parse (expand-type t)
            <replace-in-type-substitute>
            <replace-in-type-other-cases>))]
 
@@ -206,7 +206,8 @@ The other cases are similarly defined:
            [((~literal U) a ...)
             #`(let ([v-cache val])
                 (cond
-                  #,@(stx-map (λ (ta) (replace-in-union #'v-cache ta r))
+                  #,@(stx-map (λ (ta)
+                                (replace-in-union #'v-cache ta r))
                               #'(a ...))))]
            [((~literal quote) a)
             #'val]
@@ -221,9 +222,17 @@ TODO: we currently don't check that each @tc[tag] is distinct.
        (define (replace-in-union stx-v-cache t r)
          (define/with-syntax v-cache stx-v-cache)
          (syntax-parse t
-           [(List ((~literal quote) tag:id) b ...)
+           [((~literal List) ((~literal quote) tag:id) b ...)
             <replace-in-tagged-union-instance>]
-           [_ (error "Type-replace on untagged Unions isn't supported yet!")]))]
+           [_ (raise-syntax-error
+               'replace-in-type
+               (format "Type-replace on untagged Unions isn't supported yet: ~a"
+                       t)
+               t)]
+           [s:id
+            #:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
+                          (meta-struct? #'s))
+            (error "Type-replace on struct unions: WIP.")]))]
 
 For cases of the union which are a tagged list, we use a simple guard, and call
 @tc[recursive-replace] on the whole @tc[(List 'tag b ...)] type.
@@ -481,11 +490,13 @@ functions is undefined.
                           (cdr f))))]
            [((~literal U) a ...)
             (define/with-syntax (new-a-type …) (stx-map new-type-for #'(a …)))
+            (printf "<replace-fold-union>: ~a\n" type)
             #`(λ ([val : (U a ...)] [acc : acc-type])
                 : (values (U new-a-type …) acc-type)
                 (cond
-                  #,@(stx-map (λ (ta) <replace-fold-union>)
+                  #,@(for/list ([ta (in-syntax #'(a ...))]
-                              #'(a ...))
+                                [last? (in-last? (in-syntax #'(a ...)))])
+                       <replace-fold-union>)
                   [else
                    (typecheck-fail #,type
                                    #,(~a "Unhandled union case in "
@@ -501,16 +512,28 @@ functions is undefined.
 
 @CHUNK[<replace-fold-union>
        (syntax-parse ta
-         [(List ((~literal quote) tag:id) b ...)
+         [((~literal List) ((~literal quote) tag:id) b ...)
           <replace-fold-union-tagged-list>]
-         [(Pairof ((~literal quote) tag:id) b)
+         [((~literal Pairof) ((~literal quote) tag:id) b)
           <replace-fold-union-tagged-list>]
          [x:id
           #:attr assoc-result (stx-assoc #'x #'((from to pred? fun) ...))
           #:when (attribute assoc-result)
           #:with (x-from x-to x-pred? x-fun) #'assoc-result
           <replace-fold-union-predicate>]
-         [_ (error "Type-replace on untagged Unions isn't supported yet!")])]
+         [_
+          #:when last?
+          #`[#t ;; Hope type occurrence will manage here.
+             (#,(recursive-replace ta) val acc)]]
+         [s:id
+          #:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
+                        (meta-struct? #'s))
+          (error "Type-replace on struct unions: WIP.")]
+         [_ (raise-syntax-error
+             'replace-in-type
+             (format "Type-replace on untagged Unions isn't supported yet: ~a"
+                     ta)
+             ta)])]
 
 For cases of the union which are a tagged list, we use a simple guard, and call
 @tc[recursive-replace] on the whole @tc[(List 'tag b ...)] type.
@@ -589,12 +612,17 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
 @chunk[<*>
        (begin
          (module main typed/racket
-           (require (for-syntax syntax/parse
+           (require
+             (for-syntax syntax/parse
                          racket/syntax
                          syntax/stx
                          racket/format
                          syntax/parse/experimental/template
-                                "../lib/low-untyped.rkt")
+                         racket/sequence
+                         "../lib/low-untyped.rkt"
+                         (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"

graph-lib/graph/structure.lp2.rkt

@@ -414,10 +414,10 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
              (structure-get v field)))]
 
 @chunk[<get-predicate>
-       (my-st-type-info-predicate (get-struct-info stx (cdr s)))]
+       (meta-struct-predicate (cdr s) #:srcloc stx)]
 
 @CHUNK[<get-field-accessor>
-       (list-ref (my-st-type-info-accessors (get-struct-info stx (cdr s)))
+       (list-ref (meta-struct-accessors (cdr s) #:srcloc stx)
                  (indexof (syntax->datum #'field) (reverse (car s))))]
 
 @chunk[<test-get-field>
@@ -485,30 +485,6 @@ instead of needing an extra recompilation.
 
 @subsection{Anonymous type}
 
-@subsection{Accessing information about racket's structs at compile-time}
-@chunk[<my-st-type-info>
-       (begin-for-syntax
-         (struct my-st-type-info
-           (type-descriptor
-            constructor
-            predicate
-            accessors
-            mutators
-            super-type)
-           #:transparent))]
-
-@CHUNK[<struct-info>
-       (define-for-syntax (get-struct-info stx s)
-         (let* ([fail (λ () (raise-syntax-error 'get-struct-info
-                                                "not a structure definition"
-                                                stx
-                                                s))]
-                [v (if (identifier? s)
-                       (syntax-local-value s fail)
-                       (fail))]
-                [i (if (not (struct-info? v)) (fail) (extract-struct-info v))])
-           (apply my-st-type-info i)))]
-
 @subsection{Type-expander}
 
 @CHUNK[<type-expander>
@@ -620,7 +596,8 @@ chances that we could write a definition for that identifier.
                                 ;; in-syntax on older versions:
                                 ;;;unstable/sequence
                                 "../lib/low-untyped.rkt"
-                                "../lib/low/multiassoc-syntax.rkt")
+                                "../lib/low/multiassoc-syntax.rkt"
+                                "meta-struct.rkt")
                     "../lib/low.rkt"
                     "../type-expander/type-expander.lp2.rkt"
                     "../type-expander/multi-id.lp2.rkt")
@@ -647,8 +624,6 @@ chances that we could write a definition for that identifier.
            <make-structure-constructor>
            <delayed-error-please-recompile>
            
-           <my-st-type-info>
-           <struct-info>
            <fields→supertypes>
            <get-field>
            

graph-lib/lib/low.rkt

@@ -324,7 +324,9 @@
          replace-first
          Syntax-Listof
          check-duplicate-identifiers
-         generate-temporary)
+         generate-temporary
+         sequence-length>=
+         in-last?)
 
 (require (only-in racket
                   [compose ∘]
@@ -601,6 +603,24 @@
   ; (ann '() (Listof (Syntaxof Nothing)))
   (my-in-syntax #'()))
 
+(: sequence-length>= (→ (Sequenceof Any) Index Boolean))
+(define (sequence-length>= s l)
+  (let-values ([(more? next) (sequence-generate s)])
+    (define (rec [remaining : Index]) : Boolean
+      (if (= remaining 0)
+          #t
+          (and (more?)
+               (begin (next)
+                      (rec (sub1 remaining))))))
+    (rec l)))
+
+(: in-last? (→ (Sequenceof Any) (Sequenceof (U #f 'last))))
+(define (in-last? s)
+  (if (sequence-length>= s 1)
+      (sequence-append (sequence-map (λ _ #f) (sequence-tail s 1))
+                       (in-value 'last))
+      empty-sequence))
+
 
 (: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol)))
                                   Boolean))