From 9124c39c0d0d14f5cd45a2c6f68060b6ca9fc8e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 3 Apr 2016 02:39:34 +0200 Subject: [PATCH] Part 1 of inline-instance-top (unfinished, the return type is Any). --- graph-lib/Makefile | 2 +- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 123 +++++++++++---- graph-lib/graph/rewrite-type.scrbl | 154 ++++++++++--------- 3 files changed, 176 insertions(+), 103 deletions(-) diff --git a/graph-lib/Makefile b/graph-lib/Makefile index ff095c05..bcd80c3f 100644 --- a/graph-lib/Makefile +++ b/graph-lib/Makefile @@ -13,4 +13,4 @@ clean: .PHONY: build-dep build-dep: # datatype is only used as an example in the docs. - raco pkg install --deps search-auto --update-deps --skip-installed alexis-util cover cover-coveralls debug datatype mischief + raco pkg install --deps search-auto --update-deps --skip-installed alexis-util cover cover-coveralls debug datatype mischief https://github.com/jsmaniac/scribble-enhanced.git#823fdda5a65552ce4fe8d6f8fbe07391ccca73bd diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index d76faf75..39b62b2e 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -109,6 +109,7 @@ plain list. @CHUNK[ (define-syntax/parse (define/with-syntax (node* …) #'(node …)) + (define/with-syntax ([root/field-type …] . _) #'([field-type …] …)) (define-temp-ids "~a/first-step" name) (define-temp-ids "first-step-expander2" name) (define-temp-ids "top1-accumulator-type" name) @@ -196,7 +197,7 @@ produced by the first step. (define-type mapping/node-marker (tmpl-replace-in-type result-type [mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here - [node (name #:placeholder City)]) + [node (name #:placeholder node)]) #;(U (name/first-step mapping/node) (tmpl-replace-in-type result-type [mapping/node (name/first-step mapping/node)] @@ -218,15 +219,27 @@ produced by the first step. (define-type second-step-node-of-first (name/first-step node)) … - + + ;; TODO: we should take care here: inside result-type, node names get + ;; bound to the identifier from the second graph, whereas semantically + ;; they denote nodes from the first graph. Since they get rewritten as + ;; second-step-node-of-first almost immediately it doesn't cause any + ;; problem, but it's a nasty gotcha. Hoisintg this out of the + ;; second graph definition should be enough. This probably happens in + ;; another couple of places too. (define-type-expander (second-step-marker2-expander stx) (syntax-parse stx ;; TODO: should be ~literal [(_ (~datum mapping)) - #'(U second-step-mapping/node-of-first - result-type #;(tmpl-replace-in-type result-type - [mapping/node (name/first-step mapping/node)] - [node (name/first-step node)]))] + (syntax-local-introduce + #'(U second-step-mapping/node-of-first + result-type + + ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<, if any? ))] @@ -275,14 +288,17 @@ identifier, so that it can be matched against by [node [field c (Let [id-~> ~>-to-result-type] field-type)] … [(node/extract/mapping [from : (name/first-step node)]) ]] - …))] + …)) + + + + ] We create the inlined-node by inlining the temporary nodes in all of its fields: @chunk[ - ;; inline from the field-type of the old node. - (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (node ((inline-instance* field-type ()) (get from field)) …)] @@ -297,6 +313,20 @@ recursively: ("inline-instance*" stx) (syntax-parse stx [(_ i-ty seen) + #;(syntax-case (expand-type #'(Let + (~> + second-step-marker2-expander) + (~> m-streets))) () + [(a_U + a_second-step-m-streets19/node-of-first + (a_Listof a_Street)) + (syntax-case #'([node second-step-node-of-first] …) () + [((_ _) + (b_Street b_second-step-Street21-of-first)) + (begin + (displayln #'a_Street) + (displayln #'b_Street) + (displayln (free-identifier=? #'a_Street #'b_Street)))])]) (define/with-syntax replt (replace-in-type #'(Let (id-~> second-step-marker2-expander) i-ty) @@ -317,7 +347,7 @@ recursively: @chunk[ [second-step-mapping/node-of-first ;; from - (inline-type result-type (mapping/node . seen)) ;; to + (inline-type result-type (mapping/node . seen)) ;; to (name/first-step #:? mapping/node) ;; pred? (λ ([x : second-step-mapping/node-of-first]) ;; fun ((inline-instance* result-type (mapping/node . seen)) @@ -347,6 +377,11 @@ layer of actual nodes. We do this in three steps: @item{Finally, we replace the placeholders with the second-pass nodes returned by the graph.}] +@CHUNK[ + (inline-instance-top1* root/field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ()) + …] + @CHUNK[ (define-constructor mapping/node-index #:private @@ -357,9 +392,19 @@ layer of actual nodes. We do this in three steps: … (define-type top1-accumulator-type - (pairof Index ;; max - (list (listof (name/first-step node)) - …)))] + (Pairof Index ;; max + (List (Listof (Pairof mapping/node-index (name/first-step node))) ;; AListof + …))) + + (define-type-expander (second-step-marker2-top-expander stx) + (syntax-parse stx + [(_ (~datum mapping)) + (syntax-local-introduce + #'(U second-step-mapping/node-of-first + result-type))] + … + ;; TODO: should fall-back to outer definition of ~>, if any? + ))] @CHUNK[ (define-syntax (inline-instance-top1* stx) @@ -367,12 +412,28 @@ layer of actual nodes. We do this in three steps: ("inline-instance-top1*" stx) (syntax-parse stx [(_ i-ty seen) + #;(syntax-case (expand-type #'(Let + (~> + second-step-marker2-top-expander) + (~> m-streets))) () + [(a_U + a_second-step-m-streets19/node-of-first + (a_Listof a_Street)) + (syntax-case #'([node second-step-node-of-first] …) () + [((_ _) + (b_Street b_second-step-Street21-of-first)) + (begin + (displayln #'a_Street) + (displayln #'b_Street) + (displayln (free-identifier=? #'a_Street #'b_Street)))])]) + (displayln (list "~~~norepl=" #'(Let (id-~> second-step-marker2-top-expander) + i-ty))) (define/with-syntax replt - (replace-in-type #'(Let (id-~> second-step-marker2-expander) + (replace-in-type #'(Let (id-~> second-step-marker2-top-expander) i-ty) #'([node second-step-node-of-first] …))) - (displayln (list "replt=" #'replt)) + (displayln (list "replt-top=" #'replt)) #'(inline-instance-top1 replt seen)]))) (define-syntax (inline-instance-top1 stx) @@ -389,13 +450,16 @@ layer of actual nodes. We do this in three steps: @chunk[ [second-step-mapping/node-of-first ;; from - (inline-type result-type (mapping/node . seen)) ;; to + Any;(inline-type result-type (mapping/node . seen)) ;; to (name/first-step #:? mapping/node) ;; pred? (λ ([x : second-step-mapping/node-of-first] ;; fun [acc : top1-accumulator-type]) - (values ((inline-instance-top1* result-type (mapping/node . seen)) - (get x returned)) - ACC))] + (% inlined new-acc + = ((inline-instance-top1* result-type (mapping/node . seen)) + (get x returned) + acc) + in + (values inlined new-acc)))] …] @chunk[ @@ -408,11 +472,13 @@ layer of actual nodes. We do this in three steps: : (values mapping/node-index-marker top1-accumulator-type) (% (idx . (node/accumulator …)) = acc - + new-index = (mapping/node-index idx) in - (values PLACEHOLDER - (cons (add1 idx) - (NEW-NDS …)))))] + (values new-index + (let ([node/accumulator (cons (cons new-index x) + node/accumulator)]) + (cons (assert (add1 idx) index?) + (list node/accumulator …))))))] …] @chunk[ @@ -666,7 +732,8 @@ encapsulating the result types of mappings. "rewrite-type.lp2.rkt" #|debug|# syntax/id-set racket/format - mischief/transform) + mischief/transform + (submod "../type-expander/type-expander.lp2.rkt" expander)) (rename-in "../lib/low.rkt" [~> threading:~>]) "graph.lp2.rkt" "get.lp2.rkt" @@ -689,11 +756,11 @@ encapsulating the result types of mappings. (begin-for-syntax (define-syntax-rule (dbg log . body) (begin - ;(display ">>> ")(displayln (list . log)) + (display ">>> ")(displayln (list . log)) (let ((res (let () . body))) - ;(display "<<< ")(displayln (list . log)) - ;(display "<<<= ")(display (car (list . log))) - ;(display res)(displayln ".") + (display "<<< ")(displayln (list . log)) + (display "<<<= ")(display (car (list . log))) + (display res)(displayln ".") res)))) )] diff --git a/graph-lib/graph/rewrite-type.scrbl b/graph-lib/graph/rewrite-type.scrbl index a194c6fe..172865b8 100644 --- a/graph-lib/graph/rewrite-type.scrbl +++ b/graph-lib/graph/rewrite-type.scrbl @@ -1,5 +1,7 @@ #lang scribble/manual +@(require scribble-enhanced/manual-form) + @(require (for-label typed/racket/base "rewrite-type.lp2.rkt")) @@ -10,80 +12,84 @@ type with other types, and generating conversion functions transforming instances of the old type into instances of the new type. -@defform[#:kind "template metafunction" - (tmpl-fold-instance old-type - accumulator-type - [from to pred? fun] …) - #:contracts ([old-type type] - [accumulator-type type] - [from identifier?] - [to type] - [pred? predicate?] - [fun (→ from acc (values to acc))])]{ - Produces the syntax for a function from @racket[old-type] - to the new type, using the provided replacement functions - for each part.} - - -@defform[#:kind "template metafunction" - (tmpl-replace-in-instance old-type - [from to pred? fun] …) - #:contracts ([old-type type] - [accumulator-type type] - [from identifier?] - [to type] - [pred? predicate?] - [fun (→ from to)])]{ - Produces the syntax for a function from @racket[old-type] - to the new type, using the provided replacement functions - for each part.} - @defform[#:kind "procedure" - (replace-in-type old-type #'([from to] …)) - #:contracts ([old-type type] - [from identifier?] - [to type])]{ - This type-level function produces the syntax for the type - @racket[old-type], with all occurrences of @racket[from] - replaced with @racket[to] in the type.} + (replace-in-type old-type + #'([from to] …)) + #:result (syntax-for type) + #:contracts ([old-type (syntax-for type)] + [from (and/c identifier? (syntax-for type))] + [to (syntax-for type)])]{ + This type-level function produces the syntax for the + @racket[new-type]. The @racket[new-type] has the same shape + as the @racket[old-type], except all occurrences of the + @racket[from] type (which must be just a single identifier) + replaced with the @racket[to] type in the type. + + The @racket[replace-in-type] type-level function first + expands any @racketmodname[type-expander]s, and performs + the replacements on the expanded type.} -@defform[#:kind "procedure" - (replace-in-instance old-type #'([from to pred? fun] …)) - #:contracts ([old-type type] - [from identifier?] - [to type] - [pred? predicate?] - [fun (→ from to)])]{ - Produces the syntax for the syntax for a function from - @racket[old-type] to the new type, transforming all parts - of the data structure which satisfy @racket[pred?] using - @racket[fun]. @racket[pred?] should return true if and only - if the data pased as an argument is an instance of the - @racket[from] type. @racket[fun] should accept instances of - the @racket[from] type, and return instances of the +@deftogether[ + (@defform[#:kind "procedure" + (replace-in-instance old-type + #'([from to pred? fun] …)) + #:result (syntax-for (→ old-type new-type))] + @defform[#:kind "template metafunction" + (tmpl-replace-in-instance old-type + [from to pred? fun] …) + #:result (syntax-for (→ old-type new-type)) + #:contracts ([old-type (syntax-for type)] + [from (and/c identifier? (syntax-for type))] + [to (syntax-for type)] + [pred? (syntax-for predicate?)] + [fun (syntax-for (→ from to))])])]{ + Produces the syntax for the syntax for a function from the + @racket[old-type] to the @racket[new-type], transforming + all parts of the data structure which satisfy + @racket[pred?] using @racket[fun]. The @racket[new-type] + will be the same as the one that would be returned by + @racket[(replace-in-type old-type #'([from to] …))] + + @racket[pred?] should return true if and only if the data + passed as an argument is an instance of the @racket[from] + type. @racket[fun] should accept instances of the + @racket[from] type, and return instances of the + @racket[to] type. +} + +@deftogether[ + (@defform[#:kind "procedure" + (fold-instance old-type + accumulator-type + ([from to pred? fun] …)) + #:result (syntax-for + (→ old-type (Values new-type accumulator-type)))] + @defform[#:kind "template metafunction" + (tmpl-fold-instance old-type accumulator-type + [from to pred? fun] …) + #:result (syntax-for + (→ old-type (Values new-type accumulator-type))) + #:contracts ([old-type (syntax-for type)] + [accumulator-type (syntax-for type)] + [from (and/c identifier? (syntax-for type))] + [to (syntax-for type)] + [pred? (syntax-for predicate?)] + [fun (syntax-for (→ from acc (Values to acc)))])])]{ + Produces the syntax for the syntax for a function from the + @racket[old-type] to the @racket[new-type], transforming + all parts of the data structure which satisfy + @racket[pred?] using @racket[fun]. The @racket[new-type] + will be the same as the one that would be returned by + @racket[(replace-in-type old-type #'([from to] …))] + + The generated function takes as a second argument an + initial value for the accumulator. The accumulator is + passed to @racket[fun] and the one returned is used as the + accumulator for the next call. No guarantee is made on the + order of traversal. + + @racket[pred?] should return true if and only if the data + passed as an argument is an instance of the @racket[from] + type. @racket[fun] should accept instances of the + @racket[from] type, and return instances of the @racket[to] type.} - -@defform[#:kind "procedure" - (fold-instance old-type - accumulator-type - #'([from to pred? fun] …)) - #:contracts ([old-type type] - [accumulator-type type] - [from identifier?] - [to type] - [pred? predicate?] - [fun (→ from acc (values to acc))])]{ - Produces the syntax for the syntax for a function from - @racket[old-type] to the new type, transforming all parts - of the data structure which satisfy @racket[pred?] using - @racket[fun]. The generated function takes as a second - argument an initial value for the accumulator. The - accumulator is passed to @racket[fun] and the one returned - is used as the accumulator for the next call. No guarantee - is made on the order of traversal. - - @racket[pred?] should return true if and only - if the data pased as an argument is an instance of the - @racket[from] type. @racket[fun] should accept instances of - the @racket[from] type, and return instances of the - @racket[to] type.} \ No newline at end of file