suzanne.soy/type-expander
1
0
Fork 0
Code Issues 8 Pull Requests Actions Packages Projects Releases Wiki Activity

WIP on rich-returns

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-03 14:10:53 +01:00
parent d38431aa71
commit 8862166793
4 changed files with 242 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -52,7 +52,7 @@
: (Listof Street)
(map Street snames)])
(super-define-graph/rich-return
#;(super-define-graph/rich-return
grr3
([City [streets : (~> m-streets)]]
[Street [sname : String]])

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

@ -55,6 +55,7 @@ mapping declarations from the node definitions:
@chunk[<signature>
(define-graph/rich-return name:id id-~>
(~optional (~and #:debug debug))
((~commit [node:id <field-signature> …])
…)
(~commit <mapping-declaration>)
@ -98,15 +99,19 @@ for the temporary node type which encapsulates the result
of @tc[m-streets], while the latter would normally expect a
plain list.
@chunk[<graph-rich-return>
@CHUNK[<graph-rich-return>
(define-syntax/parse <signature>
(define-temp-ids "first-step" name)
(define-temp-ids "first-step-expander2" name)
(define-temp-ids "~a/simple-mapping" (node …))
(define-temp-ids "~a/node" (mapping …))
(define-temp-ids "~a/extract/mapping" (node …))
(define-temp-ids "~a/extract" (node …) #:first-base root)
(define-temp-ids "~a/node-marker" (mapping …))
(define-temp-ids "~a/from-first-pass" (node …))
;(define/with-syntax id-~> (datum->syntax #'name '~>))
(template
;(debug
<inline-temp-nodes>
(quasitemplate/debug debug
(begin
(define-graph first-step
#:definitions [<first-pass-type-expander>]
@ -119,7 +124,108 @@ plain list.
(mapping/node
(let ([node node/simple-mapping] …)
. body))]]
…))))]
…)
;; TODO: how to return something else than a node??
;; Possibility 1: add a #:main function to define-graph, which can
;; call (make-root).
;; Possibility 2: use the "(name node)" type outside as the return
;; type of functions
(define-graph name
#:definitions [<second-pass-type-expander>]
[node [field c field-type] …
[(node/extract/mapping [from : (first-step node)])
(node (<replace-in-instance> (get from field))
…)
…]]
…)
(begin
(: node/extract (→ (first-step node) root))
(define (node/extract from)
(meta-eval
(#,inline-temp-nodes/instance mapping/result-type
#,(immutable-free-id-set)))))
…
(root/extract (first-step ???)) ;; choice based on #:root argument
)))]
@chunk[<replace-in-instance>
(tmpl-replace-in-instance
(Let ~> second-step-marker-expander field-type)
<second-pass-replace>)]
@chunk[<second-pass-type-expander>
(define-type-expander (id-~> stx)
(syntax-parse stx
;; TODO: should be ~literal
[(_ (~datum mapping)) #'result-type] …
;; TODO: should fall-back to outer definition of ~>, if any?
))
(define-type-expander (second-step-marker-expander stx)
(syntax-parse stx
;; TODO: should be ~literal
[(_ (~datum mapping)) #'mapping/node-marker] …
;; TODO: should fall-back to outer definition of ~>, if any?
))]
@chunk[<second-pass-replace>
[mapping/node-marker
<fully-replaced-mapping/result-type>
(graph #:? mapping/node)
(λ ([m : (first-graph mapping/node)])
(get m val))]
…]
The result of recursively inlining the temporary mapping nodes may be a
recursive type:
@chunk[<example-recursive-inlining>
;; TODO
(m-a : (Listof (~> m-b)) …)
(m-b : (Listof (~> m-a)) …)]
Since we prefer to not deal with infinite recursive structures (they could be
built using @tc[make-reader-graph], but this would not fit well with the rest of
our framework), we do not allow type cycles unless they go through a
user-defined node like @tc[a] or @tc[b] (by opposition to first-pass mapping
nodes like @tc[ma/node] or @tc[mb/node]).
The result type of inlining the temporary mapping nodes can be obtained by
inlining the types in the same way:
@CHUNK[<inline-temp-nodes>
(define (inline-temp-nodes/type t seen)
(quasitemplate
(tmpl-replace-in-type (Let ~> second-step-marker-expander t)
[mapping/node-marker
(meta-eval
(if (free-id-set-member? #,t #,seen)
(raise-syntax-error "Cycle in types!")
(#,inline-temp-nodes/type result-type
#,(free-id-set-add t seen))))]
…)))
(define (inline-temp-nodes/instance t seen)
(quasitemplate
(tmpl-fold-instance (Let ~> second-step-marker-expander t)
[mapping/node-marker
(meta-eval
(#,inline-temp-nodes/type result-type
(free-id-set-add #,t #,seen)))
(first-pass #:? mapping/node)
(if (free-id-set-member? t seen)
(raise-syntax-error "Cycle in types!")
(inline-temp-nodes/instance result-type
(free-id-set-add t seen)))]
…
[node/from-first-pass
(name #:placeholder node) ; new type
(first-pass #:? node)
node] ;; call constructor
…)))]
----------------------
As explained above, during the first pass, the field types
of nodes will allow placeholders for the temporary nodes
@ -134,8 +240,8 @@ encapsulating the result types of mappings.
(template
(U (first-step #:placeholder mapping/node)
(tmpl-replace-in-type result-type
[node (first-step #:placeholder node)]
…)))]
[node (first-step #:placeholder node)]
…)))]
…
;; TODO: should fall-back to outer definition of ~>, if any.
))
@ -147,13 +253,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))))]
@; TODO: replace-in-type doesn't work wfell here, we need to define a
@; type-expander.
@chunk[<first-pass-field-type>
(tmpl-replace-in-type field-type
[(~> mapping) (U mapping/node result-type)] …)]
[(~> mapping) (U mapping/node result-type)] …)]
@section{Conclusion}
@ -163,7 +269,8 @@ encapsulating the result types of mappings.
syntax/parse/experimental/template
racket/syntax
(submod "../lib/low.rkt" untyped)
"rewrite-type.lp2.rkt" #|debug|#)
"rewrite-type.lp2.rkt" #|debug|#
syntax/id-set)
(rename-in "../lib/low.rkt" [~> threading:~>])
"graph.lp2.rkt"
"get.lp2.rkt"
@ -177,126 +284,10 @@ encapsulating the result types of mappings.
racket/stxparam
racket/splicing)
(provide define-graph/rich-return); ~>)
;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>))
(require (for-syntax racket/pretty))
(define-syntax (debug stx)
(syntax-case stx ()
[(_ body)
;; 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>)]

4
graph-lib/graph/graph.lp2.rkt
View File

@ -202,6 +202,7 @@ We derive identifiers for these based on the @tc[node] name:
@chunk[<define-ids/first-step>
(define-temp-ids "~a/constructor" (node …) #:first-base root)
(define-temp-ids "~a?" (node …))
(define-temp-ids "~a/make-placeholder" (node …))
(define-temp-ids "~a/make-placeholder-type" (node …))
@ -221,6 +222,7 @@ We derive identifiers for these based on the @tc[node] name:
@chunk[<pass-to-second-step>
(node/constructor …)
root/constructor
(node? …)
(node/make-placeholder …)
(node/make-placeholder-type …)
@ -294,6 +296,8 @@ The graph name will be used in several ways:
[(_ #:root (~datum node) . rest)
(syntax/loc stx (node/constructor . rest))]
…
[(_ #:? (~datum node))
(syntax/loc stx node?)]
[(_ . rest)
(syntax/loc stx (root/constructor . rest))]))
#:id (λ (stx) #'root/constructor))]

219
graph-lib/graph/rewrite-type.lp2.rkt
View File

@ -39,9 +39,9 @@ relies on the lower-level utilities provided by this module, namely
#`(begin
(: name (→ type #,(replace-in-type #'type #'([from to] ...))))
(define (name v)
#,(replace-in-instance #'v
#'type
#'([from to pred? fun] ...))))]))]
(#,(replace-in-instance #'type
#'([from to pred? fun] ...))
v)))]))]
@subsection{A bigger example}
@ -88,8 +88,8 @@ calls itself on the components of the type.
(define (recursive-replace new-t) (replace-in-type new-t r))
(define/with-syntax ([from to] ...) r)
#;(displayln (format "~a\n=> ~a"
(syntax->datum t)
(syntax->datum (expand-type t))))
(syntax->datum t)
(syntax->datum (expand-type t))))
(syntax-parse (expand-type t)
#:context #'(replace-in-type t r)
<replace-in-type-substitute>
@ -144,10 +144,12 @@ offloaded to a separate subroutine.
@CHUNK[<replace-in-instance>
(define-for-syntax (replace-in-instance val t r)
(define/with-syntax ([from to fun] ...) r)
<recursive-replace-in-instance>
<replace-in-union>
(recursive-replace val t))]
(parameterize-push-stx ([current-replacement
`(replace-in-instance ,val ,t ,r)])
(define/with-syntax ([from to fun] ...) r)
<recursive-replace-in-instance>
<replace-in-union>
(recursive-replace val t)))]
The @tc[recursive-replace] internal function defined below takes a type
@tc[type] and produces an expression that transforms instances of that type
@ -170,54 +172,57 @@ The other cases are similarly defined:
@CHUNK[<recursive-replace-in-instance>
(define (recursive-replace stx-val type)
(define/with-syntax val stx-val)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type
#:context 'recursive-replace-2
[x:id
#:attr assoc-from-to (cdr-stx-assoc #'x #'((from . (to . fun)) ...))
#:when (attribute assoc-from-to)
#:with (to-type . to-fun) #'assoc-from-to
(define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for to-type in the pattern.
#`(to-fun val)]
[((~literal List) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
#`(let-values ([(tmp ...) (apply values val)])
(list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
<replace-in-instance-case-pairof>
[((~literal Listof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)]
[((~literal Vector) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
(define/with-syntax (idx ...) (generate-indices #'(a ...)))
#`(let ([v-cache val])
(let ([tmp (vector-ref v-cache idx)]
...)
(vector-immutable #,@(stx-map recursive-replace
#'(tmp ...)
#'(a ...)))))]
[((~literal Vectorof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
;; Inst because otherwise it won't widen the inferred mutable vector
;; elements' type.
#`((inst vector->immutable-vector
#,(replace-in-type #'a #'([from to] ...)))
(list->vector
(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
(vector->list val))))]
[((~literal U) a ...)
#`(let ([v-cache val])
(cond
#,@(stx-map (λ (ta)
(replace-in-union #'v-cache ta r))
#'(a ...))))]
[((~literal quote) a)
#'val]
[x:id
#'val]))]
(parameterize-push-stx ([current-replacement
`(recursive-replace ,stx-val ,type)])
(define/with-syntax val stx-val)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type
#:context `(recursive-replace-2 ,(current-replacement))
[x:id
#:attr assoc-from-to (cdr-stx-assoc #'x
#'((from . (to . fun)) ...))
#:when (attribute assoc-from-to)
#:with (to-type . to-fun) #'assoc-from-to
(define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for to-type in the pattern.
#`(to-fun val)]
[((~literal List) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
#`(let-values ([(tmp ...) (apply values val)])
(list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
<replace-in-instance-case-pairof>
[((~literal Listof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)]
[((~literal Vector) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
(define/with-syntax (idx ...) (generate-indices #'(a ...)))
#`(let ([v-cache val])
(let ([tmp (vector-ref v-cache idx)]
...)
(vector-immutable #,@(stx-map recursive-replace
#'(tmp ...)
#'(a ...)))))]
[((~literal Vectorof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
;; Inst because otherwise it won't widen the inferred mutable
;; vector elements' type.
#`((inst vector->immutable-vector
#,(replace-in-type #'a #'([from to] ...)))
(list->vector
(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
(vector->list val))))]
[((~literal U) a ...)
#`(let ([v-cache val])
(cond
#,@(stx-map (λ (ta)
(replace-in-union #'v-cache ta r))
#'(a ...))))]
[((~literal quote) a)
#'val]
[x:id
#'val])))]
For unions, we currently support only tagged unions, that is unions where each
possible type is a @tc[List] with a distinct @tc[tag] in its first element.
@ -227,7 +232,7 @@ TODO: we currently don't check that each @tc[tag] is distinct.
(define (replace-in-union stx-v-cache t r)
(define/with-syntax v-cache stx-v-cache)
(syntax-parse t
#:context 'replace-in-union-3
#:context `(replace-in-union-3 ,(current-replacement))
[((~literal List) ((~literal quote) tag:id) b ...)
<replace-in-tagged-union-instance>]
[_ (raise-syntax-error
@ -395,17 +400,19 @@ functions is undefined.
@CHUNK[<fold-instance>
(define-for-syntax (fold-instance whole-type stx-acc-type r)
(define/with-syntax acc-type stx-acc-type)
(define/with-syntax ([from to pred? fun] ...) r)
<recursive-replace-fold-instance>
(recursive-replace whole-type))]
(parameterize-push-stx ([current-replacement
`(fold-instance ,whole-type ,stx-acc-type ,r)])
(define/with-syntax acc-type stx-acc-type)
(define/with-syntax ([from to pred? fun] ...) r)
<recursive-replace-fold-instance>
(recursive-replace whole-type)))]
@CHUNK[<recursive-replace-fold-instance>
(define (new-type-for stx) (replace-in-type stx #'([from to] ...)))
(define (recursive-replace type)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type
#:context 'recursive-replace-4
(syntax-parse (expand-type type)
#:context `(recursive-replace-4 ,(current-replacement))
[x:id
#:attr assoc-from-to-fun (stx-assoc #'x #'((from to fun) ...))
#:when (attribute assoc-from-to-fun)
@ -518,7 +525,7 @@ functions is undefined.
@CHUNK[<replace-fold-union>
(syntax-parse ta
#:context 'replace-fold-union-5
#:context `(replace-fold-union-5 ,(current-replacement))
[((~literal List) ((~literal quote) tag:id) b ...)
<replace-fold-union-tagged-list>]
[((~literal Pairof) ((~literal quote) tag:id) b)
@ -530,8 +537,8 @@ functions is undefined.
<replace-fold-union-predicate>]
[_
#:when last?
#`[#t ;; Hope type occurrence will manage here.
(#,(recursive-replace ta) val acc)]]
;; Hope type occurrence will manage here.
#`[#t (#,(recursive-replace ta) val acc)]]
[s:id
#:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
(meta-struct? #'s))
@ -569,16 +576,17 @@ better consistency between the behaviour of @tc[replace-in-instance] and
efficient than the separate implementation.
@CHUNK[<replace-in-instance2>
(define-for-syntax (replace-in-instance2 val t r)
(define-for-syntax (replace-in-instance2 t r)
(define/with-syntax ([from to pred? fun] ...) r)
#`(first-value
(#,(fold-instance t
#'Void
#'([from to pred? (λ ([x : from] [acc : Void])
(values (fun x) acc))]
...))
#,val
(void))))]
#`(λ ([val : #,t])
(first-value
(#,(fold-instance t
#'Void
#'([from to pred? (λ ([x : from] [acc : Void])
(values (fun x) acc))]
...))
val
(void)))))]
@section{Conclusion}
@ -590,41 +598,45 @@ one for @tc[replace-in-type]:
@CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-replace-in-type stx)
(syntax-parse stx
#:context 'tmple-replace-in-type-6
[(_ (~optional (~and debug? #:debug)) type:expr [from to] …)
(when (attribute debug?)
(displayln (format "~a" stx)))
(let ([res #`#,(replace-in-type #'type
#'([from to] …))])
(parameterize-push-stx ([current-replacement stx])
(syntax-parse stx
#:context `(tmpl-replace-in-type-6 ,(current-replacement))
[(_ (~optional (~and debug? #:debug)) type:expr [from to] …)
(when (attribute debug?)
(displayln (format "=> ~a" res)))
res)]))]
(displayln (format "~a" stx)))
(let ([res #`#,(replace-in-type #'type
#'([from to] …))])
(when (attribute debug?)
(displayln (format "=> ~a" res)))
res)])))]
And one each for @tc[fold-instance] and @tc[replace-in-instance2]:
@CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-fold-instance stx)
(syntax-parse stx
#:context 'tmpl-fold-instance-7
[(_ type:expr acc-type:expr [from to pred? fun] …)
#`(begin
"fold-instance expanded code below. Initially called with:"
'(fold-instance type acc-type [from to pred? λ…] …)
#,(fold-instance #'type
#'acc-type
#'([from to pred? fun] …)))]))
(parameterize-push-stx ([current-replacement stx])
(syntax-parse stx
#:context `(tmpl-fold-instance-7 ,(current-replacement))
[(_ type:expr acc-type:expr [from to pred? fun] …)
#`(begin
"fold-instance expanded code below. Initially called with:"
'(fold-instance type acc-type [from to pred? λ…] …)
#,(fold-instance #'type
#'acc-type
#'([from to pred? fun] …)))])))
(define-template-metafunction (tmpl-replace-in-instance stx)
(syntax-parse stx
#:context 'tmpl-replace-in-instance-8
[(_ type:expr [from to fun] …)
#`#,(replace-in-instance2 #'type #'([from to fun] …))]))]
(parameterize-push-stx ([current-replacement stx])
(syntax-parse stx
#:context `(tmpl-replace-in-instance-8 ,(current-replacement))
[(_ type:expr [from to pred? fun] …)
#`#,(replace-in-instance2 #'type #'([from to pred? fun] …))]
[_ (error (format "~a" `(tmpl-replace-in-instance-8 ,(continuation-mark-set->context (current-continuation-marks)) ,(syntax->datum (current-replacement)))))])))]
These metafunctions just extract the arguments for @tc[replace-in-type] and
@tc[replace-in-instance2], and pass them to these functions.
@chunk[<*>
@CHUNK[<*>
(begin
(module main typed/racket
(require
@ -651,6 +663,15 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
tmpl-fold-instance
tmpl-replace-in-instance))
(begin-for-syntax
(define current-replacement (make-parameter #'()))
;; TODO: move to lib
(require (for-syntax racket/base))
(define-syntax-rule (parameterize-push ([p val] ...) . body)
(parameterize ([p (cons val (p))] ...) . body))
(define-syntax-rule (parameterize-push-stx ([p val] ...) . body)
(parameterize ([p #`(#,val . #,(p))] ...) . body)))
<replace-in-type>
<replace-in-instance>
<replace-in-instance2>