WIP on FB case 133 Allow returning both promises for and the actual type in the first pass of rich-returns

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

@@ -116,6 +116,7 @@ plain list.
          (define-temp-ids "~a/extract/mapping" (node …))
          (define-temp-ids "~a/extract" (node …) #:first-base root)
          (define-temp-ids "~a/node-marker" (mapping …))
+         (define-temp-ids "~a/node-marker2" (mapping …))
          (define-temp-ids "~a/from-first-pass" (node …))
          ;(define step2-introducer (make-syntax-introducer))
          ;(define/with-syntax id-~> (datum->syntax #'name '~>))
@@ -208,7 +209,8 @@ produced by the first step.
        ;; globally like this.
        (define-type node (name/first-step node))
        …
-       (define-type mapping/node-marker result-type)
+       (define-type mapping/node-marker (U result-type
+                                           (name/first-step node)))
        …
        ;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        (define-type-expander (second-step-marker-expander stx)
@@ -254,69 +256,6 @@ identifier, so that it can be matched against by
 @tc[tmpl-replace-in-instance] and
 @tc[tmpl-replace-in-type].
 
-@CHUNK[<inline-temp-nodes>
-       (define (inline-temp-nodes/type t seen)
-         (printf ">>> type ~a\n" (syntax->datum #'t))
-         (let ((rslt
-                (quasitemplate
-                 (tmpl-replace-in-type (Let (id-~> second-step-marker-expander) #,t)
-                   [mapping/node-marker
-                    (meta-eval
-                     (if (free-id-set-member? #,t #,seen)
-                         (raise-syntax-error 'define-graph/rich-returns
-                                             (~a "Cycles in types are not allowed."
-                                                 " The following types were already"
-                                                 " inlined: " seen ", and " t
-                                                 " appeared a second time.")
-                                             t)
-                         (#,inline-temp-nodes/type result-type
-                                                   #,(free-id-set-add t seen))))]
-                   …))
-                ))
-           (printf "<<< type ~a\n" (syntax->datum #'t))
-           rslt))
-       
-       (define (inline-temp-nodes/instance t seen)
-         (printf ">>> inst ~a\n" (syntax->datum t))
-         (define/with-syntax (inlined-result-type …)
-           (stx-map (λ (result-type)
-                      (inline-temp-nodes/type result-type
-                                              (free-id-set-add seen t)))
-                    #'(result-type …)))
-         
-         (define (replacement result-type mapping/node)
-           #`[mapping/node-marker
-              (inline-temp-nodes/type result-type
-                                      (free-id-set-add #,seen #,t))
-              (first-pass #:? mapping/node)
-              (if (free-id-set-member? t seen)
-                  (raise-syntax-error 'define-graph/rich-returns
-                                      (~a "Cycles in types are not allowed."
-                                          " The following types were already"
-                                          " inlined: " #,seen ", and " #,t
-                                          " appeared a second time.")
-                                      t)
-                  (inline-temp-nodes/instance result-type
-                                              (free-id-set-add seen t)))]
-           …
-           (let ((rslt
-                  (replace-in-type #'(Let (id-~> second-step-marker-expander) #,t)
-                                   (stx-map replacement
-                                            #'([result-type mapping/node] …))
-                                   #;[node* ;; generated by the first pass
-                                      (name #:placeholder node*) ; new type
-                                      (first-pass #:? node*)
-                                      node*] ;; call constructor
-                                   #;…))
-                 ))
-           (printf "<<< inst ~a\n" (syntax->datum t))
-           rslt))
-       
-       (define-template-metafunction (!inline-temp-nodes/instance stx)
-         (syntax-case stx ()
-           [(_ t)
-            (inline-temp-nodes/instance #'t (immutable-free-id-set))]))]
-
 ----------------------
 
 
@@ -324,10 +263,8 @@ identifier, so that it can be matched against by
 
 
 @CHUNK[<step2>
-       ;       #,(step2-introducer
-       ;          (quasitemplate
        #,(quasitemplate/debug name
-           (define-graph name;#,(step2-introducer #'name)
+           (define-graph name
              #:definitions [<second-step-~>-expander>
                             <second-step-marker-expander>
                             <inline-type>
@@ -341,9 +278,11 @@ We create the inlined-node by inlining the temporary nodes
 in all of its fields:
 
 @chunk[<inlined-node>
-       (node ((inline-instance field-type ()) (get from field))
+       ;; inline from the field-type of the old node.
+       (node ((inline-instance field-type ()) (get from field));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              …)]
 
+@subsection{Inlining instances}
 To inline the temporary nodes in the instance, we use 
 @tc[replace-in-instance], and call the inline-instance
 recursively:
@@ -359,17 +298,6 @@ recursively:
                                   #'(<inline-instance-replacement>
                                      <inline-instance-nodes>))])))]
 
-@chunk[<inline-type>
-       (define-type-expander (inline-type stx)
-         (dbg
-          ("inline-type" stx)
-          (syntax-parse stx
-            [(_ i-t (~and seen (:id (… …))))
-             <inline-check-seen>
-             (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
-                              #'(<inline-type-replacement>
-                                 <inline-type-nodes>))])))]
-
 @chunk[<inline-instance-replacement>
        [mapping/node-marker                                   ;; from
         (inline-type result-type (mapping/node . seen))       ;; to
@@ -384,6 +312,128 @@ recursively:
         node/extract/mapping]    ;; call mapping
        …]
 
+@subsection{Inlining types}
+
+The input type for the inlining of field @tc[streets] of the node @tc[City] is:
+
+@chunk[<example-inline-input>
+       (U m-street (Listof Street))]
+
+Where @tc[m-street] is the @emph{with-promises} node type
+of @tc[name/first-step], and @tc[Street] is the
+@emph{with-promises} node type of @tc[name/first-step].
+
+More generally, @tc[(~> some-mapping)] in the first pass is expanded to:
+
+@chunk[<example-inline-input-2>
+       (U (first-pass some-mapping)
+          (tmpl-replace-in-type result-type
+            [mapping/node (first-pass mapping/node)]
+            [node (first-pass node)]))]
+
+When inlining, we want to first inline the 
+@tc[some-mapping] node, if it is present, and in all cases
+drill down the result-type in both cases (either we just
+inlined it, or it was already there). It would be nice to
+avoid duplicating the code for inlining inside the
+result-type, as the code would grow exponentially with the
+number of mappings encountered along the path otherwise.
+
+We would need to call the replace-in-instance a second time
+on the result. The generated code would have a shape like this:
+
+@chunk[<example-generated-inline>
+       (λ ([v : (V (first-pass some-mapping)
+                   (tmpl-replace-in-type result-type
+                     [mapping/node (first-pass mapping/node)]
+                     [node (first-pass node)]))])
+         ((λ ([v : (tmpl-replace-in-type result-type
+                     [mapping/node (first-pass mapping/node)]
+                     [node (first-pass node)])])
+            …)
+          (if ((first-pass #:? some-mapping) v)
+              <inline-v>
+              v)))]
+
+This would require some specific support from rewrite-type.
+
+We could have a node with the following type:
+
+@chunk[|<example (V (~> 1) (~> 2) …)>|
+       (define-graph/rich-return grr
+         ([Node [field : (V (~> m-1) (~> m-2) #:or (~> m-3))]]))]
+
+where @tc[m-1], @tc[m-2] and @tc[m-3] have different return
+types, but @tc[m-1] and @tc[m-2] are constructors or tagged
+structures. If we expand this a bit, we see the following type:
+
+@chunk[|<example (V (~> 1) (~> 2) …) expanded>|
+       (V (V (first-pass m-1)
+             some-constructor-1)
+          (V (first-pass m-2)
+             some-constructor-2)
+          #:or (U (first-pass m-3)
+                  some-abritrary-type-3))]
+
+Which is equivalent to:
+
+@chunk[|<example (V (~> 1) (~> 2) …) merged>|
+       (V (first-pass m-1)
+          some-constructor-1
+          (first-pass m-2)
+          some-constructor-2
+          (first-pass m-3)
+          #:or some-abritrary-type-3)]
+
+The generated code would be:
+
+@chunk[|<example (V (~> 1) (~> 2) …) generated >|
+       (λ ([v : (V (first-pass m-1)
+                   some-constructor-1
+                   (first-pass m-2)
+                   some-constructor-2
+                   (first-pass m-3)
+                   #:or some-abritrary-type-3)])
+         (cond
+           [(or ((first-pass #:? m-1) v) (some-constructor-1? v))
+            ((λ ([v : some-constructor-1]) …)
+             (if ((first-pass #:? m-1) v)
+                 <inline-v>
+                 v))]
+           [(or ((first-pass #:? m-2) v) (some-constructor-2? v))
+            ((λ ([v : some-constructor-2]) …)
+             (if ((first-pass #:? m-2) v)
+                 <inline-v>
+                 v))]
+           [else
+            ((λ ([v : some-abritrary-type-3]) …)
+             (if ((first-pass #:? m-3) v)
+                 <inline-v>
+                 v))]))]
+
+Detecting whether we can safely use variants for the first
+two cases (@tc[m-1] and @tc[m-2]) requires knowing if the 
+@tc[~>] was in a variant position or in the @tc[#:or]
+position, or to change the user syntax a bit.
+
+As of 2016-03-18, however, rewrite-type doesn't support yet
+variants, so we will use a temporary inefficient solution,
+which does not allow variants of (~> …).
+
+----
+
+@chunk[<inline-type>
+       (define-type-expander (inline-type stx)
+         (dbg
+          ("inline-type" stx)
+          (syntax-parse stx
+            [(_ i-t (~and seen (:id (… …))))
+             <inline-check-seen>
+             (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
+                              #'(<inline-type-replacement>
+                                 <inline-type-nodes>))])))]
+
+
 @chunk[<inline-type-replacement>
        [mapping/node-marker                                   ;; from
         (inline-type result-type (mapping/node . seen))]      ;; to
@@ -423,7 +473,6 @@ encapsulating the result types of mappings.
            [(_ (~datum mapping)) ;; TODO: should be ~literal
             (template
              (U (name/first-step #:placeholder mapping/node)
-                Nothing
                 (tmpl-replace-in-type result-type
                   [node (name/first-step #:placeholder node)]
                   …)))]

graph-lib/graph/graph.lp2.rkt

@@ -210,24 +210,25 @@ We derive identifiers for these based on the @tc[node] name:
        ;(define/with-syntax (node/promise-type …)
        ;  (stx-map syntax-local-introduce #'(node …)))
        
-       (define-temp-ids "~a/promise-type" (node …))
+       (define-temp-ids "~a/promise-type" (node …) #:prefix #'name)
-       (define-temp-ids "~a/constructor" (node …) #:first-base root)
+       (define-temp-ids "~a/constructor" (node …) #:first-base root
-       (define-temp-ids "~a?" (node …))
+          #:prefix #'name)
+       (define-temp-ids "~a?" (node …) #:prefix #'name)
        
-       (define-temp-ids "~a/make-placeholder" (node …))
+       (define-temp-ids "~a/make-placeholder" (node …) #:prefix #'name)
-       (define-temp-ids "~a/make-placeholder-type" (node …))
+       (define-temp-ids "~a/make-placeholder-type" (node …) #:prefix #'name)
-       (define-temp-ids "~a/placeholder-struct" (node …))
+       (define-temp-ids "~a/placeholder-struct" (node …) #:prefix #'name)
-       (define-temp-ids "~a/placeholder-type" (node …))
+       (define-temp-ids "~a/placeholder-type" (node …) #:prefix #'name)
        
-       (define-temp-ids "~a/incomplete-type" (node …))
+       (define-temp-ids "~a/incomplete-type" (node …) #:prefix #'name)
-       (define-temp-ids "~a/make-incomplete" (node …))
+       (define-temp-ids "~a/make-incomplete" (node …) #:prefix #'name)
-       (define-temp-ids "~a/make-incomplete-type" (node …))
+       (define-temp-ids "~a/make-incomplete-type" (node …) #:prefix #'name)
-       (define-temp-ids "~a/incomplete-tag" (node …))
+       (define-temp-ids "~a/incomplete-tag" (node …) #:prefix #'name)
-       (define-temp-ids "~a/incomplete-type" ((field …) …))
+       (define-temp-ids "~a/incomplete-type" ((field …) …) #:prefix #'name)
        
        (define-temp-ids "~a/with-promises" (node …) #:first-base root)
        
-       (define-temp-ids "~a/index-type" (node …))]
+       (define-temp-ids "~a/index-type" (node …) #:prefix #'name)]
 
 @chunk[<pass-to-second-step>
        (node/promise-type …)
@@ -256,20 +257,24 @@ We derive identifiers for these based on the @tc[node] name:
        (define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
        (define-temp-ids "~a/main-constructor" name)
        
-       (define-temp-ids "~a/placeholder-queue" (node …))
+       (define-temp-ids "~a/placeholder-queue" (node …) #:prefix #'name)
        
-       (define-temp-ids "~a/with-indices-type" (node …))
+       (define-temp-ids "~a/with-indices-type" (node …) #:prefix #'name)
-       (define-temp-ids "~a/make-with-indices" (node …))
+       (define-temp-ids "~a/make-with-indices" (node …) #:prefix #'name)
-       (define-temp-ids "~a/with-indices-tag" (node …))
+       (define-temp-ids "~a/with-indices-tag" (node …) #:prefix #'name)
        (define-temp-ids "~a/with-indices→with-promises" (node …)
-         #:first-base root)
+         #:first-base root
+         #:prefix #'name)
+       (define-temp-ids "~a/with-promises-type" ((field …) …) #:prefix #'name)
        
-       (define-temp-ids "~a/mapping-function" (node …))
+       (define-temp-ids "~a/mapping-function" (node …) #:prefix #'name)
-       (define-temp-ids "~a/mapping-function-type" (node …))
+       (define-temp-ids "~a/mapping-function-type" (node …) #:prefix #'name)
        
-       (define-temp-ids "~a/database" (node …) #:first-base root)
+       (define-temp-ids "~a/database" (node …)
+         #:first-base root
+         #:prefix #'name)
        
-       (define-temp-ids "~a/value" ((field …) …))]
+       (define-temp-ids "~a/value" ((field …) …) #:prefix #'name)]
 
 @subsection{A versatile identifier: the graph's name}
 
@@ -745,6 +750,8 @@ via @tc[(g Street)].
        (λ (stx)
          (syntax-parse stx
            [(_ (~datum node)) #'node/promise-type] …
+           [(_ (~datum node) (~datum field))
+            (template <field/with-promises-type>)] … …
            [(_ #:incomplete (~datum node)) #'node/incomplete-type] …
            [(_ #:make-incomplete (~datum node))
             #'(→ field/incomplete-type … node/incomplete-type)] …

graph-lib/lib/low/ids.rkt

@@ -39,6 +39,7 @@
   (require (only-in racket/syntax define/with-syntax)
            (only-in syntax/stx stx-map)
            (for-syntax racket/base
+                       racket/format
                        racket/syntax
                        syntax/parse
                        syntax/parse/experimental/template))
@@ -151,10 +152,15 @@
       
       ;; New features (arrows and #:first) special-cased for now
       ;; TODO: make these features more general.
-      [(_ format:simple-format base:dotted #:first-base first-base)
+      [(_ format:simple-format base:dotted
+          #:first-base first-base
+          (~optional (~seq #:prefix prefix)))
        #:with first (format-id #'first-base (syntax-e #'format) #'first-base)
        (let ([first-base-len (identifier-length #'first-base)])
-         (syntax-cons-property #'(define-temp-ids format base #:first first)
+         (syntax-cons-property (template
+                                (define-temp-ids format base
+                                  #:first first
+                                  (?? (?@ #:prefix prefix))))
                                'sub-range-binders
                                (list
                                 (if (> (attribute format.left-len) 0)
@@ -186,21 +192,26 @@
       
       [(_ format:simple-format
           base:dotted
-          (~optional (~seq #:first first)))
+          (~optional (~seq #:first first))
+          (~optional (~seq #:prefix prefix)))
        (let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))])
          (define/with-syntax pat
            (format-id #'base.id (syntax-e #'format) #'base.id))
          (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
          
          (define/with-syntax format-temp-ids*
-           ((attribute base.wrap) #'(compose car
+           ((attribute base.wrap) (template
-                                             (curry format-temp-ids format)
+                                   (compose car
-                                             generate-temporary)
+                                            (?? (curry format-temp-ids
+                                                       (~a "~a:" format)
+                                                       prefix)
+                                                (curry format-temp-ids
+                                                       format))
+                                            generate-temporary))
                                   (λ (x deepest?)
                                     (if deepest?
                                         x
                                         #`(curry stx-map #,x)))))
-         
          (syntax-cons-property
           (template (begin (define/with-syntax pat-dotted
                              (format-temp-ids* #'base))