Closes FB case 125 Use define-private-tagged in graph.lp2.rkt for with-promises etc. nodes (the ones that shouldn't be seeable outside)

This commit is contained in:
Georges Dupéron 2016-03-12 15:11:51 +01:00
parent 46b3785b47
commit 7a643178be
3 changed files with 22 additions and 26 deletions

View File

@ -215,7 +215,7 @@ We derive identifiers for these based on the @tc[node] name:
(define-temp-ids "~a/incomplete-tag" (node )) (define-temp-ids "~a/incomplete-tag" (node ))
(define-temp-ids "~a/incomplete-type" ((field ) )) (define-temp-ids "~a/incomplete-type" ((field ) ))
(define-temp-ids "~a/with-promises-type" (node ) #:first-base root) (define-temp-ids "~a/with-promises" (node ) #:first-base root)
(define-temp-ids "~a/index-type" (node ))] (define-temp-ids "~a/index-type" (node ))]
@ -235,8 +235,8 @@ We derive identifiers for these based on the @tc[node] name:
(node/incomplete-tag ) (node/incomplete-tag )
((field/incomplete-type ) ) ((field/incomplete-type ) )
(node/with-promises-type ) (node/with-promises )
root/with-promises-type root/with-promises
(node/index-type )] (node/index-type )]
@ -253,9 +253,6 @@ We derive identifiers for these based on the @tc[node] name:
(define-temp-ids "~a/with-indices→with-promises" (node ) (define-temp-ids "~a/with-indices→with-promises" (node )
#:first-base root) #:first-base root)
(define-temp-ids "~a/make-with-promises" (node ))
(define-temp-ids "~a/with-promises-tag" (node ))
(define-temp-ids "~a/mapping-function" (node )) (define-temp-ids "~a/mapping-function" (node ))
(define-temp-ids "~a/mapping-function-type" (node )) (define-temp-ids "~a/mapping-function-type" (node ))
@ -298,6 +295,7 @@ The graph name will be used in several ways:
[(_ #:? (~datum node)) [(_ #:? (~datum node))
(syntax/loc stx node?)] (syntax/loc stx node?)]
[(_ . rest) [(_ . rest)
(syntax/loc stx (root/constructor . rest))])) (syntax/loc stx (root/constructor . rest))]))
#:id (λ (stx) #'root/constructor))] #:id (λ (stx) #'root/constructor))]
@ -409,7 +407,7 @@ node.
@chunk[<constructors> @chunk[<constructors>
(begin (begin
(: node/constructor ( param-type (Promise node/with-promises-type))) (: node/constructor ( param-type (Promise node/with-promises)))
(define (node/constructor param ) (define (node/constructor param )
(match-let ([(list node/database ) (match-let ([(list node/database )
(fq 'node/placeholder-queue (fq 'node/placeholder-queue
@ -553,20 +551,12 @@ that node's @tc[with-promises] type.
@; TODO: use a type-expander here, instead of a template metafunction. @; TODO: use a type-expander here, instead of a template metafunction.
@CHUNK[<define-with-promises> @CHUNK[<define-with-promises>
(define-type node/with-promises-type (define-private-tagged node/with-promises
(tagged node/with-promises-tag [field : <field/with-promises-type>] )]
[field : <field/with-promises-type>] ))
(: node/make-with-promises ( <field/with-promises-type>
node/with-promises-type))
(define (node/make-with-promises field/value )
(tagged node/with-promises-tag
[field : <field/with-promises-type> field/value]
))]
@CHUNK[<field/with-promises-type> @CHUNK[<field/with-promises-type>
(tmpl-replace-in-type field-type (tmpl-replace-in-type field-type
[node (Promise node/with-promises-type)] )] [node (Promise node/with-promises)] )]
@subsection{Making incomplete nodes} @subsection{Making incomplete nodes}
@ -694,10 +684,10 @@ because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it
@chunk[<index→promise-clause> @chunk[<index→promise-clause>
[node/index-type [node/index-type
(Promise node/with-promises-type) (Promise node/with-promises)
(struct-predicate node/index-type) (struct-predicate node/index-type)
(λ ([tagged-index : node/index-type] [acc : Void]) (λ ([tagged-index : node/index-type] [acc : Void])
: (values (Promise node/with-promises-type) Void) : (values (Promise node/with-promises) Void)
(values <index→promise> acc))]] (values <index→promise> acc))]]
TODO: check what we are closing over in that promise. TODO: check what we are closing over in that promise.
@ -713,12 +703,12 @@ closes over.
@chunk[<define-with-indices→with-promises> @chunk[<define-with-indices→with-promises>
(: node/with-indices→with-promises ( node/with-indices-type (: node/with-indices→with-promises ( node/with-indices-type
node/with-promises-type)) node/with-promises))
(define (node/with-indices→with-promises n) (define (node/with-indices→with-promises n)
(define f (tmpl-fold-instance (List <field/with-indices-type> ) (define f (tmpl-fold-instance (List <field/with-indices-type> )
Void Void
<index→promise-clause> )) <index→promise-clause> ))
(apply node/make-with-promises (first-value (f (cdr n) (void)))))] (apply node/with-promises (first-value (f (cdr n) (void)))))]
Where @tc[<field-with-indices-type>] is the @tc[field-type] in which node types Where @tc[<field-with-indices-type>] is the @tc[field-type] in which node types
are replaced by tagged indices, as defined earlier. are replaced by tagged indices, as defined earlier.
@ -735,7 +725,7 @@ via @tc[(g Street)].
@chunk[<graph-type-expander> @chunk[<graph-type-expander>
(λ (stx) (λ (stx)
(syntax-parse stx (syntax-parse stx
[(_ (~datum node)) #'node/with-promises-type] [(_ (~datum node)) #'node/with-promises]
[(_ #:incomplete (~datum node)) #'node/incomplete-type] [(_ #:incomplete (~datum node)) #'node/incomplete-type]
[(_ #:make-incomplete (~datum node)) [(_ #:make-incomplete (~datum node))
#'( field/incomplete-type node/incomplete-type)] #'( field/incomplete-type node/incomplete-type)]

View File

@ -147,3 +147,7 @@
(variant . dl1) (variant . dl1)
(structure x y) (structure x y)
(variant . txyz) (variant . txyz)
(variant . City89/with-promises-tag)
(variant . Street90/with-promises-tag)
(variant . House91/with-promises-tag)
(variant . Person92/with-promises-tag)

View File

@ -444,9 +444,11 @@ the uninterned @tc[tag] either).
@; tags. @; tags.
@chunk[<define-uninterned-tagged> @chunk[<define-uninterned-tagged>
(define-syntax/parse (define-private-tagged tag:id (define-syntax/parse
(~maybe #:? tag?) (define-private-tagged tag:id
. (~and structure-type ([field type] ))) (~maybe #:? tag?)
. (~and structure-type
([field (~optional (~and C :colon)) type] )))
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag)) (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
(define-temp-ids "~a/struct" tag) (define-temp-ids "~a/struct" tag)
(define-temp-ids "~a/arg" (field )) (define-temp-ids "~a/arg" (field ))