From f2a43904b5ed760cfd3fefa7621a08dc126ee764 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 3 Apr 2016 17:13:13 +0200 Subject: [PATCH] Part 1 of inline-instance-top (with correct return type) --- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 104 ++++++++----------- graph-lib/lib/low/list.rkt | 5 +- 2 files changed, 50 insertions(+), 59 deletions(-) diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index 39b62b2e..e7bc65f2 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -109,7 +109,6 @@ 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) @@ -219,7 +218,7 @@ 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 @@ -290,6 +289,7 @@ identifier, so that it can be matched against by ]] …)) + ] @@ -313,20 +313,6 @@ 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) @@ -346,19 +332,19 @@ recursively: ))])))] @chunk[ - [second-step-mapping/node-of-first ;; from - (inline-type result-type (mapping/node . seen)) ;; to - (name/first-step #:? mapping/node) ;; pred? - (λ ([x : second-step-mapping/node-of-first]) ;; fun + [second-step-mapping/node-of-first ;; from + (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)) (get x returned)))] …] @chunk[ - [second-step-node-of-first ;; node of first step ;; from - (name #:placeholder node) ;; new type ;; to - (name/first-step #:? node) ;; pred? - node/extract/mapping] ;; call mapping ;; fun + [second-step-node-of-first ;; node of first step ;; from + (name #:placeholder node) ;; new type ;; to + (name/first-step #:? node) ;; pred? + node/extract/mapping] ;; call mapping ;; fun …] @subsection{Inlining instances, at the top} @@ -378,7 +364,7 @@ layer of actual nodes. We do this in three steps: second-pass nodes returned by the graph.}] @CHUNK[ - (inline-instance-top1* root/field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (inline-instance-top1* result-type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ()) …] @@ -393,9 +379,9 @@ layer of actual nodes. We do this in three steps: (define-type top1-accumulator-type (Pairof Index ;; max - (List (Listof (Pairof mapping/node-index (name/first-step node))) ;; AListof + (List (AListof mapping/node-index (name/first-step node)) …))) - + (define-type-expander (second-step-marker2-top-expander stx) (syntax-parse stx [(_ (~datum mapping)) @@ -412,22 +398,6 @@ 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-top-expander) i-ty) @@ -450,7 +420,7 @@ layer of actual nodes. We do this in three steps: @chunk[ [second-step-mapping/node-of-first ;; from - Any;(inline-type result-type (mapping/node . seen)) ;; to + (inline-type-top1 result-type (mapping/node . seen)) ;; to (name/first-step #:? mapping/node) ;; pred? (λ ([x : second-step-mapping/node-of-first] ;; fun [acc : top1-accumulator-type]) @@ -463,11 +433,10 @@ layer of actual nodes. We do this in three steps: …] @chunk[ - [second-step-node-of-first ;; node of first step ;; from - mapping/node-index-marker ;; new type ;; to - (name/first-step #:? node) ;; pred? - ;node/extract/mapping] ;; call mapping ;; fun - (λ ([x : second-step-node-of-first] + [second-step-node-of-first ;; node of first step ;; from + mapping/node-index-marker ;; new type ;; to + (name/first-step #:? node) ;; pred? + (λ ([x : second-step-node-of-first] ;; record the old node ;; fun [acc : top1-accumulator-type]) : (values mapping/node-index-marker top1-accumulator-type) @@ -481,6 +450,28 @@ layer of actual nodes. We do this in three steps: (list node/accumulator …))))))] …] +@chunk[ + (define-type-expander (inline-type-top1 stx) + (dbg + ("inline-type-top1" stx) + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) + #'( + ))])))] + + +@chunk[ + [second-step-mapping/node-of-first ;; from + (inline-type-top1 result-type (mapping/node . seen))] ;; to + …] + +@chunk[ + [node ;second-step-node-of-first ;; generated by the first pass + mapping/node-index] ;; new type + …] + @chunk[ ;; Call the second step graph constructor: (name #:roots (ann (cdr LAST-ACCUMULATOR) @@ -488,10 +479,10 @@ layer of actual nodes. We do this in three steps: @chunk[ (replace-in-instance #'TYPE?? - #'([mapping/node-index ;; from - (name node) ;; to - mapping/node-index? ;; pred? - (λ ([idx : mapping/node-index]) ;; fun + #'([mapping/node-index ;; from + (name node) ;; to + mapping/node-index? ;; pred? + (λ ([idx : mapping/node-index]) ;; fun (VECTOR-REF ??? (constructor-values idx))) ]))] @@ -732,8 +723,7 @@ encapsulating the result types of mappings. "rewrite-type.lp2.rkt" #|debug|# syntax/id-set racket/format - mischief/transform - (submod "../type-expander/type-expander.lp2.rkt" expander)) + mischief/transform) (rename-in "../lib/low.rkt" [~> threading:~>]) "graph.lp2.rkt" "get.lp2.rkt" @@ -747,9 +737,7 @@ encapsulating the result types of mappings. racket/splicing) (provide define-graph/rich-return (for-syntax dbg) ;; DEBUG - ); ~>) - - ;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>)) + ) (require (for-syntax racket/pretty)) diff --git a/graph-lib/lib/low/list.rkt b/graph-lib/lib/low/list.rkt index ebbdbf27..fa2b7eda 100644 --- a/graph-lib/lib/low/list.rkt +++ b/graph-lib/lib/low/list.rkt @@ -3,7 +3,10 @@ (define-typed/untyped-modules #:no-test (provide indexof replace-first - map+fold) + map+fold + AListof) + + (define-type (AListof K V) (Listof (Pairof K V))) (: indexof (∀ (A B) (→ A (Listof B) (→ A B Any) (U #f Integer)))) (define (indexof elt lst [compare equal?])