diff --git a/graph-lib/graph/fold-queues.lp2.rkt b/graph-lib/graph/fold-queues.lp2.rkt
index aa6b727d..09f20585 100644
--- a/graph-lib/graph/fold-queues.lp2.rkt
+++ b/graph-lib/graph/fold-queues.lp2.rkt
@@ -20,7 +20,7 @@
. body]
…
(~parse (root-name . _)
- (template ((?? root-spec) name …))))]
+ (template ((?? root-spec) 'name …))))]
@chunk[<enqueue-type>
(case→ (→ 'name
@@ -209,7 +209,7 @@ position in the vector equal to the index associated to it in the hash table:
…
[else (Δ-results-to-vectors results)])))
- (% index Δ-hash = (Δ-hash2-enqueue 'root-name root-value Δ-hash2-empty)
+ (% index Δ-hash = (Δ-hash2-enqueue root-name root-value Δ-hash2-empty)
(process-queues Δ-hash Δ-results-empty))]
@chunk[<process-queue>
diff --git a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
index 4ee9b564..83759a50 100644
--- a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
+++ b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
@@ -57,6 +57,8 @@ And @tc[<mapping-declaration>] is:
(stx-map (λ (mr) (cdr-assoc-syntax mr #'([node . node/mapping] …)))
#'(result-node …)))
(define/with-syntax all-nodes #'(node …))
+ (define/with-syntax (root-node . _) #'(result-node …))
+ (define/with-syntax (root-mapping . _) #'(mapping …))
; TODO: we should order the graph's nodes so that the root is
; the first one! (or add a #:root)
@@ -72,9 +74,16 @@ And @tc[<mapping-declaration>] is:
(λ (stx)
(syntax-case stx ()
[(_ . rest) #'(name/wrapped . rest)]))
- #:else-id name/constructor)
+ #:call (λ (stx)
+ (syntax-parse stx
+ [(_ . rest)
+ (syntax/loc stx
+ (name/constructor . rest))]))
+ #:id (λ (stx)
+ (syntax/loc stx name/constructor)))
(define (name/constructor [root-param : root-param-type] …)
- (list name/wrapped root-param …))
+ (name/wrapped #:root root-node (list 'root-mapping
+ root-param …)))
<define-mappings>)
[node [field c field-type] …
((node/mapping [node/arg : <node-arg-type>])
diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt
index 2cb3469b..d7761ba2 100644
--- a/graph-lib/graph/graph.lp2.rkt
+++ b/graph-lib/graph/graph.lp2.rkt
@@ -2,8 +2,6 @@
@(require "../lib/doc.rkt")
@doc-lib-setup
-@(define (comment . _) "")
-
@title[#:style manual-doc-style]{Graph library}
@(table-of-contents)
@@ -207,7 +205,8 @@ We derive identifiers for these based on the @tc[node] name:
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
- (define-temp-ids "~a/constructor" 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/placeholder-type" (node …))
(define-temp-ids "~a/placeholder-tag" (node …))
@@ -301,7 +300,8 @@ two values: the result of processing the element, and the latest version of
@tc[Δ-queues], which stores the new elements to be added to the queue.
@chunk[<fold-queues>
- (fold-queues <root-placeholder>
+ (fold-queues #:root queue-name
+ placeholder
[(node/placeholder-queue [e : <fold-queue-type-element>]
[Δ-queues : Δ-Queues]
enqueue)
@@ -369,7 +369,6 @@ 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>] …))
@@ -544,43 +543,6 @@ are replaced by tagged indices:
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-@comment[#|
- @subsection{Converting incomplete nodes to with-promises ones}
-
- @chunk[<convert-incomplete-to-with-promises>
- [node/incomplete-type
- node/with-promises-type
- (λ (x) (and (pair? x) (eq? (car x) 'node/incomplete-tag)))
- (λ ([x : node/incomplete-type] [acc : Void])
- <convert-incomplete-successor>)]]
-
- @chunk[<convert-placeholder-to-with-promises>
- [mapping/placeholder-type
- (tmpl-replace-in-type result-type [node node/with-promises-type] …)
- (λ (x) (and (pair? x) (eq? (car x) 'mapping/placeholder-tag)))
- (λ ([x : mapping/placeholder-type] [acc : Void])
- <convert-placeholder-successor>)]]
-
- @; TODO: this would be much simpler if we forced having only one mapping per
- @; node, and extended that with a macro.
-
- @chunk[<define-compatible-mappings>
- (define/with-syntax ((node/compatible-mappings ...) ...)
- (for/list ([x (in-syntax #'(node ...))])
- (multiassoc-syntax
- x
- #'([result-type . mapping]
- …))))]
-
- @chunk[<convert-incomplete-successor>
- (error (~a "Not implemented yet " x))]
-
- @chunk[<convert-placeholder-successor>
- (% index new-Δ-queues = (enqueue 'mapping/placeholder-tag x Δ-queues)
- (list 'mapping/placeholder-tag index)
- (error (~a "Not implemented yet " x)))]
- |#]
-
@section{Referencing the type of nodes}
The identifier defined by @tc[define-graph] will both act as a constuctor for
@@ -624,7 +586,21 @@ We will be able to use this type expander in function types, for example:
(define-multi-id name
#:type-expander <graph-type-expander>
- #:else-id name/constructor)
+ #:call (λ (stx)
+ (syntax-parse stx
+ ;; TODO: move this to a dot expander, so that writing
+ ;; g.a gives a constructor for the a node of g, and
+ ;; (g.a foo bar) or (let ((c .g.a)) (c foo bar)) both
+ ;; call it
+ [(_ #:λroot (~datum node))
+ #'node/constructor]
+ …
+ [(_ #:root (~datum node) . rest)
+ (syntax/loc stx (node/constructor . rest))]
+ …
+ [(_ . rest)
+ (syntax/loc stx (root/constructor . rest))]))
+ #:id (λ (stx) #'root/constructor))
(?? (splicing-let ([mapping node/make-placeholder]
…
@@ -633,14 +609,25 @@ We will be able to use this type expander in function types, for example:
extra-definition
…))
- (: name/constructor (→ root-param-type …
- (Promise root/with-promises-type)))
- (define (name/constructor root-param …)
- (match-let ([(list node/database …) <fold-queues>])
- (begin <define-with-indices→with-promises>) …
- (let ([root/with-promises (root/with-indices→with-promises
- (vector-ref root/database 0))])
- (delay root/with-promises))))))))]
+ (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type
+ (List (Vectorof node/with-indices-type) …))
+ …))
+ (define (fq queue-name placeholder)
+ <fold-queues>)
+
+ <constructors>))))]
+
+@chunk[<constructors>
+ (begin
+ (: node/constructor (→ param-type … (Promise node/with-promises-type)))
+ (define (node/constructor param …)
+ (match-let ([(list node/database …)
+ (fq 'node/placeholder-queue
+ (node/make-placeholder param …))])
+ (begin <define-with-indices→with-promises>) …
+ (delay (node/with-indices→with-promises
+ (vector-ref node/database 0))))))
+ …]
@chunk[<module-main>
(module main typed/racket
diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt
index 89f5dd95..2eca2d1c 100644
--- a/graph-lib/lib/low.rkt
+++ b/graph-lib/lib/low.rkt
@@ -1424,7 +1424,11 @@
;; ==== low/typed-not-implemented-yet.rkt ====
(provide ?)
-(define-syntax-rule (? t . rest) ((λ () : t (error "Not implemented yet")
- . rest)))
+(define-syntax (? stx)
+ (syntax-case stx ()
+ [(q t . rest)
+ (quasisyntax/loc stx
+ ((λ () : t #,(syntax/loc #'q (error "Not implemented yet"))
+ . rest)))]))
;; ==== end ====
\ No newline at end of file