diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index c5dab4f1..90026d38 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -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[ - (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-introducer - ; (quasitemplate #,(quasitemplate/debug name - (define-graph name;#,(step2-introducer #'name) + (define-graph name #:definitions [-expander> @@ -341,9 +278,11 @@ We create the inlined-node by inlining the temporary nodes in all of its fields: @chunk[ - (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: #'( ))])))] -@chunk[ - (define-type-expander (inline-type stx) - (dbg - ("inline-type" stx) - (syntax-parse stx - [(_ i-t (~and seen (:id (… …)))) - - (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t) - #'( - ))])))] - @chunk[ [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[ + (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[ + (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[ + (λ ([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) + + v)))] + +This would require some specific support from rewrite-type. + +We could have a node with the following type: + +@chunk[| 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[| 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[| 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[| 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) + + v))] + [(or ((first-pass #:? m-2) v) (some-constructor-2? v)) + ((λ ([v : some-constructor-2]) …) + (if ((first-pass #:? m-2) v) + + v))] + [else + ((λ ([v : some-abritrary-type-3]) …) + (if ((first-pass #:? m-3) 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[ + (define-type-expander (inline-type stx) + (dbg + ("inline-type" stx) + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t) + #'( + ))])))] + + @chunk[ [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)] …)))] diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index fce9792c..4eaf219d 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -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[ (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 )] … … [(_ #:incomplete (~datum node)) #'node/incomplete-type] … [(_ #:make-incomplete (~datum node)) #'(→ field/incomplete-type … node/incomplete-type)] … diff --git a/graph-lib/lib/low/ids.rkt b/graph-lib/lib/low/ids.rkt index f3f465f0..0b03d8b6 100644 --- a/graph-lib/lib/low/ids.rkt +++ b/graph-lib/lib/low/ids.rkt @@ -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))