Georges Dupéron
parent
51b7571d2b
commit
094fb14b00
|
|
@ -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,100 @@
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(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-let-syntax
|
||||
([~> (make-rename-transformer #'first-step-expander1)])
|
||||
(define-graph-rest))
|
||||
#;(splicing-syntax-parameterize
|
||||
((~> (make-rename-transformer #'first-step-expander1)))
|
||||
(define-graph-rest)))
|
||||
(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 +130,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 +446,4 @@
|
|||
(map Street snames))))))))
|
||||
|
||||
;(blah)
|
||||
|#
|
||||
|
|
@ -55,6 +55,9 @@ mapping declarations from the node definitions:
|
|||
|
||||
@chunk[<signature>
|
||||
(define-graph/rich-return name:id
|
||||
(~or (~seq #:definitions extra-definitions)
|
||||
(~seq #:wrapping-definitions wrapping-extra-definitions)
|
||||
(~seq))
|
||||
((~commit [node:id <field-signature> …])
|
||||
…)
|
||||
(~commit <mapping-declaration>)
|
||||
|
|
@ -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 [<first-pass-type-expander>]
|
||||
[node [field c (Let [~>-id first-step-expander2] field-type)] …
|
||||
[(node/simple-mapping [field c field-type] …)
|
||||
;<first-pass-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 <first-pass-type-expander>)
|
||||
;. #,(syntax-local-introduce
|
||||
; #'(
|
||||
[node [field c (Let [~> first-step-expander2] field-type)] … ;; ~>-id-inner
|
||||
[(node/simple-mapping [field c field-type] …)
|
||||
;<first-pass-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[<first-pass-type-expander>
|
||||
;; 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)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
<graph-rich-return>)]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user