From 7a643178be89778f4c122153fafb63f8895f264c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Sat, 12 Mar 2016 15:11:51 +0100
Subject: [PATCH] Closes FB case 125 Use define-private-tagged in graph.lp2.rkt
 for with-promises etc. nodes (the ones that shouldn't be seeable outside)

---
 graph-lib/graph/graph.lp2.rkt   | 36 ++++++++++++---------------------
 graph-lib/graph/remember.rkt    |  4 ++++
 graph-lib/graph/variant.lp2.rkt |  8 +++++---
 3 files changed, 22 insertions(+), 26 deletions(-)

diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt
index 6bfe9269..efd6e6f5 100644
--- a/graph-lib/graph/graph.lp2.rkt
+++ b/graph-lib/graph/graph.lp2.rkt
@@ -215,7 +215,7 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/incomplete-tag" (node …))
        (define-temp-ids "~a/incomplete-type" ((field …) …))
        
-       (define-temp-ids "~a/with-promises-type" (node …) #:first-base root)
+       (define-temp-ids "~a/with-promises" (node …) #:first-base root)
        
        (define-temp-ids "~a/index-type" (node …))]
 
@@ -235,8 +235,8 @@ We derive identifiers for these based on the @tc[node] name:
        (node/incomplete-tag …)
        ((field/incomplete-type …) …)
        
-       (node/with-promises-type …)
-       root/with-promises-type
+       (node/with-promises …)
+       root/with-promises
        
        (node/index-type …)]
 
@@ -253,9 +253,6 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/with-indices→with-promises" (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/mapping-function-type" (node …))
        
@@ -298,6 +295,7 @@ The graph name will be used in several ways:
                     …
                     [(_ #:? (~datum node))
                      (syntax/loc stx node?)]
+                    …
                     [(_ . rest)
                      (syntax/loc stx (root/constructor . rest))]))
          #:id (λ (stx) #'root/constructor))]
@@ -409,7 +407,7 @@ node.
 
 @chunk[<constructors>
        (begin
-         (: node/constructor (→ param-type … (Promise node/with-promises-type)))
+         (: node/constructor (→ param-type … (Promise node/with-promises)))
          (define (node/constructor param …)
            (match-let ([(list node/database …)
                         (fq 'node/placeholder-queue
@@ -553,20 +551,12 @@ 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]
-                 …))]
+       (define-private-tagged node/with-promises
+         [field : <field/with-promises-type>] …)]
 
 @CHUNK[<field/with-promises-type>
        (tmpl-replace-in-type field-type
-                             [node (Promise node/with-promises-type)] …)]
+                             [node (Promise node/with-promises)] …)]
 
 @subsection{Making incomplete nodes}
 
@@ -694,10 +684,10 @@ because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it
 
 @chunk[<index→promise-clause>
        [node/index-type
-        (Promise node/with-promises-type)
+        (Promise node/with-promises)
         (struct-predicate node/index-type)
         (λ ([tagged-index : node/index-type] [acc : Void])
-          : (values (Promise node/with-promises-type) Void)
+          : (values (Promise node/with-promises) Void)
           (values <index→promise> acc))]]
 
 TODO: check what we are closing over in that promise.
@@ -713,12 +703,12 @@ closes over.
 
 @chunk[<define-with-indices→with-promises>
        (: node/with-indices→with-promises (→ node/with-indices-type
-                                             node/with-promises-type))
+                                             node/with-promises))
        (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)))))]
+         (apply node/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, as defined earlier.
@@ -735,7 +725,7 @@ via @tc[(g Street)].
 @chunk[<graph-type-expander>
        (λ (stx)
          (syntax-parse stx
-           [(_ (~datum node)) #'node/with-promises-type] …
+           [(_ (~datum node)) #'node/with-promises] …
            [(_ #:incomplete (~datum node)) #'node/incomplete-type] …
            [(_ #:make-incomplete (~datum node))
             #'(→ field/incomplete-type … node/incomplete-type)] …
diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt
index 6236b79c..dd8d962f 100644
--- a/graph-lib/graph/remember.rkt
+++ b/graph-lib/graph/remember.rkt
@@ -147,3 +147,7 @@
 (variant . dl1)
 (structure x y)
 (variant . txyz)
+(variant . City89/with-promises-tag)
+(variant . Street90/with-promises-tag)
+(variant . House91/with-promises-tag)
+(variant . Person92/with-promises-tag)
diff --git a/graph-lib/graph/variant.lp2.rkt b/graph-lib/graph/variant.lp2.rkt
index be2919c3..b942b6e1 100644
--- a/graph-lib/graph/variant.lp2.rkt
+++ b/graph-lib/graph/variant.lp2.rkt
@@ -444,9 +444,11 @@ the uninterned @tc[tag] either).
 @; tags.
 
 @chunk[<define-uninterned-tagged>
-       (define-syntax/parse (define-private-tagged tag:id
-                              (~maybe #:? tag?)
-                              . (~and structure-type ([field type] …)))
+       (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 …))