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

Part 3 of inline-instance-top works!

Browse Source
This commit is contained in:
Georges Dupéron 2016-04-04 15:44:52 +02:00
parent d175d154c3
commit cd150cf2b3
3 changed files with 75 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

333
graph-lib/graph/__DEBUG_graph6.rkt
View File

@ -14,6 +14,7 @@
(for-syntax syntax/parse)
(for-syntax syntax/parse/experimental/template))
#|
(require "__DEBUG_graph6B.rkt")
@ -50,7 +51,10 @@
: (Listof Street)
(map Street snames)])
;(grr3 '(("a" "b") ("c")))
(% (x y) = ((car DBG) '(("a" "b" "c") ("d")))
in
(list (get x streets … sname)
(get y streets … sname)))
#;(super-define-graph/rich-return
grr4
@ -84,330 +88,3 @@
(dg grra)
|#
;; DEBUG:
(require (for-syntax racket/format
"rewrite-type.lp2.rkt"
racket/syntax
syntax/parse
(submod "../lib/low.rkt" untyped))
(for-syntax syntax/parse
syntax/parse/experimental/template
racket/syntax
(submod "../lib/low.rkt" untyped)
"rewrite-type.lp2.rkt" #|debug|#
syntax/id-set
racket/format
mischief/transform)
(rename-in "../lib/low.rkt" [~> threading:~>])
"graph.lp2.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt"
"adt.lp2.rkt" ; debug
"fold-queues.lp2.rkt"; debug
"rewrite-type.lp2.rkt"; debug
"meta-struct.rkt"; debug
racket/stxparam
racket/splicing)
#;(define-graph
grr31/first-step
#:definitions
((define-type-expander
(~> stx)
(syntax-parse
stx
((_ (~datum m-cities))
(template
(U
(grr31/first-step
#:placeholder
m-cities4/node)
(Listof
(grr31/first-step
#:placeholder
City)))))
((_ (~datum m-streets))
(template
(U
(grr31/first-step
#:placeholder
m-streets5/node)
(Listof
(grr31/first-step
#:placeholder
Street)))))))
(define-type-expander
(first-step-expander2 stx)
(syntax-parse
stx
((_ (~datum m-cities))
#'(U
m-cities4/node
(Listof City)))
((_ (~datum m-streets))
#'(U
m-streets5/node
(Listof Street))))))
(City
(streets
:
(Let
(~> first-step-expander2)
(~> m-streets)))
((City2/simple-mapping
(streets
:
(~> m-streets)))
(City streets)))
(Street
(sname
:
(Let
(~> first-step-expander2)
String))
((Street3/simple-mapping
(sname : String))
(Street sname)))
(m-cities4/node
(returned : (Listof City))
((m-cities
(cnames
:
(Listof
(Listof bubble))))
(m-cities4/node
(let ((City
City2/simple-mapping)
(Street
Street3/simple-mapping))
(define (strings→city
(s
:
(Listof
blob)))
(City (m-streets s)))
(map
strings→city
cnames)))))
(m-streets5/node
(returned
:
(Listof Street))
((m-streets
(snames
:
(Listof String)))
(m-streets5/node
(let ((City
City2/simple-mapping)
(Street
Street3/simple-mapping))
(map
Street
snames))))))
#;(define-graph
grr3
#:definitions
((define-type-expander
(~>-to-result-type stx)
(syntax-parse
stx
((_ (~datum m-cities)) #'(Listof City))
((_ (~datum m-streets)) #'(Listof Street))))
(define-type
m-cities10/node-marker
(Listof (grr3 #:placeholder City));
#;(U (grr31/first-step m-cities4/node) (Listof (grr31/first-step City))))
(define-type
m-streets11/node-marker
(Listof (grr3 #:placeholder Street));
#;(U (grr31/first-step m-streets5/node) (Listof (grr31/first-step Street))))
(define-type-expander
(second-step-marker-expander stx)
(syntax-parse
stx
((_ (~datum m-cities)) #'m-cities10/node-marker)
((_ (~datum m-streets)) #'m-streets11/node-marker)))
(define-type
second-step-m-cities16/node-of-first
(grr31/first-step m-cities4/node))
(define-type
second-step-m-streets17/node-of-first
(grr31/first-step m-streets5/node))
(define-type second-step-City18-of-first (grr31/first-step City))
(define-type second-step-Street19-of-first (grr31/first-step Street))
(define-type-expander
(second-step-marker2-expander stx)
(syntax-parse
stx
((_ (~datum m-cities))
#'(U
second-step-m-cities16/node-of-first
(Listof City #;(grr31/first-step City))))
((_ (~datum m-streets))
#'(U
second-step-m-streets17/node-of-first
(Listof Street #;(grr31/first-step Street)))))) ;;;;;;;;;SHOULD BE A MARKER! (done here)
(define-type-expander
(inline-type* stx)
(dbg
("inline-type*" stx)
(syntax-parse
stx
((_ i-tyy (~and seen (:id …)) (~optional msg))
(when (attribute msg) (displayln (syntax-e #'msg)))
(define/with-syntax replt #'i-tyy)
#'(inline-type replt seen)))))
(define-type-expander
(inline-type stx)
(dbg
("inline-type" stx)
(syntax-parse
stx
((_ i-t (~and seen (:id …)))
(let ((seen-list (syntax->list #'seen)))
(when (and
(not (null? seen-list))
(member (car seen-list) (cdr seen-list) free-identifier=?))
(raise-syntax-error
'define-graph/rich-returns
(~a
"Cycles in types are not allowed."
" The following types were already inlined: "
(syntax->datum #'seen)
", but "
#'t
" appeared a second time.")
#'t)))
(replace-in-type
#'(Let ((~> second-step-marker-expander)) i-t)
#'((second-step-m-cities16/node-of-first
(inline-type* (Listof City) (m-cities4/node . seen)))
(second-step-m-streets17/node-of-first
(inline-type* (Listof Street) (m-streets5/node . seen)))
(City (grr3 #:placeholder City))
(Street (grr3 #:placeholder Street))))))))
(define-syntax (inline-instance* stx)
(dbg
("inline-instance*" stx)
(syntax-parse
stx
((_ i-ty seen)
(define/with-syntax
replt
(replace-in-type
#'(Let (~> second-step-marker2-expander) i-ty)
#'((City second-step-City18-of-first)
(Street second-step-Street19-of-first))))
(displayln (list "replt=" #'replt))
#'(inline-instance replt seen)))))
(define-syntax (inline-instance stx)
(dbg
("inline-instance" stx)
(syntax-parse
stx
((_ i-t (~and seen (:id …)))
(define/with-syntax typp #'i-t)
(define/with-syntax
repl
(replace-in-instance
#'typp
#'((second-step-m-cities16/node-of-first
(inline-type* (Listof City) (m-cities4/node . seen) "RESSSS")
(grr31/first-step #:? m-cities4/node)
(λ ((x : second-step-m-cities16/node-of-first))
((inline-instance* (Listof City) (m-cities4/node . seen))
(get x returned))))
(second-step-m-streets17/node-of-first
(inline-type* (Listof Street) (m-streets5/node . seen) "RESSSS")
(grr31/first-step #:? m-streets5/node)
(λ ((x : second-step-m-streets17/node-of-first))
((inline-instance* (Listof Street) (m-streets5/node . seen))
(get x returned))))
(second-step-City18-of-first
(grr3 #:placeholder City)
(grr31/first-step #:? City)
City6/extract/mapping)
(second-step-Street19-of-first
(grr3 #:placeholder Street)
(grr31/first-step #:? Street)
Street7/extract/mapping))))
(displayln (list "i-t=" #'typp))
(let ((seen-list (syntax->list #'seen)))
(when (and
(not (null? seen-list))
(member (car seen-list) (cdr seen-list) free-identifier=?))
(raise-syntax-error
'define-graph/rich-returns
(~a
"Cycles in types are not allowed."
" The following types were already inlined: "
(syntax->datum #'seen)
", but "
#'t
" appeared a second time.")
#'t)))
#'repl)))))
(City
(streets : (Let (~> ~>-to-result-type) (~> m-streets)))
((City6/extract/mapping (from : (grr31/first-step City)))
(City ((inline-instance* (~> m-streets) ())
#;(λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))
(first-value
((λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))) (acc : Void))
:
(values m-streets11/node-marker ;(U (inline-type* (Listof Street) (m-streets5/node) "RE1234")
; (Listof (grr31/first-step Street)))
Void)
(cond
(((grr31/first-step #:? m-streets5/node) val)
((ann
(λ ((x : second-step-m-streets17/node-of-first) (acc : Void))
(values ((λ ((x : second-step-m-streets17/node-of-first)) ((inline-instance* (Listof Street) (m-streets5/node)) (get x returned))) x) acc))
(→ second-step-m-streets17/node-of-first Void (values (inline-type* (Listof Street) (m-streets5/node) "RESSSS") Void)))
val
acc))
(#t
((λ ((val : (Listof (grr31/first-step Street))) (acc : Void))
:
(values m-streets11/node-marker ;(Listof (grr31/first-step Street))
Void)
(let ((f
((inst foldl (grr31/first-step Street) (Pairof (Listof (grr31/first-step Street)) Void) Nothing Nothing)
(λ ((x : (grr31/first-step Street))
(acc1 : (Pairof m-streets11/node-marker;(Listof (grr31/first-step Street))
Void)))
(let-values (((res res-acc) ((inst values (grr31/first-step Street) Void) x (cdr acc1))))
(cons (cons res (car acc1)) res-acc)))
(cons '() acc)
val)))
(values (reverse (car f)) (cdr f))))
val
acc))
(else
(typecheck-fail
(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))
"Unhandled union case in (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))), whole type was:(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))"))))
val
(void))))
(get from streets)))
))
(Street
(sname : (Let (~> ~>-to-result-type) String))
((Street7/extract/mapping (from : (grr31/first-step Street)))
(Street ((inline-instance* String ()) (get from sname))))))

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

@ -114,6 +114,8 @@ plain list.
(define-temp-ids "top1-accumulator-type" name)
(define-temp-ids "~a/constructor-top2" (mapping …))
(define-temp-ids "~a/accumulator" (node …))
(define-temp-ids "~a/top2-roots" (node …))
(define-temp-ids "~a/next-idx" (node …))
(define-temp-ids "~a/simple-mapping" (node …))
(define-temp-ids "~a/node" (mapping …))
(define-temp-ids "~a/extract/mapping" (node …))
@ -294,7 +296,8 @@ identifier, so that it can be matched against by
<inline-instance-top1-types>
<inline-instance-top1>
<outer-inline>
<inline-instance-top2>]
<inline-instance-top2>
<inline-instance-top3>]
We create the inlined-node by inlining the temporary nodes
in all of its fields:
@ -330,8 +333,8 @@ recursively:
[(_ i-t (~and seen (:id (… …))))
<inline-check-seen>
(replace-in-instance #'i-t
#'(<inline-instance-replacement>
<inline-instance-nodes>))])))]
#'(<inline-instance-replacement>
<inline-instance-nodes>))])))]
@chunk[<inline-instance-replacement>
[second-step-mapping/node-of-first ;; from
@ -380,9 +383,9 @@ layer of actual nodes. We do this in three steps:
…
(define-type top1-accumulator-type
(Pairof Index ;; max
(List (AListof mapping/node-index (name/first-step node))
…)))
(List (Pairof Index ;; max
(AListof mapping/node-index (name/first-step node)))
…))
(define-type-expander (second-step-marker2-top-expander stx)
(syntax-parse stx
@ -442,14 +445,14 @@ layer of actual nodes. We do this in three steps:
[acc : top1-accumulator-type])
: (values mapping/node-index-marker
top1-accumulator-type)
(% (idx . (node/accumulator …)) = acc
new-index = (mapping/node-index idx)
(% ([node/next-idx . node/accumulator] …) = acc
new-index = (mapping/node-index node/next-idx)
in
(values new-index
(let ([node/accumulator (cons (cons new-index x)
node/accumulator)])
(cons (assert (add1 idx) index?)
(list node/accumulator …))))))]
node/accumulator)]
[node/next-idx (assert (add1 node/next-idx) index?)])
(list (cons node/next-idx node/accumulator) …)))))]
…]
@chunk[<inline-type-top1>
@ -471,7 +474,7 @@ layer of actual nodes. We do this in three steps:
@chunk[<inline-type-top1-nodes>
[node ;second-step-node-of-first ;; generated by the first pass
mapping/node-index] ;; new type
mapping/node-index-marker] ;; new type
…]
@chunk[<inline-instance-top2>
@ -484,65 +487,65 @@ layer of actual nodes. We do this in three steps:
@chunk[<constructor-top2-body>
first-graph = (name/first-step #:root mapping/node param …)
alists = (list (!each mapping '()) …)
alists = (list (!each mapping '[0 . ()]) …)
with-indices-top1 last-acc = ((inline-instance-top1* result-type ())
(get first-graph returned)
(cons 1 alists))
(_ . (node/accumulator …)) = last-acc
alists)
([node/next-idx . node/accumulator] …) = last-acc
in
(assert (= (length node/accumulator) node/next-idx))
;; Call the second step graph constructor:
(name #:roots [node (lists (cdrs node/accumulator))] …)]
(% (node/top2-roots …)
= (name #:roots [node (reverse (lists (cdrs node/accumulator)))] …)
in
((replace-markers-top3 result-type
node/top2-roots …)
with-indices-top1))]
@chunk[<inline-instance-top3>
(replace-in-instance #'TYPE??
#'([mapping/node-index ;; from
(name node) ;; to
mapping/node-index? ;; pred?
(λ ([idx : mapping/node-index]) ;; fun
(VECTOR-REF ??? (constructor-values idx)))
]))]
@(begin #|
@CHUNK[<inline-instance-top3>
(define-syntax (inline-instance-top3* stx)
(define-syntax (replace-markers-top3 stx)
(dbg
("inline-instance-top3*" stx)
(syntax-parse stx
[(_ i-ty seen)
(define/with-syntax replt
(replace-in-type #'(Let (id-~> second-step-marker2-expander)
i-ty)
#'([node second-step-node-of-first]
…)))
(displayln (list "replt=" #'replt))
#'(inline-instance-top3 replt seen)])))
[(_ i-ty node/top2-roots …)
(displayln (replace-in-type #'(inline-type-top1 i-ty ())
#'[]))
(replace-in-instance #'(inline-type-top1 i-ty ())
#'([mapping/node-index-marker ;; from
(name node) ;; to
mapping/node-index? ;; pred?
(λ ([idx : mapping/node-index]) ;; fun
(vector-ref node/top2-roots
(constructor-values idx)))]
…))])))
#;(define-syntax (inline-instance-top3* stx)
(dbg
("inline-instance-top3*" stx)
(syntax-parse stx
[(_ i-ty seen node/top2-roots …)
(define/with-syntax replt
(replace-in-type #'(Let (id-~> second-step-marker2-top-expander)
i-ty)
#'([node second-step-node-of-first]
…)))
(displayln (list "replt-top=" #'replt))
#'(inline-instance-top3 replt seen node/top2-roots …)])))
(define-syntax (inline-instance-top3 stx)
(dbg
("inline-instance-top3" stx)
(syntax-parse stx
[(_ i-t (~and seen (:id (… …))))
<inline-check-seen>
(replace-in-instance #'i-t
#'(<inline-instance-top3-replacement>
<inline-instance-top3-nodes>))])))]
@chunk[<inline-instance-top3-replacement>
[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-top3* result-type (mapping/node . seen))
(get x returned)))]
…]
@chunk[<inline-instance-top3-nodes>
[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
…]
|#)
#;(define-syntax (inline-instance-top3 stx)
(dbg
("inline-instance-top3" stx)
(syntax-parse stx
[(_ i-t (~and seen (:id (… …))) node/top2-roots …)
<inline-check-seen>
;(replace-in-instance #'i-t
(replace-in-instance #'i-t
#'([mapping/node-index-marker ;; from
(name node) ;; to
mapping/node-index? ;; pred?
(λ ([idx : mapping/node-index]) ;; fun
(vector-ref node/top2-roots
(constructor-values idx)))]
…))])))]
@subsection{Inlining types}

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

@ -96,18 +96,12 @@
(define (format-temp-ids format . vs)
;; Introduce the binding in a fresh scope.
(apply format-ids (λ _ ((make-syntax-introducer) #'())) format vs))
;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
(begin-for-syntax
(define (syntax-cons-property stx key v)
(let ([orig (syntax-property stx key)])
(syntax-property stx key (cons v (or orig '()))))))
;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
(begin-for-syntax
(define (identifier-length id) (string-length (symbol->string
(syntax-e id)))))
(apply format-ids
(λ _ ((make-syntax-introducer) (if (syntax? format) format #'())))
format
vs))
(require (for-syntax (submod "stx.rkt" untyped)))
(begin-for-syntax
(define-syntax-class dotted