Debugging define-graph/rich-returns.
This commit is contained in:
Georges Dupéron
parent
e17c026a9d
commit
af5b9bcfea
25
graph-lib/graph/__DEBUG_Let.rkt
Normal file
25
graph-lib/graph/__DEBUG_Let.rkt
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require "../type-expander/type-expander.lp2.rkt"
|
||||
(for-syntax (submod "../type-expander/type-expander.lp2.rkt"
|
||||
expander)))
|
||||
|
||||
(define-syntax (foo stx)
|
||||
(syntax-case stx ()
|
||||
[(_ t)
|
||||
#`(begin
|
||||
(define-type-expander (xp stx)
|
||||
#'Number)
|
||||
(foo2 x t (Let (#,(syntax-local-introduce #'~>) xp) t))
|
||||
(define x 0))]))
|
||||
|
||||
(define-syntax (foo2 stx)
|
||||
(syntax-case stx ()
|
||||
[(_ x t u)
|
||||
(begin
|
||||
(let ((e (expand-type #'u)))
|
||||
(display "expanded:")
|
||||
(displayln e))
|
||||
#'(: x (U u Any)))]))
|
||||
|
||||
(foo (~> String))
|
||||
|
|
@ -53,10 +53,10 @@
|
|||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
|
||||
#|
|
||||
;(grr3 '(("a" "b") ("c")))
|
||||
|
||||
#;(super-define-graph/rich-return
|
||||
grr3
|
||||
grr4
|
||||
([City [streets : (~> m-streets)]]
|
||||
[Street [sname : String]])
|
||||
[(m-cities [cnames : (Listof (Listof bubble))])
|
||||
|
|
@ -86,4 +86,3 @@
|
|||
(dg grr)
|
||||
(dg grra)
|
||||
|#
|
||||
|#
|
||||
|
|
@ -9,10 +9,11 @@
|
|||
|
||||
@section{Introduction}
|
||||
|
||||
We define a wrapper around the @tc[graph] macro, which
|
||||
We build a wrapper around the @tc[graph] macro, which
|
||||
allows defining mappings with rich return types, instead of
|
||||
being forced to return a single node. For example, a mapping
|
||||
can return a list of nodes.
|
||||
can return a list of nodes, instead of having to push the
|
||||
list operations up in the “caller” nodes.
|
||||
|
||||
During the graph construction, however, the user cannot
|
||||
access the contents of these rich values. If this was
|
||||
|
|
@ -43,11 +44,11 @@ To avoid this kind of issue, we will make the mapping
|
|||
functions return opaque values whose contents cannot be
|
||||
inspected during the creation of the graph. This also makes
|
||||
the implementation easier, as we will generate the graph in
|
||||
two phases: first, we will associate a single-field node
|
||||
with each mapping, and use it as their return type. Then, a
|
||||
second pass will break these nodes, and extract their
|
||||
constituents until an actual user-specified node is
|
||||
reached.
|
||||
two phases: first, we will associate a temporary
|
||||
single-field node with each mapping, and use it as their
|
||||
opaque return type. Then, a second pass will inline these
|
||||
temporary nodes, and extract their constituents in-depth
|
||||
until an actual user-specified node is reached.
|
||||
|
||||
Since this implementation also allows serveral mappings to
|
||||
return the same node, the new signature separates the
|
||||
|
|
@ -88,20 +89,27 @@ Here is an example usage of this syntax:
|
|||
[(m-streets [snames : (Listof String)]) : (Listof Street)
|
||||
(map Street snames)])]
|
||||
|
||||
The @tc[(~> m-streets)] type is a special marker which will
|
||||
be expanded to the return type of @tc[m-streets] (namely
|
||||
@tc[(Listof Street)]) in the final graph type. For the first
|
||||
step, however, it will be expanded to
|
||||
@tc[(U (grr #:placeholder m-streets/node) (Listof Street))].
|
||||
@tc[define-graph/rich-return] introduces a new
|
||||
type-expander, @tc[id-~>], which is used as a special marker
|
||||
to denote the return type of a mapping: @tc[(~> some-mapping)]
|
||||
is expanded to the actual return type for @tc[some-mapping].
|
||||
This notation is needed to facilitate the substitution of a
|
||||
mapping's return type by a temporary node.
|
||||
|
||||
@tc[(~> m-streets)] which will be expanded to the return type of
|
||||
@tc[m-streets] (namely @tc[(Listof Street)]) in the final
|
||||
graph type. For the first step, however, it will be expanded
|
||||
to @tc[(U (gr #:placeholder m-streets/node) (Listof Street))].
|
||||
Without this, passing the result of @tc[(m-streets s)] to
|
||||
@tc[City] would be impossible: the former is a placeholder
|
||||
for the temporary node type which encapsulates the result
|
||||
of @tc[m-streets], while the latter would normally expect a
|
||||
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>
|
||||
(define-syntax/parse <signature>
|
||||
(define-temp-ids "first-step" name)
|
||||
(define/with-syntax (node* …) #'(node …))
|
||||
(define-temp-ids "~a/first-step" name)
|
||||
(define-temp-ids "first-step-expander2" name)
|
||||
(define-temp-ids "~a/simple-mapping" (node …))
|
||||
(define-temp-ids "~a/node" (mapping …))
|
||||
|
|
@ -109,12 +117,12 @@ plain list.
|
|||
(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 step2-introducer (make-syntax-introducer))
|
||||
;(define/with-syntax id-~> (datum->syntax #'name '~>))
|
||||
(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
||||
<inline-temp-nodes>
|
||||
;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
||||
(quasitemplate/debug debug
|
||||
(begin
|
||||
(define-graph first-step
|
||||
(define-graph name/first-step
|
||||
#:definitions [<first-pass-type-expander>]
|
||||
[node [field c (Let [id-~> first-step-expander2] field-type)] …
|
||||
[(node/simple-mapping [field c field-type] …)
|
||||
|
|
@ -131,14 +139,8 @@ plain list.
|
|||
;; 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))
|
||||
…)
|
||||
…]]
|
||||
…)
|
||||
<step2>
|
||||
#|
|
||||
(begin
|
||||
(: node/extract (→ (first-step node) root))
|
||||
(define (node/extract from)
|
||||
|
|
@ -147,20 +149,68 @@ plain list.
|
|||
#,(immutable-free-id-set)))))
|
||||
…
|
||||
(root/extract (first-step ???)) ;; choice based on #:root argument
|
||||
)))]
|
||||
|#)))]
|
||||
|
||||
@chunk[<replace-in-instance>
|
||||
(tmpl-replace-in-instance
|
||||
(Let (introduced-~> second-step-marker-expander) field-type)
|
||||
<second-pass-replace>)]
|
||||
When declaring the nodes in the second step, @tc[~>] expands to the actual
|
||||
result type of the user-provided mappings, for example @tc[(Listof Street)]:
|
||||
|
||||
@chunk[<second-pass-type-expander>
|
||||
(define-type-expander (id-~> stx)
|
||||
@chunk[<second-step-~>-expander>
|
||||
(define-type-expander (~>-to-result-type stx)
|
||||
(syntax-parse stx
|
||||
;; TODO: should be ~literal
|
||||
[(_ (~datum mapping)) #'result-type] …
|
||||
;; TODO: should fall-back to outer definition of ~>, if any?
|
||||
))
|
||||
))]
|
||||
|
||||
We define the mapping's body in the second pass as a separate macro, so that
|
||||
when it is expanded, the @tc[second-step-marker-expander] has already been
|
||||
introduced.
|
||||
|
||||
@CHUNK[<pass-2-mapping-body>
|
||||
(define-syntax/parse (pass-2-mapping-body name
|
||||
<pass-2-mapping-body-args>)
|
||||
<inline-temp-nodes>
|
||||
(template
|
||||
(node (<replace-in-instance> (get from field))
|
||||
…)))]
|
||||
|
||||
We need to provide to that staged macro all the identifiers it needs:
|
||||
|
||||
@chunk[<pass-2-mapping-body-args>
|
||||
id-~>
|
||||
second-step-marker-expander
|
||||
first-pass
|
||||
node
|
||||
(node* …)
|
||||
from
|
||||
(field …)
|
||||
(field-type …)
|
||||
(result-type …)
|
||||
(mapping/node-marker …)
|
||||
(mapping/node …)
|
||||
val]
|
||||
|
||||
The goal of these mappings is to inline the temporary nodes, and return a value
|
||||
which does not refer to them anymore:
|
||||
|
||||
@chunk[<replace-in-instance>
|
||||
(!inline-temp-nodes/instance field-type)
|
||||
#;(tmpl-replace-in-instance (Let (id-~> second-step-marker-expander)
|
||||
field-type)
|
||||
<second-pass-replace>)]
|
||||
|
||||
Where @tc[second-step-marker-expander] (in the input type
|
||||
to @tc[replace-in-instance]) expands to the temporary marker
|
||||
produced by the first step.
|
||||
|
||||
@chunk[<second-step-marker-expander>
|
||||
;; TODO: should use Let or replace-in-type, instead of defining the node
|
||||
;; globally like this.
|
||||
(define-type node (name/first-step node))
|
||||
…
|
||||
(define-type mapping/node-marker result-type)
|
||||
…
|
||||
;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-type-expander (second-step-marker-expander stx)
|
||||
(syntax-parse stx
|
||||
;; TODO: should be ~literal
|
||||
|
|
@ -168,14 +218,19 @@ plain list.
|
|||
;; TODO: should fall-back to outer definition of ~>, if any?
|
||||
))]
|
||||
|
||||
Replacing a marker node is as simple as extracting the
|
||||
contents of its single field.
|
||||
|
||||
@chunk[<second-pass-replace>
|
||||
[mapping/node-marker
|
||||
<fully-replaced-mapping/result-type>
|
||||
(graph #:? mapping/node)
|
||||
(λ ([m : (first-graph mapping/node)])
|
||||
(λ ([m : (first-pass mapping/node)])
|
||||
(get m val))]
|
||||
…]
|
||||
|
||||
@subsection{Fully-inlined type}
|
||||
|
||||
The result of recursively inlining the temporary mapping nodes may be a
|
||||
recursive type:
|
||||
|
||||
|
|
@ -184,46 +239,174 @@ recursive type:
|
|||
(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]).
|
||||
Since we prefer to not deal with the possible cyclic data
|
||||
(that could be built using @tc[make-reader-graph]), 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:
|
||||
inlining the types in a way similar to what is done for the instance:
|
||||
|
||||
We replace (using the @tc[~>] syntax expander) the
|
||||
occurrences of @tc[(~> some-mapping)] with a marker
|
||||
identifier, so that it can be matched against by
|
||||
@tc[tmpl-replace-in-instance] and
|
||||
@tc[tmpl-replace-in-type].
|
||||
|
||||
@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))))]
|
||||
…)))
|
||||
(printf ">>> type ~a\n" (syntax->datum #'t))
|
||||
(let ((rslt
|
||||
(quasitemplate
|
||||
(tmpl-replace-in-type (Let (id-~> second-step-marker-expander) #,t)
|
||||
[mapping/node-marker
|
||||
(meta-eval
|
||||
(if (free-id-set-member? #,t #,seen)
|
||||
(raise-syntax-error 'define-graph/rich-returns
|
||||
(~a "Cycles in types are not allowed."
|
||||
" The following types were already"
|
||||
" inlined: " seen ", and " t
|
||||
" appeared a second time.")
|
||||
t)
|
||||
(#,inline-temp-nodes/type result-type
|
||||
#,(free-id-set-add t seen))))]
|
||||
…))
|
||||
))
|
||||
(printf "<<< type ~a\n" (syntax->datum #'t))
|
||||
rslt))
|
||||
|
||||
(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
|
||||
…)))]
|
||||
(printf ">>> inst ~a\n" (syntax->datum t))
|
||||
(define/with-syntax (inlined-result-type …)
|
||||
(stx-map (λ (result-type)
|
||||
(inline-temp-nodes/type result-type
|
||||
(free-id-set-add seen t)))
|
||||
#'(result-type …)))
|
||||
|
||||
(define (replacement result-type mapping/node)
|
||||
#`[mapping/node-marker
|
||||
(inline-temp-nodes/type result-type
|
||||
(free-id-set-add #,seen #,t))
|
||||
(first-pass #:? mapping/node)
|
||||
(if (free-id-set-member? t seen)
|
||||
(raise-syntax-error 'define-graph/rich-returns
|
||||
(~a "Cycles in types are not allowed."
|
||||
" The following types were already"
|
||||
" inlined: " #,seen ", and " #,t
|
||||
" appeared a second time.")
|
||||
t)
|
||||
(inline-temp-nodes/instance result-type
|
||||
(free-id-set-add seen t)))]
|
||||
…
|
||||
(let ((rslt
|
||||
(replace-in-type #'(Let (id-~> second-step-marker-expander) #,t)
|
||||
(stx-map replacement
|
||||
#'([result-type mapping/node] …))
|
||||
#;[node* ;; generated by the first pass
|
||||
(name #:placeholder node*) ; new type
|
||||
(first-pass #:? node*)
|
||||
node*] ;; call constructor
|
||||
#;…))
|
||||
))
|
||||
(printf "<<< inst ~a\n" (syntax->datum t))
|
||||
rslt))
|
||||
|
||||
(define-template-metafunction (!inline-temp-nodes/instance stx)
|
||||
(syntax-case stx ()
|
||||
[(_ t)
|
||||
(inline-temp-nodes/instance #'t (immutable-free-id-set))]))]
|
||||
|
||||
----------------------
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@CHUNK[<step2>
|
||||
; #,(step2-introducer
|
||||
; (quasitemplate
|
||||
#,(quasitemplate/debug name
|
||||
(define-graph name;#,(step2-introducer #'name)
|
||||
#:definitions [<second-step-~>-expander>
|
||||
<second-step-marker-expander>
|
||||
<inline-type>
|
||||
<inline-instance>]
|
||||
[node [field c (Let [id-~> ~>-to-result-type] field-type)] …
|
||||
[(node/extract/mapping [from : (name/first-step node)])
|
||||
<inlined-node>]]
|
||||
…))]
|
||||
|
||||
We create the inlined-node by inlining the temporary nodes
|
||||
in all of its fields:
|
||||
|
||||
@chunk[<inlined-node>
|
||||
(node ((inline-instance field-type ()) (get from field))
|
||||
…)]
|
||||
|
||||
To inline the temporary nodes in the instance, we use
|
||||
@tc[replace-in-instance], and call the inline-instance
|
||||
recursively:
|
||||
|
||||
@chunk[<inline-instance>
|
||||
(define-syntax (inline-instance stx)
|
||||
(dbg
|
||||
("inline-instance" stx)
|
||||
(syntax-parse stx
|
||||
[(_ i-t (~and seen (:id (… …))))
|
||||
<inline-check-seen>
|
||||
(replace-in-instance #'(Let (id-~> second-step-marker-expander) i-t)
|
||||
#'(<inline-instance-replacement>
|
||||
<inline-instance-nodes>))])))]
|
||||
|
||||
@chunk[<inline-type>
|
||||
(define-type-expander (inline-type stx)
|
||||
(dbg
|
||||
("inline-type" stx)
|
||||
(syntax-parse stx
|
||||
[(_ i-t (~and seen (:id (… …))))
|
||||
<inline-check-seen>
|
||||
(replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
|
||||
#'(<inline-type-replacement>
|
||||
<inline-type-nodes>))])))]
|
||||
|
||||
@chunk[<inline-instance-replacement>
|
||||
[mapping/node-marker ;; from
|
||||
(inline-type result-type (mapping/node . seen)) ;; to
|
||||
(first-pass #:? mapping/node) ;; pred?
|
||||
(inline-instance result-type (mapping/node . seen))] ;; fun
|
||||
…]
|
||||
|
||||
@chunk[<inline-instance-nodes>
|
||||
[node ;; generated by the first pass
|
||||
(name #:placeholder node) ;; new type
|
||||
(first-pass #:? node)
|
||||
node/extract/mapping] ;; call mapping
|
||||
…]
|
||||
|
||||
@chunk[<inline-type-replacement>
|
||||
[mapping/node-marker ;; from
|
||||
(inline-type result-type (mapping/node . seen))] ;; to
|
||||
…]
|
||||
|
||||
@chunk[<inline-type-nodes>
|
||||
[node ;; generated by the first pass
|
||||
(name #:placeholder node)] ;; new type
|
||||
…]
|
||||
|
||||
We detect the possibility of unbounded recursion when
|
||||
inlining nodes by remembering the ones alreday traversed.
|
||||
|
||||
@chunk[<inline-check-seen>
|
||||
(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)))]
|
||||
|
||||
----------------------
|
||||
|
||||
|
|
@ -239,9 +422,10 @@ encapsulating the result types of mappings.
|
|||
(syntax-parse stx
|
||||
[(_ (~datum mapping)) ;; TODO: should be ~literal
|
||||
(template
|
||||
(U (first-step #:placeholder mapping/node)
|
||||
(U (name/first-step #:placeholder mapping/node)
|
||||
Nothing
|
||||
(tmpl-replace-in-type result-type
|
||||
[node (first-step #:placeholder node)]
|
||||
[node (name/first-step #:placeholder node)]
|
||||
…)))]
|
||||
…
|
||||
;; TODO: should fall-back to outer definition of ~>, if any.
|
||||
|
|
@ -253,8 +437,8 @@ 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))))]
|
||||
#;(U (name/first-step #:placeholder m-streets4/node)
|
||||
(Listof (name/first-step #:placeholder Street))))]
|
||||
|
||||
@; TODO: replace-in-type doesn't work wfell here, we need to define a
|
||||
@; type-expander.
|
||||
|
|
@ -271,7 +455,9 @@ encapsulating the result types of mappings.
|
|||
racket/syntax
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
"rewrite-type.lp2.rkt" #|debug|#
|
||||
syntax/id-set)
|
||||
syntax/id-set
|
||||
racket/format
|
||||
mischief/transform)
|
||||
(rename-in "../lib/low.rkt" [~> threading:~>])
|
||||
"graph.lp2.rkt"
|
||||
"get.lp2.rkt"
|
||||
|
|
@ -289,6 +475,15 @@ encapsulating the result types of mappings.
|
|||
|
||||
(require (for-syntax racket/pretty))
|
||||
|
||||
;<pass-2-mapping-body>
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (dbg log . body)
|
||||
(begin
|
||||
(display ">>> ")(displayln (list . log))
|
||||
(let ((res (let () . body)))
|
||||
(display "<<< ")(displayln (list . log))
|
||||
(display "<<<= ")(displayln res)
|
||||
res))))
|
||||
<graph-rich-return>)]
|
||||
|
||||
@chunk[<module-test>
|
||||
|
|
|
|||
|
|
@ -15,15 +15,16 @@ compilations, and adds them to the file “@code{remember.rkt}”:
|
|||
(require "remember.rkt")
|
||||
|
||||
(define (check-remember-all category value)
|
||||
(let ([datum-value (syntax->datum (datum->syntax #f value))])
|
||||
(if (not (member (cons category datum-value) all-remembered-list))
|
||||
(let ((file-name (build-path (this-expression-source-directory)
|
||||
"remember.rkt")))
|
||||
;; Add the missing field names to all-fields.rkt
|
||||
(with-output-file [port file-name] #:exists 'append
|
||||
(writeln (cons category datum-value) port))
|
||||
#f)
|
||||
#t)))]
|
||||
(if (not (member (cons category (to-datum value))
|
||||
all-remembered-list))
|
||||
(let ((file-name (build-path (this-expression-source-directory)
|
||||
"remember.rkt")))
|
||||
;; Add the missing field names to all-fields.rkt
|
||||
(with-output-file [port file-name] #:exists 'append
|
||||
(writeln (cons category (to-datum value))
|
||||
port))
|
||||
#f)
|
||||
#t))]
|
||||
|
||||
@CHUNK[<remember-all-errors>
|
||||
(define (remember-all-errors id fallback stx)
|
||||
|
|
@ -118,7 +119,8 @@ declared using @tc[define-syntax].
|
|||
(for-syntax mzlib/etc
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
racket/string
|
||||
racket/format))
|
||||
racket/format
|
||||
mischief/transform))
|
||||
(begin-for-syntax
|
||||
(provide check-remember-all
|
||||
remember-all-errors
|
||||
|
|
|
|||
|
|
@ -145,11 +145,11 @@ offloaded to a separate subroutine.
|
|||
@CHUNK[<replace-in-instance>
|
||||
(define-for-syntax (replace-in-instance val t r)
|
||||
(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)))]
|
||||
`(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
|
||||
|
|
@ -173,63 +173,63 @@ The other cases are similarly defined:
|
|||
@CHUNK[<recursive-replace-in-instance>
|
||||
(define (recursive-replace stx-val type)
|
||||
(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])))]
|
||||
`(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))))]
|
||||
[(~and whole ((~literal U) a ...))
|
||||
#`(let ([v-cache val])
|
||||
(cond
|
||||
#,@(stx-map (λ (ta)
|
||||
(replace-in-union #'v-cache ta r #'whole))
|
||||
#'(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.
|
||||
TODO: we currently don't check that each @tc[tag] is distinct.
|
||||
|
||||
@CHUNK[<replace-in-union>
|
||||
(define (replace-in-union stx-v-cache t r)
|
||||
(define (replace-in-union stx-v-cache t r whole)
|
||||
(define/with-syntax v-cache stx-v-cache)
|
||||
(syntax-parse t
|
||||
#:context `(replace-in-union-3 ,(current-replacement))
|
||||
|
|
@ -237,8 +237,10 @@ TODO: we currently don't check that each @tc[tag] is distinct.
|
|||
<replace-in-tagged-union-instance>]
|
||||
[_ (raise-syntax-error
|
||||
'replace-in-type
|
||||
(format "Type-replace on untagged Unions isn't supported yet: ~a"
|
||||
(syntax->datum t))
|
||||
(~a "Type-replace on untagged Unions isn't supported yet: "
|
||||
(syntax->datum t)
|
||||
" in "
|
||||
(syntax->datum whole))
|
||||
t)]
|
||||
[s:id
|
||||
#:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
|
||||
|
|
@ -401,11 +403,11 @@ functions is undefined.
|
|||
@CHUNK[<fold-instance>
|
||||
(define-for-syntax (fold-instance whole-type stx-acc-type r)
|
||||
(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)))]
|
||||
`(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] ...)))
|
||||
|
|
@ -502,7 +504,7 @@ functions is undefined.
|
|||
(list->vector
|
||||
(reverse (car f))))
|
||||
(cdr f))))]
|
||||
[((~literal U) a ...)
|
||||
[(~and ((~literal U) a ...) whole)
|
||||
(define/with-syntax (new-a-type …) (stx-map new-type-for #'(a …)))
|
||||
#`(λ ([val : (U a ...)] [acc : acc-type])
|
||||
: (values (U new-a-type …) acc-type)
|
||||
|
|
@ -553,10 +555,15 @@ functions is undefined.
|
|||
#:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
|
||||
(meta-struct? #'s))
|
||||
(error "Type-replace on struct unions: WIP.")]
|
||||
[_ (raise-syntax-error
|
||||
[_
|
||||
(show-backtrace)
|
||||
(displayln (current-replacement))
|
||||
(raise-syntax-error
|
||||
'replace-in-type
|
||||
(format "Type-replace on untagged Unions isn't supported yet: ~a"
|
||||
(syntax->datum ta))
|
||||
(~a "Type-fold-replace on untagged Unions isn't supported yet: "
|
||||
(syntax->datum ta)
|
||||
" in "
|
||||
(syntax->datum #'whole))
|
||||
ta)])]
|
||||
|
||||
For cases of the union which are a tagged list, we use a simple guard, and call
|
||||
|
|
@ -588,7 +595,7 @@ efficient than the separate implementation.
|
|||
@CHUNK[<replace-in-instance2>
|
||||
(define-for-syntax (replace-in-instance2 t r)
|
||||
(define/with-syntax ([from to pred? fun] ...) r)
|
||||
#`(λ ([val : #,t])
|
||||
#`(λ ([val : #,(expand-type t)])
|
||||
(first-value
|
||||
(#,(fold-instance t
|
||||
#'Void
|
||||
|
|
@ -609,38 +616,38 @@ one for @tc[replace-in-type]:
|
|||
@CHUNK[<template-metafunctions>
|
||||
(define-template-metafunction (tmpl-replace-in-type stx)
|
||||
(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" stx)))
|
||||
(let ([res #`#,(replace-in-type #'type
|
||||
#'([from to] …))])
|
||||
(when (attribute debug?)
|
||||
(displayln (format "=> ~a" res)))
|
||||
res)])))]
|
||||
(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" 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)
|
||||
(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] …)))])))
|
||||
(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)
|
||||
(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] …))])))]
|
||||
(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] …))])))]
|
||||
|
||||
These metafunctions just extract the arguments for @tc[replace-in-type] and
|
||||
@tc[replace-in-instance2], and pass them to these functions.
|
||||
|
|
@ -657,7 +664,8 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
|||
(submod "../lib/low.rkt" untyped)
|
||||
(only-in "../type-expander/type-expander.lp2.rkt"
|
||||
expand-type)
|
||||
"meta-struct.rkt")
|
||||
"meta-struct.rkt"
|
||||
"../lib/low/backtrace.rkt")
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../lib/low.rkt")
|
||||
|
|
|
|||
64
graph-lib/graph/rewrite-type.scrbl
Normal file
64
graph-lib/graph/rewrite-type.scrbl
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require (for-label typed/racket/base
|
||||
"rewrite-type.lp2.rkt"))
|
||||
|
||||
@title{Rewrite-type utilities for writing type-level functions}
|
||||
|
||||
The utilities described here allow replacing parts of a
|
||||
type with other types, and generating conversion functions
|
||||
transforming instances of the old type into instances of the
|
||||
new type.
|
||||
|
||||
@defform[#:kind "template metafunction"
|
||||
(tmpl-fold-instance old-type
|
||||
accumulator-type
|
||||
[from to pred? fun] …)
|
||||
#:contracts ([old-type type]
|
||||
[accumulator-type type]
|
||||
[from identifier?]
|
||||
[to type]
|
||||
[pred? predicate?]
|
||||
[fun (→ from acc (values to acc))])]{
|
||||
Produces the syntax for a function from @racket[old-type]
|
||||
to the new type, using the provided replacement functions
|
||||
for each part.}
|
||||
|
||||
|
||||
@defform[#:kind "template metafunction"
|
||||
(tmpl-replace-in-instance old-type
|
||||
[from to pred? fun] …)
|
||||
#:contracts ([old-type type]
|
||||
[accumulator-type type]
|
||||
[from identifier?]
|
||||
[to type]
|
||||
[pred? predicate?]
|
||||
[fun (→ from to)])]{
|
||||
Produces the syntax for a function from @racket[old-type]
|
||||
to the new type, using the provided replacement functions
|
||||
for each part.}
|
||||
|
||||
@defform[#:kind "function"
|
||||
(replace-in-type old-type #'([from to] …))
|
||||
#:contracts ([old-type type]
|
||||
[from identifier?]
|
||||
[to type])]{
|
||||
This type-level function produces the syntax for the type
|
||||
@racket[old-type], with all occurrences of @racket[from]
|
||||
replaced with @racket[to] in the type.}
|
||||
|
||||
@defform[#:kind "function"
|
||||
(replace-in-instance old-type #'([from to pred? fun] …))
|
||||
#:contracts ([old-type type]
|
||||
[from identifier?]
|
||||
[to type]
|
||||
[pred? predicate?]
|
||||
[fun (→ from to)])]{
|
||||
Produces the syntax for the syntax for a function from
|
||||
@racket[old-type] to the new type, transforming all parts
|
||||
of the data structure which satisfy @racket[pred?] using
|
||||
@racket[fun]. @racket[pred?] should return true if and only
|
||||
if the data pased as an argument is an instance of the
|
||||
@racket[from] type. @racket[fun] should accept instances of
|
||||
the @racket[from] type, and return instances of the
|
||||
@racket[to] type.}
|
||||
|
|
@ -331,7 +331,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
|
|||
|
||||
@chunk[<fields→stx-name>
|
||||
(define-for-syntax (fields→stx-name fields)
|
||||
(cdr (assoc (syntax->datum (datum->syntax #f (sort-fields fields)))
|
||||
(cdr (assoc (to-datum (sort-fields fields))
|
||||
fields→stx-name-alist)))]
|
||||
|
||||
@subsection{Has-field}
|
||||
|
|
@ -559,7 +559,8 @@ its arguments across compilations, and adds them to the file
|
|||
;;;unstable/sequence
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
"meta-struct.rkt"
|
||||
"remember-lib.rkt")
|
||||
"remember-lib.rkt"
|
||||
mischief/transform)
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt")
|
||||
|
|
|
|||
14
graph-lib/lib/low/backtrace.rkt
Normal file
14
graph-lib/lib/low/backtrace.rkt
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
#lang racket
|
||||
;(require "typed-untyped.rkt")
|
||||
;(define-typed/untyped-modules #:no-test
|
||||
(provide show-backtrace
|
||||
with-backtrace)
|
||||
|
||||
(define backtrace (make-parameter '()))
|
||||
|
||||
(define-syntax-rule (with-backtrace push . body)
|
||||
(parameterize ([backtrace (cons push (backtrace))])
|
||||
. body))
|
||||
|
||||
(define (show-backtrace)
|
||||
(pretty-write (backtrace)));)
|
||||
|
|
@ -39,6 +39,11 @@
|
|||
(for-meta 2 racket/base racket/syntax)
|
||||
racket/stxparam)
|
||||
|
||||
;(require "typed-untyped.rkt")
|
||||
;(require-typed/untyped "backtrace.rkt")
|
||||
(require (for-syntax "backtrace.rkt")
|
||||
"backtrace.rkt")
|
||||
|
||||
(define-syntax ~maybe
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
|
|
@ -105,15 +110,17 @@
|
|||
|
||||
(define-simple-macro (define-syntax/parse (name . args) body0 . body)
|
||||
(define-syntax (name stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) body0 . body]))))
|
||||
(with-backtrace (syntax->datum stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) body0 . body])))))
|
||||
|
||||
(define-simple-macro (λ/syntax-parse args . body)
|
||||
(λ (stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body]))))
|
||||
(with-backtrace (syntax->datum stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body])))))
|
||||
|
||||
;; λstx
|
||||
(begin
|
||||
|
|
|
|||
|
|
@ -83,8 +83,6 @@ else.
|
|||
|
||||
@chunk[<apply-type-expander>
|
||||
(define (apply-type-expander type-expander-stx stx)
|
||||
(displayln type-expander-stx)
|
||||
(displayln (syntax->datum type-expander-stx))
|
||||
(let ([type-expander (syntax-local-value type-expander-stx)])
|
||||
(((get-prop:type-expander-value type-expander) type-expander) stx)))]
|
||||
|
||||
|
|
@ -184,7 +182,8 @@ else.
|
|||
|
||||
@CHUNK[<define-type-expander>
|
||||
(define-syntax/parse (define-type-expander (name:id arg:id) . body)
|
||||
#'(define-syntax name (type-expander (λ (arg) . body))))]
|
||||
#`(define-syntax name
|
||||
(type-expander #,(syntax/loc stx (λ (arg) . body)))))]
|
||||
|
||||
@subsection{Tests for @racket[expand-type]}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user