diff --git a/graph-lib/graph/__DEBUG_graph6.2.rkt b/graph-lib/graph/__DEBUG_graph6.2.rkt new file mode 100644 index 0000000..432ec33 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6.2.rkt @@ -0,0 +1,38 @@ +#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)]]) \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index 0e15d65..530f7d7 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -1,7 +1,7 @@ #lang typed/racket (require "graph-6-rich-returns.lp2.rkt" - "../lib/low.rkt" + (except-in "../lib/low.rkt" ~>) "graph.lp2.rkt" "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt" @@ -12,6 +12,7 @@ "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)) @@ -23,6 +24,96 @@ + + + + + + + + + + + + + + +(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 ([City [streets : (~> m-streets)]] [Street [sname : String]]) @@ -35,6 +126,18 @@ : (Listof Street) (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"))) @@ -339,3 +442,4 @@ (map Street snames)))))))) ;(blah) +|# \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6E.rkt b/graph-lib/graph/__DEBUG_graph6E.rkt new file mode 100644 index 0000000..40a6254 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6E.rkt @@ -0,0 +1,39 @@ +#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) + +|# \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6EB.rkt b/graph-lib/graph/__DEBUG_graph6EB.rkt new file mode 100644 index 0000000..5e7f5b1 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6EB.rkt @@ -0,0 +1,41 @@ +#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) \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6F.rkt b/graph-lib/graph/__DEBUG_graph6F.rkt new file mode 100644 index 0000000..fc983be --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6F.rkt @@ -0,0 +1,37 @@ +#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)) diff --git a/graph-lib/graph/__DEBUG_graph6G-req.rkt b/graph-lib/graph/__DEBUG_graph6G-req.rkt new file mode 100644 index 0000000..70d3a90 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6G-req.rkt @@ -0,0 +1,29 @@ +#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 + )) \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6G.rkt b/graph-lib/graph/__DEBUG_graph6G.rkt new file mode 100644 index 0000000..1c91804 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6G.rkt @@ -0,0 +1,33 @@ +#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))) diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index e4a5708..6d862c7 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -55,6 +55,9 @@ mapping declarations from the node definitions: @chunk[ (define-graph/rich-return name:id + (~or (~seq #:definitions extra-definitions) + (~seq #:wrapping-definitions wrapping-extra-definitions) + (~seq)) ((~commit [node:id …]) …) (~commit ) @@ -104,22 +107,31 @@ plain list. (define-temp-ids "first-step-expander2" name) (define-temp-ids "~a/simple-mapping" (node …)) (define-temp-ids "~a/node" (mapping …)) - (define/with-syntax ~>-id (datum->syntax #'name '~>)) - (template - ;(debug - (begin - (define-graph first-step - #:definitions [] - [node [field c (Let [~>-id first-step-expander2] field-type)] … - [(node/simple-mapping [field c field-type] …) - ;] …) - (node field …)]] … - [mapping/node [returned cm result-type] - [(mapping [param cp param-type] …) - (mapping/node - (let ([node node/simple-mapping] …) - . body))]] - …))))] + ;(define/with-syntax ~>-id #'~>);(datum->syntax #'name '~>)) + ;(define/with-syntax ~>-id-inner (syntax-local-introduce #'~>)) + (quasitemplate + (debug + (begin + (define-graph first-step + ; . #,((make-syntax-delta-introducer #'~> #'name) + ; (syntax-local-introduce + ; #'( + #:wrapping-definitions (begin ) + ;. #,(syntax-local-introduce + ; #'( + [node [field c (Let [~> first-step-expander2] field-type)] … ;; ~>-id-inner + [(node/simple-mapping [field c field-type] …) + ;] …) + (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 of nodes will allow placeholders for the temporary nodes @@ -128,7 +140,34 @@ encapsulating the result types of mappings. @chunk[ ;; TODO: to avoid conflicting definitions of ~>, we should either use ;; 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 [(_ (~datum mapping)) ;; TODO: should be ~literal (template @@ -139,6 +178,7 @@ encapsulating the result types of mappings. … ;; 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 @@ -147,7 +187,13 @@ encapsulating the result types of mappings. ;; TODO: should fall-back to outer definition of ~>, if any. ) #;(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 @; type-expander. @@ -179,9 +225,10 @@ encapsulating the result types of mappings. "meta-struct.rkt"; debug racket/stxparam racket/splicing) - (provide define-graph/rich-return); ~>) - - ;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>)) + (provide define-graph/rich-return ~>) + + (define-rename-transformer-parameter ~> + (make-rename-transformer #'threading:~>)) (require (for-syntax racket/pretty)) (define-syntax (debug stx) @@ -190,116 +237,6 @@ encapsulating the result types of mappings. ;; syntax->string (pretty-print (syntax->datum #'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))))))) - - - - - - )] diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 42019bb..b6ba31e 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -156,7 +156,9 @@ flexible through wrapper macros. (define-graph . (~and main-args ))] @chunk[ (name (~optional (~and debug #:debug)) - (~maybe #:definitions (extra-definition:expr …)) + (~or (~seq #:definitions extra-definitions) + (~seq #:wrapping-definitions wrapping-extra-definitions) + (~seq)) [node … ] …)] @@ -345,12 +347,31 @@ extra definitions, and a call to the second step macro: … [node node/make-incomplete] …) - (?? (begin extra-definition …)) - )] + (?? + (?@ (?? extra-definitions) + )))] + +When the user gave @tc[#:wrapping-definitions] instead of @tc[#:definitions], we +use syntax-parameterize to enable the @tc[(define-graph-rest)] form. + +@chunk[ + (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]) + ])]);)])]) + wrapping-extra-definitions)] The first step macro is defined as follows: @chunk[ + (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 (debug-template debug @@ -769,6 +790,7 @@ We will be able to use this type expander in function types, for example: "../lib/low-untyped.rkt" "meta-struct.rkt") racket/splicing + racket/stxparam "fold-queues.lp2.rkt" "rewrite-type.lp2.rkt" "../lib/low.rkt" @@ -778,10 +800,7 @@ We will be able to use this type expander in function types, for example: "../type-expander/multi-id.lp2.rkt" "meta-struct.rkt") - ;(begin-for-syntax - ;) - - (provide define-graph) + (provide define-graph define-graph-rest) )]