Part 1 of inline-instance-top (unfinished, the return type is Any).

graph-lib/Makefile

@@ -13,4 +13,4 @@ clean:
 .PHONY: build-dep
 build-dep:
 	# datatype is only used as an example in the docs.
-	raco pkg install --deps search-auto --update-deps --skip-installed alexis-util cover cover-coveralls debug datatype mischief
+	raco pkg install --deps search-auto --update-deps --skip-installed alexis-util cover cover-coveralls debug datatype mischief https://github.com/jsmaniac/scribble-enhanced.git#823fdda5a65552ce4fe8d6f8fbe07391ccca73bd

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

@@ -109,6 +109,7 @@ plain list.
 @CHUNK[<graph-rich-return>
        (define-syntax/parse <signature>
          (define/with-syntax (node* …) #'(node …))
+         (define/with-syntax ([root/field-type …] . _) #'([field-type …] …))
          (define-temp-ids "~a/first-step" name)
          (define-temp-ids "first-step-expander2" name)
          (define-temp-ids "top1-accumulator-type" name)
@@ -196,7 +197,7 @@ produced by the first step.
        (define-type mapping/node-marker
          (tmpl-replace-in-type result-type
            [mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here
-           [node (name #:placeholder City)])
+           [node (name #:placeholder node)])
          #;(U (name/first-step mapping/node)
               (tmpl-replace-in-type result-type
                 [mapping/node (name/first-step mapping/node)]
@@ -219,14 +220,26 @@ produced by the first step.
          (name/first-step node))
        …
 
+       ;; TODO: we should take care here: inside result-type, node names get
+       ;; bound to the identifier from the second graph, whereas semantically
+       ;; they denote nodes from the first graph. Since they get rewritten as
+       ;; second-step-node-of-first almost immediately it doesn't cause any
+       ;; problem, but it's a nasty gotcha. Hoisintg this out of the
+       ;; second graph definition should be enough. This probably happens in
+       ;; another couple of places too.
        (define-type-expander (second-step-marker2-expander stx)
          (syntax-parse stx
            ;; TODO: should be ~literal
            [(_ (~datum mapping))
+            (syntax-local-introduce
              #'(U second-step-mapping/node-of-first
-                 result-type #;(tmpl-replace-in-type result-type
+                  result-type
+                  
+                  ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<THIS WORKED
+                  
+                  #;(tmpl-replace-in-type result-type
                       [mapping/node (name/first-step mapping/node)]
-                                 [node (name/first-step node)]))]
+                      [node (name/first-step node)])))]
            …
            ;; TODO: should fall-back to outer definition of ~>, if any?
            ))]
@@ -275,14 +288,17 @@ identifier, so that it can be matched against by
              [node [field c (Let [id-~> ~>-to-result-type] field-type)] …
               [(node/extract/mapping [from : (name/first-step node)])
                <inlined-node>]]
-             …))]
+             …))
+       
+       <inline-instance-top1-types>
+       <inline-instance-top1>
+       <outer-inline>]
 
 We create the inlined-node by inlining the temporary nodes
 in all of its fields:
 
 @chunk[<inlined-node>
-       ;; inline from the field-type of the old node.
+       (node ((inline-instance* field-type
-       (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                                 ()) (get from field))
              …)]
 
@@ -297,6 +313,20 @@ recursively:
           ("inline-instance*" stx)
           (syntax-parse stx
             [(_ i-ty seen)
+             #;(syntax-case (expand-type #'(Let
+                                            (~>
+                                             second-step-marker2-expander)
+                                            (~> m-streets))) ()
+                 [(a_U
+                   a_second-step-m-streets19/node-of-first
+                   (a_Listof a_Street))
+                  (syntax-case #'([node second-step-node-of-first] …) ()
+                    [((_ _)
+                      (b_Street b_second-step-Street21-of-first))
+                     (begin
+                       (displayln #'a_Street)
+                       (displayln #'b_Street)
+                       (displayln (free-identifier=? #'a_Street #'b_Street)))])])
              (define/with-syntax replt
                (replace-in-type #'(Let (id-~> second-step-marker2-expander)
                                        i-ty)
@@ -347,6 +377,11 @@ layer of actual nodes. We do this in three steps:
  @item{Finally, we replace the placeholders with the
   second-pass nodes returned by the graph.}]
 
+@CHUNK[<outer-inline>
+       (inline-instance-top1* root/field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+                              ())
+       …]
+
 @CHUNK[<inline-instance-top1-types>
        (define-constructor mapping/node-index
          #:private
@@ -357,9 +392,19 @@ layer of actual nodes. We do this in three steps:
        …
        
        (define-type top1-accumulator-type
-         (pairof Index ;; max
+         (Pairof Index ;; max
-                 (list (listof (name/first-step node))
+                 (List (Listof (Pairof mapping/node-index (name/first-step node))) ;; AListof
-                       …)))]
+                       …)))
+
+       (define-type-expander (second-step-marker2-top-expander stx)
+         (syntax-parse stx
+           [(_ (~datum mapping))
+            (syntax-local-introduce
+             #'(U second-step-mapping/node-of-first
+                  result-type))]
+           …
+           ;; TODO: should fall-back to outer definition of ~>, if any?
+           ))]
 
 @CHUNK[<inline-instance-top1>
        (define-syntax (inline-instance-top1* stx)
@@ -367,12 +412,28 @@ layer of actual nodes. We do this in three steps:
           ("inline-instance-top1*" stx)
           (syntax-parse stx
             [(_ i-ty seen)
+             #;(syntax-case (expand-type #'(Let
+                                            (~>
+                                             second-step-marker2-top-expander)
+                                            (~> m-streets))) ()
+                 [(a_U
+                   a_second-step-m-streets19/node-of-first
+                   (a_Listof a_Street))
+                  (syntax-case #'([node second-step-node-of-first] …) ()
+                    [((_ _)
+                      (b_Street b_second-step-Street21-of-first))
+                     (begin
+                       (displayln #'a_Street)
+                       (displayln #'b_Street)
+                       (displayln (free-identifier=? #'a_Street #'b_Street)))])])
+             (displayln (list "~~~norepl=" #'(Let (id-~> second-step-marker2-top-expander)
+                                                  i-ty)))
              (define/with-syntax replt
-               (replace-in-type #'(Let (id-~> second-step-marker2-expander)
+               (replace-in-type #'(Let (id-~> second-step-marker2-top-expander)
                                        i-ty)
                                 #'([node second-step-node-of-first]
                                    …)))
-             (displayln (list "replt=" #'replt))
+             (displayln (list "replt-top=" #'replt))
              #'(inline-instance-top1 replt seen)])))
        
        (define-syntax (inline-instance-top1 stx)
@@ -389,13 +450,16 @@ layer of actual nodes. We do this in three steps:
 
 @chunk[<inline-instance-top1-replacement>
        [second-step-mapping/node-of-first                             ;; from
-        (inline-type result-type (mapping/node . seen))               ;; to
+        Any;(inline-type result-type (mapping/node . seen))               ;; to
         (name/first-step #:? mapping/node)                            ;; pred?
         (λ ([x : second-step-mapping/node-of-first]                   ;; fun
             [acc : top1-accumulator-type])
-          (values ((inline-instance-top1* result-type (mapping/node . seen))
+          (% inlined new-acc
-                   (get x returned))
+             = ((inline-instance-top1* result-type (mapping/node . seen))
-                  ACC))]
+                (get x returned)
+                acc)
+             in
+             (values inlined new-acc)))]
        …]
 
 @chunk[<inline-instance-top1-nodes>
@@ -408,11 +472,13 @@ layer of actual nodes. We do this in three steps:
           : (values mapping/node-index-marker
                     top1-accumulator-type)
           (% (idx . (node/accumulator …)) = acc
-             
+             new-index = (mapping/node-index idx)
              in
-             (values PLACEHOLDER
+             (values new-index
-                     (cons (add1 idx)
+                     (let ([node/accumulator (cons (cons new-index x)
-                           (NEW-NDS …)))))]
+                                                   node/accumulator)])
+                       (cons (assert (add1 idx) index?)
+                             (list node/accumulator …))))))]
        …]
 
 @chunk[<inline-instance-top2>
@@ -666,7 +732,8 @@ encapsulating the result types of mappings.
                               "rewrite-type.lp2.rkt" #|debug|#
                               syntax/id-set
                               racket/format
-                              mischief/transform)
+                              mischief/transform
+                              (submod "../type-expander/type-expander.lp2.rkt" expander))
                   (rename-in "../lib/low.rkt" [~> threading:~>])
                   "graph.lp2.rkt"
                   "get.lp2.rkt"
@@ -689,11 +756,11 @@ encapsulating the result types of mappings.
          (begin-for-syntax
            (define-syntax-rule (dbg log . body)
              (begin
-               ;(display ">>> ")(displayln (list . log))
+               (display ">>> ")(displayln (list . log))
                (let ((res (let () . body)))
-                 ;(display "<<< ")(displayln (list . log))
+                 (display "<<< ")(displayln (list . log))
-                 ;(display "<<<= ")(display (car (list . log)))
+                 (display "<<<= ")(display (car (list . log)))
-                 ;(display res)(displayln ".")
+                 (display res)(displayln ".")
                  res))))
          <graph-rich-return>)]
 

graph-lib/graph/rewrite-type.scrbl

@@ -1,5 +1,7 @@
 #lang scribble/manual
 
+@(require scribble-enhanced/manual-form)
+
 @(require (for-label typed/racket/base
                      "rewrite-type.lp2.rkt"))
 
@@ -10,80 +12,84 @@ type with other types, and generating conversion functions
 transforming instances of the old type into instances of the
 new type.
 
-@defform[#:kind "template metafunction"
+@defform[#:kind "procedure"
-         (tmpl-fold-instance old-type
+         (replace-in-type old-type
-           accumulator-type
+                          #'([from to] …))
-           [from to pred? fun] …)
+         #:result (syntax-for type)
-         #:contracts ([old-type type]
+         #:contracts ([old-type (syntax-for type)]
-                      [accumulator-type type]
+                      [from (and/c identifier? (syntax-for type))]
-                      [from identifier?]
+                      [to (syntax-for type)])]{
-                      [to type]
+ This type-level function produces the syntax for the 
-                      [pred? predicate?]
+ @racket[new-type]. The @racket[new-type] has the same shape
-                      [fun (→ from acc (values to acc))])]{
+ as the @racket[old-type], except all occurrences of the 
- Produces the syntax for a function from @racket[old-type]
+ @racket[from] type (which must be just a single identifier)
- to the new type, using the provided replacement functions
+ replaced with the @racket[to] type in the type.
- for each part.}
  
+ The @racket[replace-in-type] type-level function first
+ expands any @racketmodname[type-expander]s, and performs
+ the replacements on the expanded type.}
 
-@defform[#:kind "template metafunction"
+@deftogether[
+ (@defform[#:kind "procedure"
+           (replace-in-instance old-type
+                                #'([from to pred? fun] …))
+           #:result (syntax-for (→ old-type new-type))]
+   @defform[#:kind "template metafunction"
             (tmpl-replace-in-instance old-type
               [from to pred? fun] …)
-         #:contracts ([old-type type]
+            #:result (syntax-for (→ old-type new-type))
-                      [accumulator-type type]
+            #:contracts ([old-type (syntax-for type)]
-                      [from identifier?]
+                         [from (and/c identifier? (syntax-for type))]
-                      [to type]
+                         [to (syntax-for type)]
-                      [pred? predicate?]
+                         [pred? (syntax-for predicate?)]
-                      [fun (→ from to)])]{
+                         [fun (syntax-for (→ from to))])])]{
- Produces the syntax for a function from @racket[old-type]
+ Produces the syntax for the syntax for a function from the
- to the new type, using the provided replacement functions
+ @racket[old-type] to the @racket[new-type], transforming
- for each part.}
+ all parts of the data structure which satisfy 
+ @racket[pred?] using @racket[fun]. The @racket[new-type]
+ will be the same as the one that would be returned by 
+ @racket[(replace-in-type old-type #'([from to] …))]
  
-@defform[#:kind "procedure"
+ @racket[pred?] should return true if and only if the data
-         (replace-in-type old-type #'([from to] …))
+ passed as an argument is an instance of the @racket[from]
-         #:contracts ([old-type type]
+ type. @racket[fun] should accept instances of the 
-                      [from identifier?]
+ @racket[from] type, and return instances of the 
-                      [to type])]{
+ @racket[to] type.
- This type-level function produces the syntax for the type 
+}
- @racket[old-type], with all occurrences of @racket[from]
- replaced with @racket[to] in the type.}
 
-@defform[#:kind "procedure"
+@deftogether[
-         (replace-in-instance old-type #'([from to pred? fun] …))
+ (@defform[#:kind "procedure"
-         #:contracts ([old-type type]
-                      [from identifier?]
-                      [to type]
-                      [pred? predicate?]
-                      [fun (→ from to)])]{
- Produces the syntax for the syntax for a function from 
- @racket[old-type] to the new type, transforming all parts
- of the data structure which satisfy @racket[pred?] using 
- @racket[fun]. @racket[pred?] should return true if and only
- if the data pased as an argument is an instance of the 
- @racket[from] type. @racket[fun] should accept instances of
- the @racket[from] type, and return instances of the 
- @racket[to] type.}
-
-@defform[#:kind "procedure"
            (fold-instance old-type
                           accumulator-type
-                        #'([from to pred? fun] …))
+                          ([from to pred? fun] …))
-         #:contracts ([old-type type]
+           #:result (syntax-for
-                      [accumulator-type type]
+                     (→ old-type (Values new-type accumulator-type)))]
-                      [from identifier?]
+   @defform[#:kind "template metafunction"
-                      [to type]
+            (tmpl-fold-instance old-type accumulator-type
-                      [pred? predicate?]
+              [from to pred? fun] …)
-                      [fun (→ from acc (values to acc))])]{
+            #:result (syntax-for
- Produces the syntax for the syntax for a function from 
+                      (→ old-type (Values new-type accumulator-type)))
- @racket[old-type] to the new type, transforming all parts
+            #:contracts ([old-type (syntax-for type)]
- of the data structure which satisfy @racket[pred?] using 
+                         [accumulator-type (syntax-for type)]
- @racket[fun]. The generated function takes as a second
+                         [from (and/c identifier? (syntax-for type))]
- argument an initial value for the accumulator. The
+                         [to (syntax-for type)]
- accumulator is passed to @racket[fun] and the one returned
+                         [pred? (syntax-for predicate?)]
- is used as the accumulator for the next call. No guarantee
+                         [fun (syntax-for (→ from acc (Values to acc)))])])]{
- is made on the order of traversal.
+ Produces the syntax for the syntax for a function from the
+ @racket[old-type] to the @racket[new-type], transforming
+ all parts of the data structure which satisfy 
+ @racket[pred?] using @racket[fun]. The @racket[new-type]
+ will be the same as the one that would be returned by 
+ @racket[(replace-in-type old-type #'([from to] …))]
  
- @racket[pred?] should return true if and only
+ The generated function takes as a second argument an
- if the data pased as an argument is an instance of the 
+ initial value for the accumulator. The accumulator is
- @racket[from] type. @racket[fun] should accept instances of
+ passed to @racket[fun] and the one returned is used as the
- the @racket[from] type, and return instances of the 
+ accumulator for the next call. No guarantee is made on the
+ order of traversal.
+ 
+ @racket[pred?] should return true if and only if the data
+ passed as an argument is an instance of the @racket[from]
+ type. @racket[fun] should accept instances of the 
+ @racket[from] type, and return instances of the 
  @racket[to] type.}