Revert "Problem on expansion step 10086 in __DEBUG_graph6.2.rkt : clicking on City9/make-placeholder-type:14 shows that it hasn't the same scopes afterwards.". Now at commit 876c4d2 Fixed most bugs related to ~> type expander.
This reverts commit 56fdfaeb8f.
This commit is contained in:
Georges Dupéron
parent
9d68e98882
commit
ada994beb9
|
|
@ -1,38 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require ;"graph-6-rich-returns.lp2.rkt"
|
|
||||||
(except-in "../lib/low.rkt" ~>)
|
|
||||||
"graph.lp2.rkt"
|
|
||||||
"get.lp2.rkt"
|
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
|
||||||
"structure.lp2.rkt" ; debug
|
|
||||||
"variant.lp2.rkt" ; debug
|
|
||||||
"fold-queues.lp2.rkt"; debug
|
|
||||||
"rewrite-type.lp2.rkt"; debug
|
|
||||||
"meta-struct.rkt"; debug
|
|
||||||
racket/splicing; debug
|
|
||||||
racket/stxparam; debug
|
|
||||||
(for-syntax syntax/parse)
|
|
||||||
(for-syntax syntax/parse/experimental/template))
|
|
||||||
|
|
||||||
(define-graph gr
|
|
||||||
#:wrapping-definitions (begin (define-graph-rest))
|
|
||||||
[City [streets : (Listof Street)] [people : (Listof Person)]
|
|
||||||
[(m-city [c : (Listof (Pairof String String))])
|
|
||||||
(City (remove-duplicates (map (curry m-street c) (cdrs c)))
|
|
||||||
(remove-duplicates (map m-person (cars c))))]]
|
|
||||||
[Street [sname : String] [houses : (Listof House)]
|
|
||||||
[(m-street [c : (Listof (Pairof String String))] [s : String])
|
|
||||||
(Street s (map (curry (curry m-house s) c)
|
|
||||||
(cars (filter (λ ([x : (Pairof String String)])
|
|
||||||
(equal? (cdr x) s))
|
|
||||||
c))))]]
|
|
||||||
[House [owner : Person] [location : Street]
|
|
||||||
[(m-house [s : String]
|
|
||||||
[c : (Listof (Pairof String String))]
|
|
||||||
[p : String])
|
|
||||||
(House (m-person p) (m-street c s))]]
|
|
||||||
[Person [name : String]
|
|
||||||
[(m-person [p : String])
|
|
||||||
(Person p)]])
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
#lang typed/racket
|
#lang typed/racket
|
||||||
|
|
||||||
(require "graph-6-rich-returns.lp2.rkt"
|
(require "graph-6-rich-returns.lp2.rkt"
|
||||||
(except-in "../lib/low.rkt" ~>)
|
"../lib/low.rkt"
|
||||||
"graph.lp2.rkt"
|
"graph.lp2.rkt"
|
||||||
"get.lp2.rkt"
|
"get.lp2.rkt"
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
"../type-expander/type-expander.lp2.rkt"
|
||||||
|
|
@ -12,7 +12,6 @@
|
||||||
"rewrite-type.lp2.rkt"; debug
|
"rewrite-type.lp2.rkt"; debug
|
||||||
"meta-struct.rkt"; debug
|
"meta-struct.rkt"; debug
|
||||||
racket/splicing; debug
|
racket/splicing; debug
|
||||||
racket/stxparam; debug
|
|
||||||
(for-syntax syntax/parse)
|
(for-syntax syntax/parse)
|
||||||
(for-syntax syntax/parse/experimental/template))
|
(for-syntax syntax/parse/experimental/template))
|
||||||
|
|
||||||
|
|
@ -24,96 +23,6 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-rename-transformer-parameter ~>
|
|
||||||
(make-rename-transformer #'+))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(begin
|
|
||||||
(define-graph
|
|
||||||
first-step
|
|
||||||
#:wrapping-definitions
|
|
||||||
(begin
|
|
||||||
(define-type-expander
|
|
||||||
(first-step-expander1 stx)
|
|
||||||
#'Number
|
|
||||||
#;(syntax-parse
|
|
||||||
stx
|
|
||||||
((_ (~datum m-cities))
|
|
||||||
(template
|
|
||||||
(U
|
|
||||||
(first-step #:placeholder m-cities3/node)
|
|
||||||
(Listof (first-step #:placeholder City)))))
|
|
||||||
((_ (~datum m-streets))
|
|
||||||
(template
|
|
||||||
(U
|
|
||||||
(first-step #:placeholder m-streets4/node)
|
|
||||||
(Listof (first-step #:placeholder Street)))))))
|
|
||||||
(define-type-expander
|
|
||||||
(first-step-expander2 stx)
|
|
||||||
#'Number
|
|
||||||
#;(syntax-parse
|
|
||||||
stx
|
|
||||||
((_ (~datum m-cities)) #'(U m-cities3/node (Listof City)))
|
|
||||||
((_ (~datum m-streets)) #'(U m-streets4/node (Listof Street)))))
|
|
||||||
(splicing-syntax-parameterize
|
|
||||||
((~> (make-rename-transformer #'first-step-expander1)))))
|
|
||||||
(City
|
|
||||||
(streets : (Let (~> first-step-expander2) (~> m-streets)))
|
|
||||||
((City1/simple-mapping (streets : (~> m-streets))) (City streets)))
|
|
||||||
(Street
|
|
||||||
(sname : (Let (~> first-step-expander2) String))
|
|
||||||
((Street2/simple-mapping (sname : String)) (Street sname)))
|
|
||||||
(m-cities3/node
|
|
||||||
(returned : (Listof City))
|
|
||||||
((m-cities (cnames : (Listof (Listof String))))
|
|
||||||
(m-cities3/node
|
|
||||||
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
|
||||||
(define (strings→city (s : (Listof String))) (City (m-streets s)))
|
|
||||||
(map strings→city cnames)))))
|
|
||||||
(m-streets4/node
|
|
||||||
(returned : (Listof Street))
|
|
||||||
((m-streets (snames : (Listof String)))
|
|
||||||
(m-streets4/node
|
|
||||||
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
|
||||||
(map Street snames)))))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#|
|
|
||||||
(define-graph/rich-return grr
|
(define-graph/rich-return grr
|
||||||
([City [streets : (~> m-streets)]]
|
([City [streets : (~> m-streets)]]
|
||||||
[Street [sname : String]])
|
[Street [sname : String]])
|
||||||
|
|
@ -126,18 +35,6 @@
|
||||||
: (Listof Street)
|
: (Listof Street)
|
||||||
(map Street snames)])
|
(map Street snames)])
|
||||||
|
|
||||||
#;(define-graph/rich-return grra
|
|
||||||
([City [streets : (~> m-streets)]]
|
|
||||||
[Street [sname : String]])
|
|
||||||
[(m-cities [cnames : (Listof (Listof String))])
|
|
||||||
: (Listof City)
|
|
||||||
(define (strings→city [s : (Listof String)])
|
|
||||||
(City (m-streets s)))
|
|
||||||
(map strings→city cnames)]
|
|
||||||
[(m-streets [snames : (Listof String)])
|
|
||||||
: (Listof Street)
|
|
||||||
(map Street snames)])
|
|
||||||
|
|
||||||
|
|
||||||
;(first-step '(("a" "b") ("c" "d")))
|
;(first-step '(("a" "b") ("c" "d")))
|
||||||
|
|
||||||
|
|
@ -442,4 +339,3 @@
|
||||||
(map Street snames))))))))
|
(map Street snames))))))))
|
||||||
|
|
||||||
;(blah)
|
;(blah)
|
||||||
|#
|
|
||||||
|
|
@ -1,39 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(module m typed/racket
|
|
||||||
(define-syntax (m1 stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ (_ (e) _) b)
|
|
||||||
(begin (displayln (free-identifier=? #'e #'b))
|
|
||||||
#'(void))]))
|
|
||||||
|
|
||||||
(define-syntax (frozen stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ def b)
|
|
||||||
#`(begin def ;#,(datum->syntax #'a (syntax->datum #'(define def val)))
|
|
||||||
(m1 def b))]))
|
|
||||||
|
|
||||||
(define-syntax (goo stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ b)
|
|
||||||
;(begin (define i1 (make-syntax-delta-introducer #'te #'b))
|
|
||||||
; (define i2 (make-syntax-delta-introducer #'b #'te))
|
|
||||||
#`(frozen (define (te) 1)
|
|
||||||
#,(syntax-local-introduce #'b))]))
|
|
||||||
|
|
||||||
(provide goo))
|
|
||||||
|
|
||||||
(require 'm)
|
|
||||||
|
|
||||||
(goo te)
|
|
||||||
|
|
||||||
#|
|
|
||||||
|
|
||||||
(define-syntax (lake stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ val a)
|
|
||||||
#`(let ((#,(datum->syntax stx 'tea) val)) a)]))
|
|
||||||
|
|
||||||
(lake 3 tea)
|
|
||||||
|
|
||||||
|#
|
|
||||||
|
|
@ -1,41 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require #|"graph-6-rich-returns.lp2.rkt"
|
|
||||||
"../lib/low.rkt"
|
|
||||||
"graph.lp2.rkt"
|
|
||||||
"get.lp2.rkt"
|
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
|
||||||
(for-syntax (submod "../type-expander/type-expander.lp2.rkt" expander))
|
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
|
||||||
"structure.lp2.rkt" ; debug
|
|
||||||
"variant.lp2.rkt" ; debug
|
|
||||||
"fold-queues.lp2.rkt"; debug
|
|
||||||
"rewrite-type.lp2.rkt"; debug
|
|
||||||
"meta-struct.rkt"; debug
|
|
||||||
"../lib/debug-syntax.rkt"
|
|
||||||
racket/splicing|#
|
|
||||||
(for-syntax syntax/parse)
|
|
||||||
(for-syntax syntax/parse/experimental/template))
|
|
||||||
|
|
||||||
;(syntax-local-lift-expression #`(browse-syntaxes (list #'e #'b)))
|
|
||||||
(define-syntax (d-exp stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (_ (e) _) b)
|
|
||||||
(displayln (free-identifier=? #'e #'b))
|
|
||||||
#'(void)]))
|
|
||||||
|
|
||||||
(define-syntax (frozen stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ def b)
|
|
||||||
#`(begin def ;#,(datum->syntax #'a (syntax->datum #'(define def val)))
|
|
||||||
(d-exp def b))]))
|
|
||||||
|
|
||||||
(define-syntax (goo stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ b)
|
|
||||||
(define i1 (make-syntax-delta-introducer #'te #'b))
|
|
||||||
(define i2 (make-syntax-delta-introducer #'b #'te))
|
|
||||||
#`(frozen (define (#,(i2 #'te)) 1)
|
|
||||||
#,(i1 #'b))]))
|
|
||||||
|
|
||||||
(provide goo)
|
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
#lang racket
|
|
||||||
|
|
||||||
(module m racket
|
|
||||||
(require macro-debugger/syntax-browser)
|
|
||||||
(define-syntax (m1 stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ sol (su sv) m2-id user-id i-user-id a f r aa ff rr)
|
|
||||||
(syntax-local-lift-expression
|
|
||||||
#`(browse-syntaxes
|
|
||||||
(list #'sol #'m2-id #'user-id #'i-user-id #'a #'f #'r #'aa #'ff #'rr)))
|
|
||||||
#`(cons (list (su) sv) #,(free-identifier=? #'m2-id #'sol))]))
|
|
||||||
|
|
||||||
(define-syntax (m2 stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ user-id val)
|
|
||||||
#`(begin
|
|
||||||
(define (foo) 1)
|
|
||||||
(m1
|
|
||||||
;#,((make-syntax-delta-introducer #'foo #'user-id) (syntax-local-introduce #'user-id) 'add)
|
|
||||||
#,((make-syntax-delta-introducer #'foo stx) (syntax-local-introduce #'user-id) 'add)
|
|
||||||
#,((make-syntax-delta-introducer #'foo stx) (syntax-local-introduce #'(user-id val)) 'add)
|
|
||||||
foo
|
|
||||||
user-id
|
|
||||||
#,(syntax-local-introduce #'user-id)
|
|
||||||
#,((make-syntax-delta-introducer #'foo #'user-id) #'user-id 'add)
|
|
||||||
#,((make-syntax-delta-introducer #'foo #'user-id) #'user-id 'flip)
|
|
||||||
#,((make-syntax-delta-introducer #'foo #'user-id) #'user-id 'remove)
|
|
||||||
#,((make-syntax-delta-introducer #'user-id #'foo) #'user-id 'add)
|
|
||||||
#,((make-syntax-delta-introducer #'user-id #'foo) #'user-id 'flip)
|
|
||||||
#,((make-syntax-delta-introducer #'user-id #'foo) #'user-id 'remove)))]))
|
|
||||||
|
|
||||||
(provide m2))(require 'm)
|
|
||||||
|
|
||||||
(let ((y 1))
|
|
||||||
(m2 foo y))
|
|
||||||
(let ((y 2))
|
|
||||||
(m2 foo y))
|
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require "graph-6-rich-returns.lp2.rkt"
|
|
||||||
"../lib/low.rkt"
|
|
||||||
"graph.lp2.rkt"
|
|
||||||
"get.lp2.rkt"
|
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
|
||||||
"structure.lp2.rkt" ; debug
|
|
||||||
"variant.lp2.rkt" ; debug
|
|
||||||
"fold-queues.lp2.rkt"; debug
|
|
||||||
"rewrite-type.lp2.rkt"; debug
|
|
||||||
"meta-struct.rkt"; debug
|
|
||||||
racket/splicing; debug
|
|
||||||
)
|
|
||||||
|
|
||||||
(provide (all-from-out "graph-6-rich-returns.lp2.rkt"
|
|
||||||
"../lib/low.rkt"
|
|
||||||
"graph.lp2.rkt"
|
|
||||||
"get.lp2.rkt"
|
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
|
||||||
"structure.lp2.rkt" ; debug
|
|
||||||
"variant.lp2.rkt" ; debug
|
|
||||||
"fold-queues.lp2.rkt"; debug
|
|
||||||
"rewrite-type.lp2.rkt"; debug
|
|
||||||
"meta-struct.rkt"; debug
|
|
||||||
racket/splicing; debug
|
|
||||||
))
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require "__DEBUG_graph6G-req.rkt")
|
|
||||||
|
|
||||||
(module m typed/racket
|
|
||||||
(require "__DEBUG_graph6G-req.rkt"
|
|
||||||
macro-debugger/syntax-browser
|
|
||||||
(for-syntax syntax/parse)
|
|
||||||
(for-syntax syntax/parse/experimental/template))
|
|
||||||
|
|
||||||
(define-syntax (m1 stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ m2-id (~and code (_ _ (~and (~datum foo) su))))
|
|
||||||
#`(begin code
|
|
||||||
#,(free-identifier=? #'m2-id #'su))]))
|
|
||||||
|
|
||||||
(define-syntax (rich-graph stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ user-code)
|
|
||||||
(define i (make-syntax-introducer))
|
|
||||||
|
|
||||||
#`(begin
|
|
||||||
#,(i #'(define-type-expander (foo stx) #'Number))
|
|
||||||
(m1 foo #,(i #'user-code)))]))
|
|
||||||
|
|
||||||
(provide rich-graph))
|
|
||||||
|
|
||||||
(require 'm)
|
|
||||||
|
|
||||||
(let ((y 1))
|
|
||||||
(rich-graph (ann y foo)))
|
|
||||||
(let ((y 2))
|
|
||||||
(rich-graph (ann y foo)))
|
|
||||||
|
|
@ -55,9 +55,6 @@ mapping declarations from the node definitions:
|
||||||
|
|
||||||
@chunk[<signature>
|
@chunk[<signature>
|
||||||
(define-graph/rich-return name:id
|
(define-graph/rich-return name:id
|
||||||
(~or (~seq #:definitions extra-definitions)
|
|
||||||
(~seq #:wrapping-definitions wrapping-extra-definitions)
|
|
||||||
(~seq))
|
|
||||||
((~commit [node:id <field-signature> …])
|
((~commit [node:id <field-signature> …])
|
||||||
…)
|
…)
|
||||||
(~commit <mapping-declaration>)
|
(~commit <mapping-declaration>)
|
||||||
|
|
@ -107,31 +104,22 @@ plain list.
|
||||||
(define-temp-ids "first-step-expander2" name)
|
(define-temp-ids "first-step-expander2" name)
|
||||||
(define-temp-ids "~a/simple-mapping" (node …))
|
(define-temp-ids "~a/simple-mapping" (node …))
|
||||||
(define-temp-ids "~a/node" (mapping …))
|
(define-temp-ids "~a/node" (mapping …))
|
||||||
;(define/with-syntax ~>-id #'~>);(datum->syntax #'name '~>))
|
(define/with-syntax ~>-id (datum->syntax #'name '~>))
|
||||||
;(define/with-syntax ~>-id-inner (syntax-local-introduce #'~>))
|
(template
|
||||||
(quasitemplate
|
;(debug
|
||||||
(debug
|
(begin
|
||||||
(begin
|
(define-graph first-step
|
||||||
(define-graph first-step
|
#:definitions [<first-pass-type-expander>]
|
||||||
; . #,((make-syntax-delta-introducer #'~> #'name)
|
[node [field c (Let [~>-id first-step-expander2] field-type)] …
|
||||||
; (syntax-local-introduce
|
[(node/simple-mapping [field c field-type] …)
|
||||||
; #'(
|
;<first-pass-field-type>] …)
|
||||||
#:wrapping-definitions (begin <first-pass-type-expander>)
|
(node field …)]] …
|
||||||
;. #,(syntax-local-introduce
|
[mapping/node [returned cm result-type]
|
||||||
; #'(
|
[(mapping [param cp param-type] …)
|
||||||
[node [field c (Let [~> first-step-expander2] field-type)] … ;; ~>-id-inner
|
(mapping/node
|
||||||
[(node/simple-mapping [field c field-type] …)
|
(let ([node node/simple-mapping] …)
|
||||||
;<first-pass-field-type>] …)
|
. body))]]
|
||||||
(node field …)]]
|
…))))]
|
||||||
…
|
|
||||||
[mapping/node [returned cm result-type]
|
|
||||||
[(mapping [param cp param-type] …)
|
|
||||||
(mapping/node
|
|
||||||
(let ([node node/simple-mapping] …)
|
|
||||||
. body))]]
|
|
||||||
…
|
|
||||||
;)) 'add)
|
|
||||||
)))))]
|
|
||||||
|
|
||||||
As explained above, during the first pass, the field types
|
As explained above, during the first pass, the field types
|
||||||
of nodes will allow placeholders for the temporary nodes
|
of nodes will allow placeholders for the temporary nodes
|
||||||
|
|
@ -140,34 +128,7 @@ encapsulating the result types of mappings.
|
||||||
@chunk[<first-pass-type-expander>
|
@chunk[<first-pass-type-expander>
|
||||||
;; TODO: to avoid conflicting definitions of ~>, we should either use
|
;; TODO: to avoid conflicting definitions of ~>, we should either use
|
||||||
;; syntax-parameterize, or make a #:local-definitions
|
;; syntax-parameterize, or make a #:local-definitions
|
||||||
#;(define-type-expander (~>-id stx)
|
(define-type-expander (~>-id stx)
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
|
||||||
(template
|
|
||||||
(U (first-step #:placeholder mapping/node)
|
|
||||||
(tmpl-replace-in-type result-type
|
|
||||||
[node (first-step #:placeholder node)]
|
|
||||||
…)))]
|
|
||||||
…
|
|
||||||
;; TODO: should fall-back to outer definition of ~>, if any.
|
|
||||||
))
|
|
||||||
#;(define-type-expander (first-step-expander2 stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
|
||||||
#'(U mapping/node result-type)]
|
|
||||||
…
|
|
||||||
;; TODO: should fall-back to outer definition of ~>, if any.
|
|
||||||
)
|
|
||||||
#;(U (first-step #:placeholder m-streets4/node)
|
|
||||||
(Listof (first-step #:placeholder Street))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-type-expander (first-step-expander1 stx)
|
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
||||||
(template
|
(template
|
||||||
|
|
@ -178,7 +139,6 @@ encapsulating the result types of mappings.
|
||||||
…
|
…
|
||||||
;; TODO: should fall-back to outer definition of ~>, if any.
|
;; TODO: should fall-back to outer definition of ~>, if any.
|
||||||
))
|
))
|
||||||
|
|
||||||
(define-type-expander (first-step-expander2 stx)
|
(define-type-expander (first-step-expander2 stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
||||||
|
|
@ -187,13 +147,7 @@ encapsulating the result types of mappings.
|
||||||
;; TODO: should fall-back to outer definition of ~>, if any.
|
;; TODO: should fall-back to outer definition of ~>, if any.
|
||||||
)
|
)
|
||||||
#;(U (first-step #:placeholder m-streets4/node)
|
#;(U (first-step #:placeholder m-streets4/node)
|
||||||
(Listof (first-step #:placeholder Street))))
|
(Listof (first-step #:placeholder Street))))]
|
||||||
|
|
||||||
(splicing-syntax-parameterize ([~> (make-rename-transformer
|
|
||||||
#'first-step-expander1)])
|
|
||||||
(?? wrapping-extra-definitions
|
|
||||||
(?? (?@ extra-definitions
|
|
||||||
(define-graph-rest)))))]
|
|
||||||
|
|
||||||
@; TODO: replace-in-type doesn't work wfell here, we need to define a
|
@; TODO: replace-in-type doesn't work wfell here, we need to define a
|
||||||
@; type-expander.
|
@; type-expander.
|
||||||
|
|
@ -225,10 +179,9 @@ encapsulating the result types of mappings.
|
||||||
"meta-struct.rkt"; debug
|
"meta-struct.rkt"; debug
|
||||||
racket/stxparam
|
racket/stxparam
|
||||||
racket/splicing)
|
racket/splicing)
|
||||||
(provide define-graph/rich-return ~>)
|
(provide define-graph/rich-return); ~>)
|
||||||
|
|
||||||
(define-rename-transformer-parameter ~>
|
;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>))
|
||||||
(make-rename-transformer #'threading:~>))
|
|
||||||
|
|
||||||
(require (for-syntax racket/pretty))
|
(require (for-syntax racket/pretty))
|
||||||
(define-syntax (debug stx)
|
(define-syntax (debug stx)
|
||||||
|
|
@ -237,6 +190,116 @@ encapsulating the result types of mappings.
|
||||||
;; syntax->string
|
;; syntax->string
|
||||||
(pretty-print (syntax->datum #'body))
|
(pretty-print (syntax->datum #'body))
|
||||||
#'body]))
|
#'body]))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#;(begin
|
||||||
|
(define-graph
|
||||||
|
first-step
|
||||||
|
#:definitions
|
||||||
|
((define-type-expander
|
||||||
|
(~> stx)
|
||||||
|
(syntax-parse
|
||||||
|
stx
|
||||||
|
((_ (~datum m-cities))
|
||||||
|
(template
|
||||||
|
(U
|
||||||
|
(first-step #:placeholder m-cities3/node)
|
||||||
|
(Listof (first-step #:placeholder City)))))
|
||||||
|
((_ (~datum m-streets))
|
||||||
|
(template
|
||||||
|
(U
|
||||||
|
(first-step #:placeholder m-streets4/node)
|
||||||
|
(Listof (first-step #:placeholder Street)))))))
|
||||||
|
(define-type-expander
|
||||||
|
(first-step-expander2 stx)
|
||||||
|
(syntax-parse
|
||||||
|
stx
|
||||||
|
((_ (~literal m-cities))
|
||||||
|
(template
|
||||||
|
(U m-streets4/node (Listof Street))))
|
||||||
|
((_ (~literal m-streets))
|
||||||
|
(template
|
||||||
|
(U m-streets4/node (Listof Street)))))))
|
||||||
|
(City
|
||||||
|
(streets : (Let [~> first-step-expander2] (~> m-streets))#;(~> m-streets))
|
||||||
|
((City1/simple-mapping (streets : (~> m-streets))) (City streets)))
|
||||||
|
(Street
|
||||||
|
(sname : String)
|
||||||
|
((Street2/simple-mapping (sname : String)) (Street sname)))
|
||||||
|
(m-cities3/node
|
||||||
|
(returned : (Listof City))
|
||||||
|
((m-cities (cnames : (Listof (Listof String))))
|
||||||
|
(m-cities3/node
|
||||||
|
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
||||||
|
(define (strings→city (s : (Listof String))) (City (m-streets s)))
|
||||||
|
(map strings→city cnames)))))
|
||||||
|
(m-streets4/node
|
||||||
|
(returned : (Listof Street))
|
||||||
|
((m-streets (snames : (Listof String)))
|
||||||
|
(m-streets4/node
|
||||||
|
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
||||||
|
(map Street snames)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#;(begin
|
||||||
|
(define-graph
|
||||||
|
first-step
|
||||||
|
#:definitions
|
||||||
|
((define-type-expander
|
||||||
|
(~> stx)
|
||||||
|
(syntax-parse
|
||||||
|
stx
|
||||||
|
((_ (~datum m-cities))
|
||||||
|
(template
|
||||||
|
(U
|
||||||
|
(first-step #:placeholder m-cities3/node)
|
||||||
|
(Listof (first-step #:placeholder City)))))
|
||||||
|
((_ (~datum m-streets))
|
||||||
|
(template
|
||||||
|
(U
|
||||||
|
(first-step #:placeholder m-streets4/node)
|
||||||
|
(Listof (first-step #:placeholder Street)))))))
|
||||||
|
(define-type-expander
|
||||||
|
(first-step-expander2 stx)
|
||||||
|
(syntax-parse
|
||||||
|
stx
|
||||||
|
((_ (~datum m-cities)) #'(U m-cities3/node (Listof City)))
|
||||||
|
((_ (~datum m-streets)) #'(U m-streets4/node (Listof Street))))))
|
||||||
|
(City
|
||||||
|
(streets : (Let (~> first-step-expander2) (~> m-streets)))
|
||||||
|
((City1/simple-mapping (streets : (~> m-streets))) (City streets)))
|
||||||
|
(Street
|
||||||
|
(sname : (Let (~> first-step-expander2) String))
|
||||||
|
((Street2/simple-mapping (sname : String)) (Street sname)))
|
||||||
|
(m-cities3/node
|
||||||
|
(returned : (Listof City))
|
||||||
|
((m-cities (cnames : (Listof (Listof String))))
|
||||||
|
(m-cities3/node
|
||||||
|
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
||||||
|
(define (strings→city (s : (Listof String))) (City (m-streets s)))
|
||||||
|
(map strings→city cnames)))))
|
||||||
|
(m-streets4/node
|
||||||
|
(returned : (Listof Street))
|
||||||
|
((m-streets (snames : (Listof String)))
|
||||||
|
(m-streets4/node
|
||||||
|
(let ((City City1/simple-mapping) (Street Street2/simple-mapping))
|
||||||
|
(map Street snames)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
<graph-rich-return>)]
|
<graph-rich-return>)]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -156,9 +156,7 @@ flexible through wrapper macros.
|
||||||
(define-graph . (~and main-args <main-macro-arguments>))]
|
(define-graph . (~and main-args <main-macro-arguments>))]
|
||||||
@chunk[<main-macro-arguments>
|
@chunk[<main-macro-arguments>
|
||||||
(name (~optional (~and debug #:debug))
|
(name (~optional (~and debug #:debug))
|
||||||
(~or (~seq #:definitions extra-definitions)
|
(~maybe #:definitions (extra-definition:expr …))
|
||||||
(~seq #:wrapping-definitions wrapping-extra-definitions)
|
|
||||||
(~seq))
|
|
||||||
[node <field-signature> … <mapping-declaration>]
|
[node <field-signature> … <mapping-declaration>]
|
||||||
…)]
|
…)]
|
||||||
|
|
||||||
|
|
@ -347,31 +345,12 @@ extra definitions, and a call to the second step macro:
|
||||||
…
|
…
|
||||||
[node node/make-incomplete]
|
[node node/make-incomplete]
|
||||||
…)
|
…)
|
||||||
(?? <wrapping-first-step>
|
(?? (begin extra-definition …))
|
||||||
(?@ (?? extra-definitions)
|
<call-second-step>)]
|
||||||
<call-second-step>)))]
|
|
||||||
|
|
||||||
When the user gave @tc[#:wrapping-definitions] instead of @tc[#:definitions], we
|
|
||||||
use syntax-parameterize to enable the @tc[(define-graph-rest)] form.
|
|
||||||
|
|
||||||
@chunk[<wrapping-first-step>
|
|
||||||
(splicing-syntax-parameterize
|
|
||||||
([define-graph-rest
|
|
||||||
(syntax-rules () ;; TODO: indentation bug here in v 6.4.0.8
|
|
||||||
[(_) #';(splicing-syntax-parameterize
|
|
||||||
; ([define-graph-rest default-define-graph-rest])
|
|
||||||
<call-second-step>])]);)])])
|
|
||||||
wrapping-extra-definitions)]
|
|
||||||
|
|
||||||
The first step macro is defined as follows:
|
The first step macro is defined as follows:
|
||||||
|
|
||||||
@chunk[<first-step>
|
@chunk[<first-step>
|
||||||
(define-for-syntax (default-define-graph-rest stx)
|
|
||||||
(raise-syntax-error 'define-graph-rest
|
|
||||||
"can only be used inside define-graph"
|
|
||||||
stx))
|
|
||||||
(define-syntax-parameter define-graph-rest default-define-graph-rest)
|
|
||||||
|
|
||||||
(define-syntax/parse <signature>
|
(define-syntax/parse <signature>
|
||||||
<define-ids/first-step>
|
<define-ids/first-step>
|
||||||
(debug-template debug
|
(debug-template debug
|
||||||
|
|
@ -790,7 +769,6 @@ We will be able to use this type expander in function types, for example:
|
||||||
"../lib/low-untyped.rkt"
|
"../lib/low-untyped.rkt"
|
||||||
"meta-struct.rkt")
|
"meta-struct.rkt")
|
||||||
racket/splicing
|
racket/splicing
|
||||||
racket/stxparam
|
|
||||||
"fold-queues.lp2.rkt"
|
"fold-queues.lp2.rkt"
|
||||||
"rewrite-type.lp2.rkt"
|
"rewrite-type.lp2.rkt"
|
||||||
"../lib/low.rkt"
|
"../lib/low.rkt"
|
||||||
|
|
@ -800,7 +778,10 @@ We will be able to use this type expander in function types, for example:
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
"../type-expander/multi-id.lp2.rkt"
|
||||||
"meta-struct.rkt")
|
"meta-struct.rkt")
|
||||||
|
|
||||||
(provide define-graph define-graph-rest)
|
;(begin-for-syntax
|
||||||
|
;<multiassoc-syntax>)
|
||||||
|
|
||||||
|
(provide define-graph)
|
||||||
<first-step>
|
<first-step>
|
||||||
<second-step>)]
|
<second-step>)]
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user