diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt
index 3331352..6924960 100644
--- a/graph-lib/graph/__DEBUG_graph6.rkt
+++ b/graph-lib/graph/__DEBUG_graph6.rkt
@@ -14,6 +14,7 @@
(for-syntax syntax/parse)
(for-syntax syntax/parse/experimental/template))
+
#|
(require "__DEBUG_graph6B.rkt")
@@ -50,7 +51,10 @@
: (Listof Street)
(map Street snames)])
-;(grr3 '(("a" "b") ("c")))
+(% (x y) = ((car DBG) '(("a" "b" "c") ("d")))
+ in
+ (list (get x streets … sname)
+ (get y streets … sname)))
#;(super-define-graph/rich-return
grr4
@@ -84,330 +88,3 @@
(dg grra)
|#
-
-
-
-
-
-
-
-
-
-;; DEBUG:
-(require (for-syntax racket/format
- "rewrite-type.lp2.rkt"
- racket/syntax
- syntax/parse
- (submod "../lib/low.rkt" untyped))
- (for-syntax syntax/parse
- syntax/parse/experimental/template
- racket/syntax
- (submod "../lib/low.rkt" untyped)
- "rewrite-type.lp2.rkt" #|debug|#
- syntax/id-set
- racket/format
- mischief/transform)
- (rename-in "../lib/low.rkt" [~> threading:~>])
- "graph.lp2.rkt"
- "get.lp2.rkt"
- "../type-expander/type-expander.lp2.rkt"
- "../type-expander/multi-id.lp2.rkt"
- "adt.lp2.rkt" ; debug
- "fold-queues.lp2.rkt"; debug
- "rewrite-type.lp2.rkt"; debug
- "meta-struct.rkt"; debug
- racket/stxparam
- racket/splicing)
-
-
-
-
-#;(define-graph
- grr31/first-step
- #:definitions
- ((define-type-expander
- (~> stx)
- (syntax-parse
- stx
- ((_ (~datum m-cities))
- (template
- (U
- (grr31/first-step
- #:placeholder
- m-cities4/node)
- (Listof
- (grr31/first-step
- #:placeholder
- City)))))
- ((_ (~datum m-streets))
- (template
- (U
- (grr31/first-step
- #:placeholder
- m-streets5/node)
- (Listof
- (grr31/first-step
- #:placeholder
- Street)))))))
- (define-type-expander
- (first-step-expander2 stx)
- (syntax-parse
- stx
- ((_ (~datum m-cities))
- #'(U
- m-cities4/node
- (Listof City)))
- ((_ (~datum m-streets))
- #'(U
- m-streets5/node
- (Listof Street))))))
- (City
- (streets
- :
- (Let
- (~> first-step-expander2)
- (~> m-streets)))
- ((City2/simple-mapping
- (streets
- :
- (~> m-streets)))
- (City streets)))
- (Street
- (sname
- :
- (Let
- (~> first-step-expander2)
- String))
- ((Street3/simple-mapping
- (sname : String))
- (Street sname)))
- (m-cities4/node
- (returned : (Listof City))
- ((m-cities
- (cnames
- :
- (Listof
- (Listof bubble))))
- (m-cities4/node
- (let ((City
- City2/simple-mapping)
- (Street
- Street3/simple-mapping))
- (define (strings→city
- (s
- :
- (Listof
- blob)))
- (City (m-streets s)))
- (map
- strings→city
- cnames)))))
- (m-streets5/node
- (returned
- :
- (Listof Street))
- ((m-streets
- (snames
- :
- (Listof String)))
- (m-streets5/node
- (let ((City
- City2/simple-mapping)
- (Street
- Street3/simple-mapping))
- (map
- Street
- snames))))))
-
-
-#;(define-graph
- grr3
- #:definitions
- ((define-type-expander
- (~>-to-result-type stx)
- (syntax-parse
- stx
- ((_ (~datum m-cities)) #'(Listof City))
- ((_ (~datum m-streets)) #'(Listof Street))))
- (define-type
- m-cities10/node-marker
- (Listof (grr3 #:placeholder City));
- #;(U (grr31/first-step m-cities4/node) (Listof (grr31/first-step City))))
- (define-type
- m-streets11/node-marker
- (Listof (grr3 #:placeholder Street));
- #;(U (grr31/first-step m-streets5/node) (Listof (grr31/first-step Street))))
- (define-type-expander
- (second-step-marker-expander stx)
- (syntax-parse
- stx
- ((_ (~datum m-cities)) #'m-cities10/node-marker)
- ((_ (~datum m-streets)) #'m-streets11/node-marker)))
- (define-type
- second-step-m-cities16/node-of-first
- (grr31/first-step m-cities4/node))
- (define-type
- second-step-m-streets17/node-of-first
- (grr31/first-step m-streets5/node))
- (define-type second-step-City18-of-first (grr31/first-step City))
- (define-type second-step-Street19-of-first (grr31/first-step Street))
- (define-type-expander
- (second-step-marker2-expander stx)
- (syntax-parse
- stx
- ((_ (~datum m-cities))
- #'(U
- second-step-m-cities16/node-of-first
- (Listof City #;(grr31/first-step City))))
- ((_ (~datum m-streets))
- #'(U
- second-step-m-streets17/node-of-first
- (Listof Street #;(grr31/first-step Street)))))) ;;;;;;;;;SHOULD BE A MARKER! (done here)
- (define-type-expander
- (inline-type* stx)
- (dbg
- ("inline-type*" stx)
- (syntax-parse
- stx
- ((_ i-tyy (~and seen (:id …)) (~optional msg))
- (when (attribute msg) (displayln (syntax-e #'msg)))
- (define/with-syntax replt #'i-tyy)
- #'(inline-type replt seen)))))
- (define-type-expander
- (inline-type stx)
- (dbg
- ("inline-type" stx)
- (syntax-parse
- stx
- ((_ i-t (~and seen (:id …)))
- (let ((seen-list (syntax->list #'seen)))
- (when (and
- (not (null? seen-list))
- (member (car seen-list) (cdr seen-list) free-identifier=?))
- (raise-syntax-error
- 'define-graph/rich-returns
- (~a
- "Cycles in types are not allowed."
- " The following types were already inlined: "
- (syntax->datum #'seen)
- ", but "
- #'t
- " appeared a second time.")
- #'t)))
- (replace-in-type
- #'(Let ((~> second-step-marker-expander)) i-t)
- #'((second-step-m-cities16/node-of-first
- (inline-type* (Listof City) (m-cities4/node . seen)))
- (second-step-m-streets17/node-of-first
- (inline-type* (Listof Street) (m-streets5/node . seen)))
- (City (grr3 #:placeholder City))
- (Street (grr3 #:placeholder Street))))))))
- (define-syntax (inline-instance* stx)
- (dbg
- ("inline-instance*" stx)
- (syntax-parse
- stx
- ((_ i-ty seen)
- (define/with-syntax
- replt
- (replace-in-type
- #'(Let (~> second-step-marker2-expander) i-ty)
- #'((City second-step-City18-of-first)
- (Street second-step-Street19-of-first))))
- (displayln (list "replt=" #'replt))
- #'(inline-instance replt seen)))))
- (define-syntax (inline-instance stx)
- (dbg
- ("inline-instance" stx)
- (syntax-parse
- stx
- ((_ i-t (~and seen (:id …)))
- (define/with-syntax typp #'i-t)
- (define/with-syntax
- repl
- (replace-in-instance
- #'typp
- #'((second-step-m-cities16/node-of-first
- (inline-type* (Listof City) (m-cities4/node . seen) "RESSSS")
- (grr31/first-step #:? m-cities4/node)
- (λ ((x : second-step-m-cities16/node-of-first))
- ((inline-instance* (Listof City) (m-cities4/node . seen))
- (get x returned))))
- (second-step-m-streets17/node-of-first
- (inline-type* (Listof Street) (m-streets5/node . seen) "RESSSS")
- (grr31/first-step #:? m-streets5/node)
- (λ ((x : second-step-m-streets17/node-of-first))
- ((inline-instance* (Listof Street) (m-streets5/node . seen))
- (get x returned))))
- (second-step-City18-of-first
- (grr3 #:placeholder City)
- (grr31/first-step #:? City)
- City6/extract/mapping)
- (second-step-Street19-of-first
- (grr3 #:placeholder Street)
- (grr31/first-step #:? Street)
- Street7/extract/mapping))))
- (displayln (list "i-t=" #'typp))
- (let ((seen-list (syntax->list #'seen)))
- (when (and
- (not (null? seen-list))
- (member (car seen-list) (cdr seen-list) free-identifier=?))
- (raise-syntax-error
- 'define-graph/rich-returns
- (~a
- "Cycles in types are not allowed."
- " The following types were already inlined: "
- (syntax->datum #'seen)
- ", but "
- #'t
- " appeared a second time.")
- #'t)))
- #'repl)))))
- (City
- (streets : (Let (~> ~>-to-result-type) (~> m-streets)))
- ((City6/extract/mapping (from : (grr31/first-step City)))
- (City ((inline-instance* (~> m-streets) ())
- #;(λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))
- (first-value
- ((λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))) (acc : Void))
- :
- (values m-streets11/node-marker ;(U (inline-type* (Listof Street) (m-streets5/node) "RE1234")
- ; (Listof (grr31/first-step Street)))
- Void)
- (cond
- (((grr31/first-step #:? m-streets5/node) val)
- ((ann
- (λ ((x : second-step-m-streets17/node-of-first) (acc : Void))
- (values ((λ ((x : second-step-m-streets17/node-of-first)) ((inline-instance* (Listof Street) (m-streets5/node)) (get x returned))) x) acc))
- (→ second-step-m-streets17/node-of-first Void (values (inline-type* (Listof Street) (m-streets5/node) "RESSSS") Void)))
- val
- acc))
- (#t
- ((λ ((val : (Listof (grr31/first-step Street))) (acc : Void))
- :
- (values m-streets11/node-marker ;(Listof (grr31/first-step Street))
- Void)
- (let ((f
- ((inst foldl (grr31/first-step Street) (Pairof (Listof (grr31/first-step Street)) Void) Nothing Nothing)
- (λ ((x : (grr31/first-step Street))
- (acc1 : (Pairof m-streets11/node-marker;(Listof (grr31/first-step Street))
- Void)))
- (let-values (((res res-acc) ((inst values (grr31/first-step Street) Void) x (cdr acc1))))
- (cons (cons res (car acc1)) res-acc)))
- (cons '() acc)
- val)))
- (values (reverse (car f)) (cdr f))))
- val
- acc))
- (else
- (typecheck-fail
- (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))
- "Unhandled union case in (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))), whole type was:(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))"))))
- val
- (void))))
- (get from streets)))
- ))
- (Street
- (sname : (Let (~> ~>-to-result-type) String))
- ((Street7/extract/mapping (from : (grr31/first-step Street)))
- (Street ((inline-instance* String ()) (get from sname))))))
\ No newline at end of file
diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
index 14b35a1..8d144fc 100644
--- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt
+++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
@@ -114,6 +114,8 @@ plain list.
(define-temp-ids "top1-accumulator-type" name)
(define-temp-ids "~a/constructor-top2" (mapping …))
(define-temp-ids "~a/accumulator" (node …))
+ (define-temp-ids "~a/top2-roots" (node …))
+ (define-temp-ids "~a/next-idx" (node …))
(define-temp-ids "~a/simple-mapping" (node …))
(define-temp-ids "~a/node" (mapping …))
(define-temp-ids "~a/extract/mapping" (node …))
@@ -294,7 +296,8 @@ identifier, so that it can be matched against by
<inline-instance-top1-types>
<inline-instance-top1>
<outer-inline>
- <inline-instance-top2>]
+ <inline-instance-top2>
+ <inline-instance-top3>]
We create the inlined-node by inlining the temporary nodes
in all of its fields:
@@ -330,8 +333,8 @@ recursively:
[(_ i-t (~and seen (:id (… …))))
<inline-check-seen>
(replace-in-instance #'i-t
- #'(<inline-instance-replacement>
- <inline-instance-nodes>))])))]
+ #'(<inline-instance-replacement>
+ <inline-instance-nodes>))])))]
@chunk[<inline-instance-replacement>
[second-step-mapping/node-of-first ;; from
@@ -380,9 +383,9 @@ layer of actual nodes. We do this in three steps:
…
(define-type top1-accumulator-type
- (Pairof Index ;; max
- (List (AListof mapping/node-index (name/first-step node))
- …)))
+ (List (Pairof Index ;; max
+ (AListof mapping/node-index (name/first-step node)))
+ …))
(define-type-expander (second-step-marker2-top-expander stx)
(syntax-parse stx
@@ -442,14 +445,14 @@ layer of actual nodes. We do this in three steps:
[acc : top1-accumulator-type])
: (values mapping/node-index-marker
top1-accumulator-type)
- (% (idx . (node/accumulator …)) = acc
- new-index = (mapping/node-index idx)
+ (% ([node/next-idx . node/accumulator] …) = acc
+ new-index = (mapping/node-index node/next-idx)
in
(values new-index
(let ([node/accumulator (cons (cons new-index x)
- node/accumulator)])
- (cons (assert (add1 idx) index?)
- (list node/accumulator …))))))]
+ node/accumulator)]
+ [node/next-idx (assert (add1 node/next-idx) index?)])
+ (list (cons node/next-idx node/accumulator) …)))))]
…]
@chunk[<inline-type-top1>
@@ -471,7 +474,7 @@ layer of actual nodes. We do this in three steps:
@chunk[<inline-type-top1-nodes>
[node ;second-step-node-of-first ;; generated by the first pass
- mapping/node-index] ;; new type
+ mapping/node-index-marker] ;; new type
…]
@chunk[<inline-instance-top2>
@@ -484,65 +487,65 @@ layer of actual nodes. We do this in three steps:
@chunk[<constructor-top2-body>
first-graph = (name/first-step #:root mapping/node param …)
- alists = (list (!each mapping '()) …)
+ alists = (list (!each mapping '[0 . ()]) …)
with-indices-top1 last-acc = ((inline-instance-top1* result-type ())
(get first-graph returned)
- (cons 1 alists))
- (_ . (node/accumulator …)) = last-acc
+ alists)
+ ([node/next-idx . node/accumulator] …) = last-acc
in
+ (assert (= (length node/accumulator) node/next-idx))
;; Call the second step graph constructor:
- (name #:roots [node (lists (cdrs node/accumulator))] …)]
+ (% (node/top2-roots …)
+ = (name #:roots [node (reverse (lists (cdrs node/accumulator)))] …)
+ in
+ ((replace-markers-top3 result-type
+ node/top2-roots …)
+ with-indices-top1))]
@chunk[<inline-instance-top3>
- (replace-in-instance #'TYPE??
- #'([mapping/node-index ;; from
- (name node) ;; to
- mapping/node-index? ;; pred?
- (λ ([idx : mapping/node-index]) ;; fun
- (VECTOR-REF ??? (constructor-values idx)))
- ]))]
-
-@(begin #|
-@CHUNK[<inline-instance-top3>
- (define-syntax (inline-instance-top3* stx)
+ (define-syntax (replace-markers-top3 stx)
(dbg
("inline-instance-top3*" stx)
(syntax-parse stx
- [(_ i-ty seen)
- (define/with-syntax replt
- (replace-in-type #'(Let (id-~> second-step-marker2-expander)
- i-ty)
- #'([node second-step-node-of-first]
- …)))
- (displayln (list "replt=" #'replt))
- #'(inline-instance-top3 replt seen)])))
+ [(_ i-ty node/top2-roots …)
+ (displayln (replace-in-type #'(inline-type-top1 i-ty ())
+ #'[]))
+ (replace-in-instance #'(inline-type-top1 i-ty ())
+ #'([mapping/node-index-marker ;; from
+ (name node) ;; to
+ mapping/node-index? ;; pred?
+ (λ ([idx : mapping/node-index]) ;; fun
+ (vector-ref node/top2-roots
+ (constructor-values idx)))]
+ …))])))
+ #;(define-syntax (inline-instance-top3* stx)
+ (dbg
+ ("inline-instance-top3*" stx)
+ (syntax-parse stx
+ [(_ i-ty seen node/top2-roots …)
+ (define/with-syntax replt
+ (replace-in-type #'(Let (id-~> second-step-marker2-top-expander)
+ i-ty)
+ #'([node second-step-node-of-first]
+ …)))
+ (displayln (list "replt-top=" #'replt))
+ #'(inline-instance-top3 replt seen node/top2-roots …)])))
- (define-syntax (inline-instance-top3 stx)
- (dbg
- ("inline-instance-top3" stx)
- (syntax-parse stx
- [(_ i-t (~and seen (:id (… …))))
- <inline-check-seen>
- (replace-in-instance #'i-t
- #'(<inline-instance-top3-replacement>
- <inline-instance-top3-nodes>))])))]
-
-@chunk[<inline-instance-top3-replacement>
- [second-step-mapping/node-of-first ;; from
- (inline-type result-type (mapping/node . seen)) ;; to
- (name/first-step #:? mapping/node) ;; pred?
- (λ ([x : second-step-mapping/node-of-first]) ;; fun
- ((inline-instance-top3* result-type (mapping/node . seen))
- (get x returned)))]
- …]
-
-@chunk[<inline-instance-top3-nodes>
- [second-step-node-of-first ;; node of first step ;; from
- (name #:placeholder node) ;; new type ;; to
- (name/first-step #:? node) ;; pred?
- node/extract/mapping] ;; call mapping ;; fun
- …]
-|#)
+ #;(define-syntax (inline-instance-top3 stx)
+ (dbg
+ ("inline-instance-top3" stx)
+ (syntax-parse stx
+ [(_ i-t (~and seen (:id (… …))) node/top2-roots …)
+ <inline-check-seen>
+ ;(replace-in-instance #'i-t
+ (replace-in-instance #'i-t
+ #'([mapping/node-index-marker ;; from
+ (name node) ;; to
+ mapping/node-index? ;; pred?
+ (λ ([idx : mapping/node-index]) ;; fun
+ (vector-ref node/top2-roots
+ (constructor-values idx)))]
+ …))])))]
@subsection{Inlining types}
diff --git a/graph-lib/lib/low/ids.rkt b/graph-lib/lib/low/ids.rkt
index 0b03d8b..6f1570a 100644
--- a/graph-lib/lib/low/ids.rkt
+++ b/graph-lib/lib/low/ids.rkt
@@ -96,18 +96,12 @@
(define (format-temp-ids format . vs)
;; Introduce the binding in a fresh scope.
- (apply format-ids (λ _ ((make-syntax-introducer) #'())) format vs))
-
- ;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
- (begin-for-syntax
- (define (syntax-cons-property stx key v)
- (let ([orig (syntax-property stx key)])
- (syntax-property stx key (cons v (or orig '()))))))
-
- ;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
- (begin-for-syntax
- (define (identifier-length id) (string-length (symbol->string
- (syntax-e id)))))
+ (apply format-ids
+ (λ _ ((make-syntax-introducer) (if (syntax? format) format #'())))
+ format
+ vs))
+
+ (require (for-syntax (submod "stx.rkt" untyped)))
(begin-for-syntax
(define-syntax-class dotted