WIP.

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

@@ -106,8 +106,8 @@ plain list.
          (template
           (debug
            (begin
-             <first-pass-type-expander>
              (define-graph first-step
+               #:definitions [<first-pass-type-expander>]
                [node [field c field-type] …
                 [(node/simple-mapping [field c field-type] …);<first-pass-field-type>] …)
                  (node field …)]] …
@@ -124,8 +124,14 @@ encapsulating the result types of mappings.
 
 @chunk[<first-pass-type-expander>
        (define-type-expander (~> stx)
-         (syntax-case stx ()
+         (syntax-parse stx
-           [(_ mapping) #'(U mapping/node result-type)] …))]
+           [(_ (~literal mapping))
+            (template
+             (U (first-step #:placeholder mapping/node)
+                (tmpl-replace-in-type result-type
+                                      [node (first-step #:placeholder node)]
+                                      …)))]
+           …))]
 
 @; TODO: replace-in-type doesn't work well here, we need to define a
 @; type-expander.
@@ -142,7 +148,9 @@ encapsulating the result types of mappings.
                               racket/syntax
                               syntax/stx
                               "../lib/low-untyped.rkt"
-                              "../lib/low/multiassoc-syntax.rkt")
+                              "../lib/low/multiassoc-syntax.rkt"
+                              "rewrite-type.lp2.rkt"; debug
+                              )
                   "../lib/low.rkt"
                   "graph.lp2.rkt"
                   "get.lp2.rkt"
@@ -168,16 +176,40 @@ encapsulating the result types of mappings.
          
          
          
-         (begin
+         #|(begin
-           (define-type-expander (~> stx)
+           (define-graph
+             first-step
+             #:definitions [
+ #;(define-type-expander (~> stx)
    (displayln stx)
    (displayln #'m-streets)
    (syntax-parse stx
      ((_ (~datum m-cities)) #'(U m-cities3/node (Listof City)))
      ((_ (~datum m-streets)) #'(U (first-step #:placeholder m-streets4/node)
                                   (Listof (first-step #:placeholder Street))))))
-           (define-graph
+
-             first-step
+
+ 
+
+ (define-type-expander
+      (~> stx)
+      (syntax-parse stx
+        ((_ (~literal m-cities))
+         (template (U
+            (first-step #:placeholder m-cities3/node)
+            (tmpl-replace-in-type
+             (Listof City)
+             (City (first-step #:placeholder City))
+             (Street (first-step #:placeholder Street))))))
+        ((_ (~literal m-streets))
+         (template (U
+            (first-step #:placeholder m-streets4/node)
+            (tmpl-replace-in-type
+             (Listof Street)
+             (City (first-step #:placeholder City))
+             (Street (first-step #:placeholder Street))))))))
+
+ ]
              (City
               (streets : (U m-streets4/node (Listof Street)))
               ((City1/simple-mapping (streets : (~> m-streets)
@@ -195,6 +227,58 @@ encapsulating the result types of mappings.
                   (define (strings→city (s : (Listof String)))
                     (City (m-streets s)))
                   (map strings→city cnames)))))
+             (m-streets4/node
+              (returned : (Listof Street))
+              ((m-streets (snames : (Listof String)))
+               (m-streets4/node
+                (let ((City City1/simple-mapping) (Street Street2/simple-mapping))
+                  (map Street snames)))))))|#
+
+(begin
+   (define-graph
+    first-step
+    #:definitions
+    ((define-type-expander
+      (~> stx)
+      (syntax-parse stx
+        ((_ (~literal m-cities))
+         (template (U
+            (first-step #:placeholder m-cities3/node)
+            (tmpl-replace-in-type
+             (Listof City)
+             (City (first-step #:placeholder City))
+             (Street (first-step #:placeholder Street))))))
+        ((_ (~literal m-streets))
+         (template (U
+            (first-step #:placeholder m-streets4/node)
+            (tmpl-replace-in-type
+             (Listof Street)
+             (City (first-step #:placeholder City))
+             (Street (first-step #:placeholder Street)))))))))
+     #|
+     (City [foo : Number] ((m1) (City 1)))
+     (Street [foo : Number] ((m2) (Street 2)))
+     (m-cities3/node [foo : Number] ((m3) (m-cities3/node 3)))
+     (m-streets4/node [foo : Number] ((m4) (m-streets4/node 4)))
+     |#
+
+     ;; TODO: have a let-expander.
+    (City
+     (streets : (U m-streets4/node (Listof Street)))
+     ((City1/simple-mapping (streets : #|(~> m-streets)|#
+                                     (U (first-step #:placeholder m-streets4/node)
+                                        (Listof (first-step #:placeholder Street)))
+                                     )) (City streets)))
+    (Street
+     (sname : String)
+     ((Street2/simple-mapping (sname : String)) (Street sname)))
+    (m-cities3/node
+     (returned : (Listof City))
+     ((m-cities (cnames : (Listof (Listof String))))
+      (m-cities3/node
+       (let ((City City1/simple-mapping) (Street Street2/simple-mapping))
+         (define (strings→city (s : (Listof String))) (City (m-streets s))) ;;
+         (map strings→city cnames)))))
     (m-streets4/node
      (returned : (Listof Street))
      ((m-streets (snames : (Listof String)))
@@ -249,7 +333,8 @@ encapsulating the result types of mappings.
          (require (submod "..")
                   typed/rackunit)
          
-         #;<test-graph-rich-return>)]
+         ;<test-graph-rich-return>
+         )]
 
 @chunk[<*>
        (begin

graph-lib/graph/graph.lp2.rkt

@@ -208,12 +208,14 @@ 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/make-placeholder-type" (node …))
        (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/make-incomplete-type" (node …))
        (define-temp-ids "~a/incomplete-tag" (node …))
        
        (define-temp-ids "~a/with-indices-type" (node …))
@@ -228,6 +230,7 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/with-promises-tag" (node …))
        
        (define-temp-ids "~a/mapping-function" (node …))
+       (define-temp-ids "~a/mapping-function-type" (node …))
        
        (define-temp-ids "~a/database" (node …) #:first-base root)
        
@@ -330,10 +333,13 @@ arguments, tagged with the @tc[node]'s name):
 
 Then we define the @tc[node/make-placeholder] function:
 
+@chunk[<define-make-placeholder-type>
+       (define-type node/make-placeholder-type
+         (→ param-type … node/placeholder-type))]
 @chunk[<define-make-placeholder>
-       (: node/make-placeholder (→ param-type … node/placeholder-type))
+       (: node/make-placeholder node/make-placeholder-type)
        (define (node/make-placeholder param …)
-         ((inst node/placeholder-struct (List param-type …)) (list param …)))]
+         (node/placeholder-struct (list param …)))]
 
 @subsection{Making with-indices nodes}
 
@@ -392,16 +398,18 @@ library. We replace all occurrences of a @tc[node] name with its
 
 @; TODO: use a type-expander here, instead of a template metafunction.
 
-@CHUNK[<define-incomplete>
+@chunk[<define-incomplete-type>
        (define-type node/incomplete-type
          (List 'node/incomplete-tag <field/incomplete-type> …))
        
-       (: node/make-incomplete (→ <field/incomplete-type> …
+       (define-type node/make-incomplete-type
-                                  node/incomplete-type))
+         (→ <field/incomplete-type> … node/incomplete-type))]
+@chunk[<define-incomplete>
+       (: node/make-incomplete node/make-incomplete-type)
        (define (node/make-incomplete field …)
          (list 'node/incomplete-tag field …))]
 
-@CHUNK[<field/incomplete-type>
+@chunk[<field/incomplete-type>
        (tmpl-replace-in-type field-type
                              [node node/placeholder-type] …)]
 
@@ -454,14 +462,14 @@ 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))
+       (: node/mapping-function node/mapping-function-type)
        (define node/mapping-function
-         (let ([mapping node/make-placeholder]
+         (ann (λ (param …) . mapping-body)
-               …
+              node/mapping-function-type))]
-               [node node/make-incomplete]
+
-               …)
+@chunk[<define-mapping-function-type>
-           (λ ([param : param-type] …) : node/incomplete-type
+       (define-type node/mapping-function-type
-             . mapping-body)))]
+         (→ param-type … node/incomplete-type))]
 
 @subsection{Returning a with-promises nodes}
 
@@ -607,20 +615,20 @@ We will be able to use this type expander in function types, for example:
                            (syntax/loc stx (root/constructor . rest))]))
                #:id (λ (stx) #'root/constructor))
 
-             (?? (splicing-let ([mapping node/make-placeholder]
+             (begin <define-make-placeholder>) …
-                                …
+             (begin <define-incomplete>) …
-                                [node node/make-incomplete]
+             (splicing-let ([mapping node/make-placeholder] …
-                                …)
+                            [node node/make-incomplete] …)
-                   extra-definition
+               (?? (begin extra-definition …))
-                   …))
+               (begin <define-mapping-function>) …)
 
              (begin <define-placeholder-type>) …
-             (begin <define-make-placeholder>) …
+             (begin <define-make-placeholder-type>) …
              (begin <define-with-indices>) …
              (begin <define-with-promises>) …
-             (begin <define-incomplete>) …
+             (begin <define-incomplete-type>) …
              
-             (begin <define-mapping-function>) …
+             (begin <define-mapping-function-type>) …
              
              (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type
                              (List (Vectorof node/with-indices-type) …))

graph-lib/graph/remember.rkt

@@ -94,3 +94,9 @@
 (structure returned)
 (structure returned)
 (structure returned)
+(structure foo)
+(structure foo)
+(structure foo)
+(structure foo)
+(structure foo)
+(structure foo)

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

@@ -584,9 +584,14 @@ one for @tc[replace-in-type]:
 @CHUNK[<template-metafunctions>
        (define-template-metafunction (tmpl-replace-in-type stx)
          (syntax-parse stx
-           [(_ type:expr [from to] …)
+           [(_ (~optional (~and debug? #:debug)) type:expr [from to] …)
-            #`#,(replace-in-type #'type
+            (when (attribute debug?)
-                                 #'([from to] …))]))]
+              (displayln (format "~a" stx)))
+            (let ([res #`#,(replace-in-type #'type
+                                            #'([from to] …))])
+              (when (attribute debug?)
+                (displayln (format "=> ~a" res)))
+              res)]))]
 
 And one each for @tc[fold-instance] and @tc[replace-in-instance2]: