suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

WIP on FB case 133 Allow returning both promises for and the actual type in the first pass of rich-returns

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-18 18:23:00 +01:00
parent af5b9bcfea
commit 929f16ee1c
3 changed files with 176 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

209
graph-lib/graph/graph-6-rich-returns.lp2.rkt
View File

@ -116,6 +116,7 @@ plain list.
(define-temp-ids "~a/extract/mapping" (node …))
(define-temp-ids "~a/extract" (node …) #:first-base root)
(define-temp-ids "~a/node-marker" (mapping …))
(define-temp-ids "~a/node-marker2" (mapping …))
(define-temp-ids "~a/from-first-pass" (node …))
;(define step2-introducer (make-syntax-introducer))
;(define/with-syntax id-~> (datum->syntax #'name '~>))
@ -208,7 +209,8 @@ produced by the first step.
;; globally like this.
(define-type node (name/first-step node))
…
(define-type mapping/node-marker result-type)
(define-type mapping/node-marker (U result-type
(name/first-step node)))
…
;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-type-expander (second-step-marker-expander stx)
@ -254,69 +256,6 @@ identifier, so that it can be matched against by
@tc[tmpl-replace-in-instance] and
@tc[tmpl-replace-in-type].
@CHUNK[<inline-temp-nodes>
(define (inline-temp-nodes/type t seen)
(printf ">>> type ~a\n" (syntax->datum #'t))
(let ((rslt
(quasitemplate
(tmpl-replace-in-type (Let (id-~> second-step-marker-expander) #,t)
[mapping/node-marker
(meta-eval
(if (free-id-set-member? #,t #,seen)
(raise-syntax-error 'define-graph/rich-returns
(~a "Cycles in types are not allowed."
" The following types were already"
" inlined: " seen ", and " t
" appeared a second time.")
t)
(#,inline-temp-nodes/type result-type
#,(free-id-set-add t seen))))]
…))
))
(printf "<<< type ~a\n" (syntax->datum #'t))
rslt))
(define (inline-temp-nodes/instance t seen)
(printf ">>> inst ~a\n" (syntax->datum t))
(define/with-syntax (inlined-result-type …)
(stx-map (λ (result-type)
(inline-temp-nodes/type result-type
(free-id-set-add seen t)))
#'(result-type …)))
(define (replacement result-type mapping/node)
#`[mapping/node-marker
(inline-temp-nodes/type result-type
(free-id-set-add #,seen #,t))
(first-pass #:? mapping/node)
(if (free-id-set-member? t seen)
(raise-syntax-error 'define-graph/rich-returns
(~a "Cycles in types are not allowed."
" The following types were already"
" inlined: " #,seen ", and " #,t
" appeared a second time.")
t)
(inline-temp-nodes/instance result-type
(free-id-set-add seen t)))]
…
(let ((rslt
(replace-in-type #'(Let (id-~> second-step-marker-expander) #,t)
(stx-map replacement
#'([result-type mapping/node] …))
#;[node* ;; generated by the first pass
(name #:placeholder node*) ; new type
(first-pass #:? node*)
node*] ;; call constructor
#;…))
))
(printf "<<< inst ~a\n" (syntax->datum t))
rslt))
(define-template-metafunction (!inline-temp-nodes/instance stx)
(syntax-case stx ()
[(_ t)
(inline-temp-nodes/instance #'t (immutable-free-id-set))]))]
----------------------
@ -324,10 +263,8 @@ identifier, so that it can be matched against by
@CHUNK[<step2>
; #,(step2-introducer
; (quasitemplate
#,(quasitemplate/debug name
(define-graph name;#,(step2-introducer #'name)
(define-graph name
#:definitions [<second-step-~>-expander>
<second-step-marker-expander>
<inline-type>
@ -341,9 +278,11 @@ We create the inlined-node by inlining the temporary nodes
in all of its fields:
@chunk[<inlined-node>
(node ((inline-instance field-type ()) (get from field))
;; inline from the field-type of the old node.
(node ((inline-instance field-type ()) (get from field));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
…)]
@subsection{Inlining instances}
To inline the temporary nodes in the instance, we use
@tc[replace-in-instance], and call the inline-instance
recursively:
@ -359,17 +298,6 @@ recursively:
#'(<inline-instance-replacement>
<inline-instance-nodes>))])))]
@chunk[<inline-type>
(define-type-expander (inline-type stx)
(dbg
("inline-type" stx)
(syntax-parse stx
[(_ i-t (~and seen (:id (… …))))
<inline-check-seen>
(replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
#'(<inline-type-replacement>
<inline-type-nodes>))])))]
@chunk[<inline-instance-replacement>
[mapping/node-marker ;; from
(inline-type result-type (mapping/node . seen)) ;; to
@ -384,6 +312,128 @@ recursively:
node/extract/mapping] ;; call mapping
…]
@subsection{Inlining types}
The input type for the inlining of field @tc[streets] of the node @tc[City] is:
@chunk[<example-inline-input>
(U m-street (Listof Street))]
Where @tc[m-street] is the @emph{with-promises} node type
of @tc[name/first-step], and @tc[Street] is the
@emph{with-promises} node type of @tc[name/first-step].
More generally, @tc[(~> some-mapping)] in the first pass is expanded to:
@chunk[<example-inline-input-2>
(U (first-pass some-mapping)
(tmpl-replace-in-type result-type
[mapping/node (first-pass mapping/node)]
[node (first-pass node)]))]
When inlining, we want to first inline the
@tc[some-mapping] node, if it is present, and in all cases
drill down the result-type in both cases (either we just
inlined it, or it was already there). It would be nice to
avoid duplicating the code for inlining inside the
result-type, as the code would grow exponentially with the
number of mappings encountered along the path otherwise.
We would need to call the replace-in-instance a second time
on the result. The generated code would have a shape like this:
@chunk[<example-generated-inline>
(λ ([v : (V (first-pass some-mapping)
(tmpl-replace-in-type result-type
[mapping/node (first-pass mapping/node)]
[node (first-pass node)]))])
((λ ([v : (tmpl-replace-in-type result-type
[mapping/node (first-pass mapping/node)]
[node (first-pass node)])])
…)
(if ((first-pass #:? some-mapping) v)
<inline-v>
v)))]
This would require some specific support from rewrite-type.
We could have a node with the following type:
@chunk[|<example (V (~> 1) (~> 2) …)>|
(define-graph/rich-return grr
([Node [field : (V (~> m-1) (~> m-2) #:or (~> m-3))]]))]
where @tc[m-1], @tc[m-2] and @tc[m-3] have different return
types, but @tc[m-1] and @tc[m-2] are constructors or tagged
structures. If we expand this a bit, we see the following type:
@chunk[|<example (V (~> 1) (~> 2) …) expanded>|
(V (V (first-pass m-1)
some-constructor-1)
(V (first-pass m-2)
some-constructor-2)
#:or (U (first-pass m-3)
some-abritrary-type-3))]
Which is equivalent to:
@chunk[|<example (V (~> 1) (~> 2) …) merged>|
(V (first-pass m-1)
some-constructor-1
(first-pass m-2)
some-constructor-2
(first-pass m-3)
#:or some-abritrary-type-3)]
The generated code would be:
@chunk[|<example (V (~> 1) (~> 2) …) generated >|
(λ ([v : (V (first-pass m-1)
some-constructor-1
(first-pass m-2)
some-constructor-2
(first-pass m-3)
#:or some-abritrary-type-3)])
(cond
[(or ((first-pass #:? m-1) v) (some-constructor-1? v))
((λ ([v : some-constructor-1]) …)
(if ((first-pass #:? m-1) v)
<inline-v>
v))]
[(or ((first-pass #:? m-2) v) (some-constructor-2? v))
((λ ([v : some-constructor-2]) …)
(if ((first-pass #:? m-2) v)
<inline-v>
v))]
[else
((λ ([v : some-abritrary-type-3]) …)
(if ((first-pass #:? m-3) v)
<inline-v>
v))]))]
Detecting whether we can safely use variants for the first
two cases (@tc[m-1] and @tc[m-2]) requires knowing if the
@tc[~>] was in a variant position or in the @tc[#:or]
position, or to change the user syntax a bit.
As of 2016-03-18, however, rewrite-type doesn't support yet
variants, so we will use a temporary inefficient solution,
which does not allow variants of (~> …).
----
@chunk[<inline-type>
(define-type-expander (inline-type stx)
(dbg
("inline-type" stx)
(syntax-parse stx
[(_ i-t (~and seen (:id (… …))))
<inline-check-seen>
(replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
#'(<inline-type-replacement>
<inline-type-nodes>))])))]
@chunk[<inline-type-replacement>
[mapping/node-marker ;; from
(inline-type result-type (mapping/node . seen))] ;; to
@ -423,7 +473,6 @@ encapsulating the result types of mappings.
[(_ (~datum mapping)) ;; TODO: should be ~literal
(template
(U (name/first-step #:placeholder mapping/node)
Nothing
(tmpl-replace-in-type result-type
[node (name/first-step #:placeholder node)]
…)))]

51
graph-lib/graph/graph.lp2.rkt
View File

@ -210,24 +210,25 @@ We derive identifiers for these based on the @tc[node] name:
;(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 …))
(define-temp-ids "~a/promise-type" (node …) #:prefix #'name)
(define-temp-ids "~a/constructor" (node …) #:first-base root
#:prefix #'name)
(define-temp-ids "~a?" (node …) #:prefix #'name)
(define-temp-ids "~a/make-placeholder" (node …))
(define-temp-ids "~a/make-placeholder-type" (node …))
(define-temp-ids "~a/placeholder-struct" (node …))
(define-temp-ids "~a/placeholder-type" (node …))
(define-temp-ids "~a/make-placeholder" (node …) #:prefix #'name)
(define-temp-ids "~a/make-placeholder-type" (node …) #:prefix #'name)
(define-temp-ids "~a/placeholder-struct" (node …) #:prefix #'name)
(define-temp-ids "~a/placeholder-type" (node …) #:prefix #'name)
(define-temp-ids "~a/incomplete-type" (node …))
(define-temp-ids "~a/make-incomplete" (node …))
(define-temp-ids "~a/make-incomplete-type" (node …))
(define-temp-ids "~a/incomplete-tag" (node …))
(define-temp-ids "~a/incomplete-type" ((field …) …))
(define-temp-ids "~a/incomplete-type" (node …) #:prefix #'name)
(define-temp-ids "~a/make-incomplete" (node …) #:prefix #'name)
(define-temp-ids "~a/make-incomplete-type" (node …) #:prefix #'name)
(define-temp-ids "~a/incomplete-tag" (node …) #:prefix #'name)
(define-temp-ids "~a/incomplete-type" ((field …) …) #:prefix #'name)
(define-temp-ids "~a/with-promises" (node …) #:first-base root)
(define-temp-ids "~a/index-type" (node …))]
(define-temp-ids "~a/index-type" (node …) #:prefix #'name)]
@chunk[<pass-to-second-step>
(node/promise-type …)
@ -256,20 +257,24 @@ We derive identifiers for these based on the @tc[node] name:
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
(define-temp-ids "~a/main-constructor" name)
(define-temp-ids "~a/placeholder-queue" (node …))
(define-temp-ids "~a/placeholder-queue" (node …) #:prefix #'name)
(define-temp-ids "~a/with-indices-type" (node …))
(define-temp-ids "~a/make-with-indices" (node …))
(define-temp-ids "~a/with-indices-tag" (node …))
(define-temp-ids "~a/with-indices-type" (node …) #:prefix #'name)
(define-temp-ids "~a/make-with-indices" (node …) #:prefix #'name)
(define-temp-ids "~a/with-indices-tag" (node …) #:prefix #'name)
(define-temp-ids "~a/with-indices→with-promises" (node …)
#:first-base root)
#:first-base root
#:prefix #'name)
(define-temp-ids "~a/with-promises-type" ((field …) …) #:prefix #'name)
(define-temp-ids "~a/mapping-function" (node …))
(define-temp-ids "~a/mapping-function-type" (node …))
(define-temp-ids "~a/mapping-function" (node …) #:prefix #'name)
(define-temp-ids "~a/mapping-function-type" (node …) #:prefix #'name)
(define-temp-ids "~a/database" (node …) #:first-base root)
(define-temp-ids "~a/database" (node …)
#:first-base root
#:prefix #'name)
(define-temp-ids "~a/value" ((field …) …))]
(define-temp-ids "~a/value" ((field …) …) #:prefix #'name)]
@subsection{A versatile identifier: the graph's name}
@ -745,6 +750,8 @@ via @tc[(g Street)].
(λ (stx)
(syntax-parse stx
[(_ (~datum node)) #'node/promise-type] …
[(_ (~datum node) (~datum field))
(template <field/with-promises-type>)] … …
[(_ #:incomplete (~datum node)) #'node/incomplete-type] …
[(_ #:make-incomplete (~datum node))
#'(→ field/incomplete-type … node/incomplete-type)] …

25
graph-lib/lib/low/ids.rkt
View File

@ -39,6 +39,7 @@
(require (only-in racket/syntax define/with-syntax)
(only-in syntax/stx stx-map)
(for-syntax racket/base
racket/format
racket/syntax
syntax/parse
syntax/parse/experimental/template))
@ -151,10 +152,15 @@
;; New features (arrows and #:first) special-cased for now
;; TODO: make these features more general.
[(_ format:simple-format base:dotted #:first-base first-base)
[(_ format:simple-format base:dotted
#:first-base first-base
(~optional (~seq #:prefix prefix)))
#:with first (format-id #'first-base (syntax-e #'format) #'first-base)
(let ([first-base-len (identifier-length #'first-base)])
(syntax-cons-property #'(define-temp-ids format base #:first first)
(syntax-cons-property (template
(define-temp-ids format base
#:first first
(?? (?@ #:prefix prefix))))
'sub-range-binders
(list
(if (> (attribute format.left-len) 0)
@ -186,21 +192,26 @@
[(_ format:simple-format
base:dotted
(~optional (~seq #:first first)))
(~optional (~seq #:first first))
(~optional (~seq #:prefix prefix)))
(let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))])
(define/with-syntax pat
(format-id #'base.id (syntax-e #'format) #'base.id))
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
(define/with-syntax format-temp-ids*
((attribute base.wrap) #'(compose car
(curry format-temp-ids format)
generate-temporary)
((attribute base.wrap) (template
(compose car
(?? (curry format-temp-ids
(~a "~a:" format)
prefix)
(curry format-temp-ids
format))
generate-temporary))
(λ (x deepest?)
(if deepest?
x
#`(curry stx-map #,x)))))
(syntax-cons-property
(template (begin (define/with-syntax pat-dotted
(format-temp-ids* #'base))