From 1d16c55f5092caa834ac9c3a67cf78014fb8476b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 14 Mar 2016 14:12:21 +0100 Subject: [PATCH] Closes FB case 120 Use the unique variants in the graph declaration --- graph-lib/graph/graph.lp2.rkt | 145 +++++++++++++++++++++----------- graph-lib/graph/remember.rkt | 3 + graph-lib/graph/variant.lp2.rkt | 3 +- 3 files changed, 103 insertions(+), 48 deletions(-) diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index efd6e6f5..e88f5757 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -200,7 +200,17 @@ A single node name can refer to several types: We derive identifiers for these based on the @tc[node] name: +@; The syntax-local-introduce trick doesn't seem to work well here. +@; Street: identifier's binding is ambiguous +@; context...: +@; matching binding...: +@; matching binding...: in: Street + @chunk[ + ;(define/with-syntax (node/promise-type …) + ; (stx-map syntax-local-introduce #'(node …))) + + (define-temp-ids "~a/promise-type" (node …)) (define-temp-ids "~a/constructor" (node …) #:first-base root) (define-temp-ids "~a?" (node …)) @@ -220,6 +230,7 @@ We derive identifiers for these based on the @tc[node] name: (define-temp-ids "~a/index-type" (node …))] @chunk[ + (node/promise-type …) (node/constructor …) root/constructor (node? …) @@ -293,6 +304,9 @@ The graph name will be used in several ways: [(_ #:root (~datum node) . rest) (syntax/loc stx (node/constructor . rest))] … + ;; TODO: TR has issues with occurrence typing and promises, + ;; so we should wrap the nodes in a tag, which contains a + ;; promise, instead of the opposite (tag inside promise). [(_ #:? (~datum node)) (syntax/loc stx node?)] … @@ -336,7 +350,8 @@ available outside the graph definition: ;; TODO: Struct definitions have to be outside due to TR bug #192 ;; https://github.com/racket/typed-racket/issues/192 (begin ) … - (begin ) …] + (begin ) … + (begin ) …] It will then bind these generated names to identifiers which can be used in the scope of the graph declaration. There, we will first inject the user-supplied @@ -381,25 +396,25 @@ It will be called from the first step with the following syntax: (define-syntax/parse (template/debug debug - (begin - (begin ) … - - (begin ) … - (begin ) … - (begin ) … - (begin ) … - (begin (begin ) …) … - (begin ) … - - (begin ) … - - (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type - (List (Vectorof node/with-indices-type) …)) - …)) - (define (fq queue-name placeholder) - ) - - )))] + (begin + (begin ) … + + (begin ) … + (begin ) … + (begin ) … + (begin ) … + (begin (begin ) …) … + (begin ) … + + (begin ) … + + (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type + (List (Vectorof node/with-indices-type) …)) + …)) + (define (fq queue-name placeholder) + ) + + )))] We shall define a graph constructor for each node type, which accepts the arguments for that node's mapping, and generates a graph rooted in the resulting @@ -407,14 +422,13 @@ node. @chunk[ (begin - (: node/constructor (→ param-type … (Promise node/with-promises))) + (: node/constructor (→ param-type … node/promise-type)) (define (node/constructor param …) (match-let ([(list node/database …) (fq 'node/placeholder-queue (node/make-placeholder param …))]) (begin ) … - (delay (node/with-indices→with-promises - (vector-ref node/database 0)))))) + (node/with-indices→with-promises (vector-ref node/database 0))))) …] @@ -550,13 +564,18 @@ that node's @tc[with-promises] type. @; TODO: use a type-expander here, instead of a template metafunction. +@; TODO: use a private-constructor here (single field, no need to use a +@; structure with define-private-tagged). +@CHUNK[ + (define-private-tagged node/promise-type + [n : (Promise node/with-promises)])] @CHUNK[ - (define-private-tagged node/with-promises - [field : ] …)] + (define-structure node/with-promises + [field ] …)] @CHUNK[ (tmpl-replace-in-type field-type - [node (Promise node/with-promises)] …)] + [node node/promise-type] …)] @subsection{Making incomplete nodes} @@ -582,7 +601,7 @@ library. We replace all occurrences of a @tc[node] name with its (define-type field/incomplete-type )] @chunk[ (tmpl-replace-in-type field-type - [node node/placeholder-type] …)] + [node node/placeholder-type] …)] @subsection{Converting incomplete nodes to with-indices ones} @@ -613,8 +632,8 @@ library. We replace all occurrences of a @tc[node] name with its (apply node/mapping-function ((struct-accessor node/placeholder-struct 0) e))] [f (tmpl-fold-instance (List …) - Δ-Queues - …)]) + Δ-Queues + …)]) (let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)]) (values (apply node/make-with-indices r) new-Δ-queues)))] @@ -684,10 +703,10 @@ because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it @chunk[ [node/index-type - (Promise node/with-promises) + node/promise-type (struct-predicate node/index-type) (λ ([tagged-index : node/index-type] [acc : Void]) - : (values (Promise node/with-promises) Void) + : (values node/promise-type Void) (values acc))]] TODO: check what we are closing over in that promise. @@ -699,16 +718,19 @@ closes over. (let ([successor-with-index (vector-ref node/database ((struct-accessor node/index-type 0) tagged-index))]) - (delay (node/with-indices→with-promises successor-with-index)))] + (node/with-indices→with-promises successor-with-index))] @chunk[ (: node/with-indices→with-promises (→ node/with-indices-type - node/with-promises)) + node/promise-type)) (define (node/with-indices→with-promises n) - (define f (tmpl-fold-instance (List …) - Void - …)) - (apply node/with-promises (first-value (f (cdr n) (void)))))] + (node/promise-type + (delay + (let () + (define f (tmpl-fold-instance (List …) + Void + …)) + (apply node/with-promises (first-value (f (cdr n) (void))))))))] Where @tc[] is the @tc[field-type] in which node types are replaced by tagged indices, as defined earlier. @@ -725,7 +747,7 @@ via @tc[(g Street)]. @chunk[ (λ (stx) (syntax-parse stx - [(_ (~datum node)) #'node/with-promises] … + [(_ (~datum node)) #'node/promise-type] … [(_ #:incomplete (~datum node)) #'node/incomplete-type] … [(_ #:make-incomplete (~datum node)) #'(→ field/incomplete-type … node/incomplete-type)] … @@ -742,12 +764,16 @@ We will be able to use this type expander in function types, for example: (define (type-example [x : (gr Street)]) : (gr Street) x) - (check-equal?: (let* ([v1 (car (structure-get (cadr (force g)) streets))] - [v2 (ann (type-example (force v1)) (gr Street))] - [v3 (structure-get (cadr v2) sname)]) - v3) - : String - "Ada Street")] + (check-equal?: + (let* ([v1 (car + (structure-get (force (structure-get (Tagged-value g) n)) + streets))] + [v2 (ann (type-example v1) (gr Street))] + [v3 (structure-get (force (structure-get (Tagged-value v2) n)) + sname)]) + v3) + : String + "Ada Street")] @section{Putting it all together} @@ -774,7 +800,9 @@ We will be able to use this type expander in function types, for example: ;(begin-for-syntax ;) - (provide define-graph) + (provide define-graph + define-graph-second-step ; DEBUG + ) )] @@ -789,11 +817,34 @@ not match the one from @tc[typed/racket] (only-in "../lib/low.rkt" cars cdrs check-equal?:) (only-in "structure.lp2.rkt" structure-get) "../type-expander/type-expander.lp2.rkt" - typed/rackunit) + typed/rackunit + ;;DEBUG: + (for-syntax syntax/parse + racket/syntax + syntax/parse/experimental/template + racket/sequence + racket/pretty + "rewrite-type.lp2.rkt" + (submod "../lib/low.rkt" untyped) + "meta-struct.rkt") + racket/splicing + "fold-queues.lp2.rkt" + "rewrite-type.lp2.rkt" + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "meta-struct.rkt") (provide g) - )] + + + (define-graph gr-simple + [Fountain [water : (Listof Symbol)] + [(m-fountain [mountain : Symbol]) + (Fountain (list mountain mountain))]]))] The whole file, finally: diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt index dd8d962f..66850bbf 100644 --- a/graph-lib/graph/remember.rkt +++ b/graph-lib/graph/remember.rkt @@ -151,3 +151,6 @@ (variant . Street90/with-promises-tag) (variant . House91/with-promises-tag) (variant . Person92/with-promises-tag) +(structure n) +(structure water) +(structure water) diff --git a/graph-lib/graph/variant.lp2.rkt b/graph-lib/graph/variant.lp2.rkt index b942b6e1..69218c49 100644 --- a/graph-lib/graph/variant.lp2.rkt +++ b/graph-lib/graph/variant.lp2.rkt @@ -539,6 +539,7 @@ the uninterned @tc[tag] either). "structure.lp2.rkt") (provide (rename-out [Tagged-predicate? Tagged?] [Tagged-type TaggedTop]) + Tagged-value constructor define-variant tagged @@ -560,7 +561,7 @@ the uninterned @tc[tag] either). (module+ test-helpers - (provide Tagged-value))) + #;(provide Tagged-value))) (require 'main) (provide (all-from-out 'main))