suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Debugging define-graph/rich-returns.

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-18 00:10:26 +01:00
parent e17c026a9d
commit af5b9bcfea
10 changed files with 502 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
graph-lib/graph/__DEBUG_Let.rkt Normal file
View 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))

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

@ -53,10 +53,10 @@
: (Listof Street) : (Listof Street)
(map Street snames)]) (map Street snames)])
#| ;(grr3 '(("a" "b") ("c")))
#;(super-define-graph/rich-return #;(super-define-graph/rich-return
grr3 grr4
([City [streets : (~> m-streets)]] ([City [streets : (~> m-streets)]]
[Street [sname : String]]) [Street [sname : String]])
[(m-cities [cnames : (Listof (Listof bubble))]) [(m-cities [cnames : (Listof (Listof bubble))])
@ -86,4 +86,3 @@
(dg grr) (dg grr)
(dg grra) (dg grra)
|# |#
|#

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

@ -9,10 +9,11 @@
@section{Introduction} @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 allows defining mappings with rich return types, instead of
being forced to return a single node. For example, a mapping 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 During the graph construction, however, the user cannot
access the contents of these rich values. If this was 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 functions return opaque values whose contents cannot be
inspected during the creation of the graph. This also makes inspected during the creation of the graph. This also makes
the implementation easier, as we will generate the graph in the implementation easier, as we will generate the graph in
two phases: first, we will associate a single-field node two phases: first, we will associate a temporary
with each mapping, and use it as their return type. Then, a single-field node with each mapping, and use it as their
second pass will break these nodes, and extract their opaque return type. Then, a second pass will inline these
constituents until an actual user-specified node is temporary nodes, and extract their constituents in-depth
reached. until an actual user-specified node is reached.
Since this implementation also allows serveral mappings to Since this implementation also allows serveral mappings to
return the same node, the new signature separates the 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) [(m-streets [snames : (Listof String)]) : (Listof Street)
(map Street snames)])] (map Street snames)])]
The @tc[(~> m-streets)] type is a special marker which will @tc[define-graph/rich-return] introduces a new
be expanded to the return type of @tc[m-streets] (namely type-expander, @tc[id-~>], which is used as a special marker
@tc[(Listof Street)]) in the final graph type. For the first to denote the return type of a mapping: @tc[(~> some-mapping)]
step, however, it will be expanded to is expanded to the actual return type for @tc[some-mapping].
@tc[(U (grr #:placeholder m-streets/node) (Listof Street))]. 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 Without this, passing the result of @tc[(m-streets s)] to
@tc[City] would be impossible: the former is a placeholder @tc[City] would be impossible: the former is a placeholder
for the temporary node type which encapsulates the result for the temporary node type which encapsulates the result of
of @tc[m-streets], while the latter would normally expect a @tc[m-streets], while the latter would normally expect a
plain list. plain list.
@CHUNK[<graph-rich-return> @CHUNK[<graph-rich-return>
(define-syntax/parse <signature> (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 "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 …))
@ -109,12 +117,12 @@ plain list.
(define-temp-ids "~a/extract" (node …) #:first-base root) (define-temp-ids "~a/extract" (node …) #:first-base root)
(define-temp-ids "~a/node-marker" (mapping …)) (define-temp-ids "~a/node-marker" (mapping …))
(define-temp-ids "~a/from-first-pass" (node …)) (define-temp-ids "~a/from-first-pass" (node …))
;(define step2-introducer (make-syntax-introducer))
;(define/with-syntax id-~> (datum->syntax #'name '~>)) ;(define/with-syntax id-~> (datum->syntax #'name '~>))
(define/with-syntax introduced-~> (datum->syntax #'name '~>)) ;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
<inline-temp-nodes>
(quasitemplate/debug debug (quasitemplate/debug debug
(begin (begin
(define-graph first-step (define-graph name/first-step
#:definitions [<first-pass-type-expander>] #:definitions [<first-pass-type-expander>]
[node [field c (Let [id-~> first-step-expander2] field-type)] … [node [field c (Let [id-~> first-step-expander2] field-type)] …
[(node/simple-mapping [field c field-type] …) [(node/simple-mapping [field c field-type] …)
@ -131,14 +139,8 @@ plain list.
;; call (make-root). ;; call (make-root).
;; Possibility 2: use the "(name node)" type outside as the return ;; Possibility 2: use the "(name node)" type outside as the return
;; type of functions ;; type of functions
(define-graph name <step2>
#: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 (begin
(: node/extract (→ (first-step node) root)) (: node/extract (→ (first-step node) root))
(define (node/extract from) (define (node/extract from)
@ -147,20 +149,68 @@ plain list.
#,(immutable-free-id-set))))) #,(immutable-free-id-set)))))
… …
(root/extract (first-step ???)) ;; choice based on #:root argument (root/extract (first-step ???)) ;; choice based on #:root argument
)))] |#)))]
@chunk[<replace-in-instance> When declaring the nodes in the second step, @tc[~>] expands to the actual
(tmpl-replace-in-instance result type of the user-provided mappings, for example @tc[(Listof Street)]:
(Let (introduced-~> second-step-marker-expander) field-type)
<second-pass-replace>)]
@chunk[<second-pass-type-expander> @chunk[<second-step-~>-expander>
(define-type-expander (id-~> stx) (define-type-expander (~>-to-result-type stx)
(syntax-parse stx (syntax-parse stx
;; TODO: should be ~literal ;; TODO: should be ~literal
[(_ (~datum mapping)) #'result-type] … [(_ (~datum mapping)) #'result-type] …
;; TODO: should fall-back to outer definition of ~>, if any? ;; 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) (define-type-expander (second-step-marker-expander stx)
(syntax-parse stx (syntax-parse stx
;; TODO: should be ~literal ;; TODO: should be ~literal
@ -168,14 +218,19 @@ plain list.
;; TODO: should fall-back to outer definition of ~>, if any? ;; 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> @chunk[<second-pass-replace>
[mapping/node-marker [mapping/node-marker
<fully-replaced-mapping/result-type> <fully-replaced-mapping/result-type>
(graph #:? mapping/node) (graph #:? mapping/node)
(λ ([m : (first-graph mapping/node)]) (λ ([m : (first-pass mapping/node)])
(get m val))] (get m val))]
…] …]
@subsection{Fully-inlined type}
The result of recursively inlining the temporary mapping nodes may be a The result of recursively inlining the temporary mapping nodes may be a
recursive type: recursive type:
@ -184,46 +239,174 @@ recursive type:
(m-a : (Listof (~> m-b)) …) (m-a : (Listof (~> m-b)) …)
(m-b : (Listof (~> m-a)) …)] (m-b : (Listof (~> m-a)) …)]
Since we prefer to not deal with infinite recursive structures (they could be Since we prefer to not deal with the possible cyclic data
built using @tc[make-reader-graph], but this would not fit well with the rest of (that could be built using @tc[make-reader-graph]), we do
our framework), we do not allow type cycles unless they go through a not allow type cycles unless they go through a user-defined
user-defined node like @tc[a] or @tc[b] (by opposition to first-pass mapping node like @tc[a] or @tc[b] (by opposition to first-pass
nodes like @tc[ma/node] or @tc[mb/node]). mapping nodes like @tc[ma/node] or @tc[mb/node]).
The result type of inlining the temporary mapping nodes can be obtained by 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> @CHUNK[<inline-temp-nodes>
(define (inline-temp-nodes/type t seen) (define (inline-temp-nodes/type t seen)
(quasitemplate (printf ">>> type ~a\n" (syntax->datum #'t))
(tmpl-replace-in-type (Let ~> second-step-marker-expander t) (let ((rslt
[mapping/node-marker (quasitemplate
(meta-eval (tmpl-replace-in-type (Let (id-~> second-step-marker-expander) #,t)
(if (free-id-set-member? #,t #,seen) [mapping/node-marker
(raise-syntax-error "Cycle in types!") (meta-eval
(#,inline-temp-nodes/type result-type (if (free-id-set-member? #,t #,seen)
#,(free-id-set-add 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) (define (inline-temp-nodes/instance t seen)
(quasitemplate (printf ">>> inst ~a\n" (syntax->datum t))
(tmpl-fold-instance (Let ~> second-step-marker-expander t) (define/with-syntax (inlined-result-type …)
[mapping/node-marker (stx-map (λ (result-type)
(meta-eval (inline-temp-nodes/type result-type
(#,inline-temp-nodes/type result-type (free-id-set-add seen t)))
(free-id-set-add #,t #,seen))) #'(result-type …)))
(first-pass #:? mapping/node)
(if (free-id-set-member? t seen) (define (replacement result-type mapping/node)
(raise-syntax-error "Cycle in types!") #`[mapping/node-marker
(inline-temp-nodes/instance result-type (inline-temp-nodes/type result-type
(free-id-set-add t seen)))] (free-id-set-add #,seen #,t))
… (first-pass #:? mapping/node)
[node/from-first-pass (if (free-id-set-member? t seen)
(name #:placeholder node) ; new type (raise-syntax-error 'define-graph/rich-returns
(first-pass #:? node) (~a "Cycles in types are not allowed."
node] ;; call constructor " 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 (syntax-parse stx
[(_ (~datum mapping)) ;; TODO: should be ~literal [(_ (~datum mapping)) ;; TODO: should be ~literal
(template (template
(U (first-step #:placeholder mapping/node) (U (name/first-step #:placeholder mapping/node)
Nothing
(tmpl-replace-in-type result-type (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. ;; 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. ;; TODO: should fall-back to outer definition of ~>, if any.
) )
#;(U (first-step #:placeholder m-streets4/node) #;(U (name/first-step #:placeholder m-streets4/node)
(Listof (first-step #:placeholder Street))))] (Listof (name/first-step #:placeholder Street))))]
@; 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.
@ -271,7 +455,9 @@ encapsulating the result types of mappings.
racket/syntax racket/syntax
(submod "../lib/low.rkt" untyped) (submod "../lib/low.rkt" untyped)
"rewrite-type.lp2.rkt" #|debug|# "rewrite-type.lp2.rkt" #|debug|#
syntax/id-set) syntax/id-set
racket/format
mischief/transform)
(rename-in "../lib/low.rkt" [~> threading:~>]) (rename-in "../lib/low.rkt" [~> threading:~>])
"graph.lp2.rkt" "graph.lp2.rkt"
"get.lp2.rkt" "get.lp2.rkt"
@ -289,6 +475,15 @@ encapsulating the result types of mappings.
(require (for-syntax racket/pretty)) (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>)] <graph-rich-return>)]
@chunk[<module-test> @chunk[<module-test>

22
graph-lib/graph/remember-lib.rkt
View File

@ -15,15 +15,16 @@ compilations, and adds them to the file “@code{remember.rkt}”:
(require "remember.rkt") (require "remember.rkt")
(define (check-remember-all category value) (define (check-remember-all category value)
(let ([datum-value (syntax->datum (datum->syntax #f value))]) (if (not (member (cons category (to-datum value))
(if (not (member (cons category datum-value) all-remembered-list)) all-remembered-list))
(let ((file-name (build-path (this-expression-source-directory) (let ((file-name (build-path (this-expression-source-directory)
"remember.rkt"))) "remember.rkt")))
;; Add the missing field names to all-fields.rkt ;; Add the missing field names to all-fields.rkt
(with-output-file [port file-name] #:exists 'append (with-output-file [port file-name] #:exists 'append
(writeln (cons category datum-value) port)) (writeln (cons category (to-datum value))
#f) port))
#t)))] #f)
#t))]
@CHUNK[<remember-all-errors> @CHUNK[<remember-all-errors>
(define (remember-all-errors id fallback stx) (define (remember-all-errors id fallback stx)
@ -118,7 +119,8 @@ declared using @tc[define-syntax].
(for-syntax mzlib/etc (for-syntax mzlib/etc
(submod "../lib/low.rkt" untyped) (submod "../lib/low.rkt" untyped)
racket/string racket/string
racket/format)) racket/format
mischief/transform))
(begin-for-syntax (begin-for-syntax
(provide check-remember-all (provide check-remember-all
remember-all-errors remember-all-errors

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

@ -145,11 +145,11 @@ offloaded to a separate subroutine.
@CHUNK[<replace-in-instance> @CHUNK[<replace-in-instance>
(define-for-syntax (replace-in-instance val t r) (define-for-syntax (replace-in-instance val t r)
(parameterize-push-stx ([current-replacement (parameterize-push-stx ([current-replacement
`(replace-in-instance ,val ,t ,r)]) `(replace-in-instance ,val ,t ,r)])
(define/with-syntax ([from to fun] ...) r) (define/with-syntax ([from to fun] ...) r)
<recursive-replace-in-instance> <recursive-replace-in-instance>
<replace-in-union> <replace-in-union>
(recursive-replace val t)))] (recursive-replace val t)))]
The @tc[recursive-replace] internal function defined below takes a type The @tc[recursive-replace] internal function defined below takes a type
@tc[type] and produces an expression that transforms instances of that 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> @CHUNK[<recursive-replace-in-instance>
(define (recursive-replace stx-val type) (define (recursive-replace stx-val type)
(parameterize-push-stx ([current-replacement (parameterize-push-stx ([current-replacement
`(recursive-replace ,stx-val ,type)]) `(recursive-replace ,stx-val ,type)])
(define/with-syntax val stx-val) (define/with-syntax val stx-val)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache))) (define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type (syntax-parse type
#:context `(recursive-replace-2 ,(current-replacement)) #:context `(recursive-replace-2 ,(current-replacement))
[x:id [x:id
#:attr assoc-from-to (cdr-stx-assoc #'x #:attr assoc-from-to (cdr-stx-assoc #'x
#'((from . (to . fun)) ...)) #'((from . (to . fun)) ...))
#:when (attribute assoc-from-to) #:when (attribute assoc-from-to)
#:with (to-type . to-fun) #'assoc-from-to #:with (to-type . to-fun) #'assoc-from-to
(define/with-syntax (tmp) (generate-temporaries #'(x))) (define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for to-type in the pattern. ;; TODO: Add predicate for to-type in the pattern.
#`(to-fun val)] #`(to-fun val)]
[((~literal List) a ...) [((~literal List) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
#`(let-values ([(tmp ...) (apply values val)]) #`(let-values ([(tmp ...) (apply values val)])
(list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))] (list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
<replace-in-instance-case-pairof> <replace-in-instance-case-pairof>
[((~literal Listof) a) [((~literal Listof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a))) (define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a)) #`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)] val)]
[((~literal Vector) a ...) [((~literal Vector) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
(define/with-syntax (idx ...) (generate-indices #'(a ...))) (define/with-syntax (idx ...) (generate-indices #'(a ...)))
#`(let ([v-cache val]) #`(let ([v-cache val])
(let ([tmp (vector-ref v-cache idx)] (let ([tmp (vector-ref v-cache idx)]
...) ...)
(vector-immutable #,@(stx-map recursive-replace (vector-immutable #,@(stx-map recursive-replace
#'(tmp ...) #'(tmp ...)
#'(a ...)))))] #'(a ...)))))]
[((~literal Vectorof) a) [((~literal Vectorof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a))) (define/with-syntax (tmp) (generate-temporaries #'(a)))
;; Inst because otherwise it won't widen the inferred mutable ;; Inst because otherwise it won't widen the inferred mutable
;; vector elements' type. ;; vector elements' type.
#`((inst vector->immutable-vector #`((inst vector->immutable-vector
#,(replace-in-type #'a #'([from to] ...))) #,(replace-in-type #'a #'([from to] ...)))
(list->vector (list->vector
(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a)) (map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
(vector->list val))))] (vector->list val))))]
[((~literal U) a ...) [(~and whole ((~literal U) a ...))
#`(let ([v-cache val]) #`(let ([v-cache val])
(cond (cond
#,@(stx-map (λ (ta) #,@(stx-map (λ (ta)
(replace-in-union #'v-cache ta r)) (replace-in-union #'v-cache ta r #'whole))
#'(a ...))))] #'(a ...))))]
[((~literal quote) a) [((~literal quote) a)
#'val] #'val]
[x:id [x:id
#'val])))] #'val])))]
For unions, we currently support only tagged unions, that is unions where each 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. 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. TODO: we currently don't check that each @tc[tag] is distinct.
@CHUNK[<replace-in-union> @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) (define/with-syntax v-cache stx-v-cache)
(syntax-parse t (syntax-parse t
#:context `(replace-in-union-3 ,(current-replacement)) #: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>] <replace-in-tagged-union-instance>]
[_ (raise-syntax-error [_ (raise-syntax-error
'replace-in-type 'replace-in-type
(format "Type-replace on untagged Unions isn't supported yet: ~a" (~a "Type-replace on untagged Unions isn't supported yet: "
(syntax->datum t)) (syntax->datum t)
" in "
(syntax->datum whole))
t)] t)]
[s:id [s:id
#:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s) #:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
@ -401,11 +403,11 @@ functions is undefined.
@CHUNK[<fold-instance> @CHUNK[<fold-instance>
(define-for-syntax (fold-instance whole-type stx-acc-type r) (define-for-syntax (fold-instance whole-type stx-acc-type r)
(parameterize-push-stx ([current-replacement (parameterize-push-stx ([current-replacement
`(fold-instance ,whole-type ,stx-acc-type ,r)]) `(fold-instance ,whole-type ,stx-acc-type ,r)])
(define/with-syntax acc-type stx-acc-type) (define/with-syntax acc-type stx-acc-type)
(define/with-syntax ([from to pred? fun] ...) r) (define/with-syntax ([from to pred? fun] ...) r)
<recursive-replace-fold-instance> <recursive-replace-fold-instance>
(recursive-replace whole-type)))] (recursive-replace whole-type)))]
@CHUNK[<recursive-replace-fold-instance> @CHUNK[<recursive-replace-fold-instance>
(define (new-type-for stx) (replace-in-type stx #'([from to] ...))) (define (new-type-for stx) (replace-in-type stx #'([from to] ...)))
@ -502,7 +504,7 @@ functions is undefined.
(list->vector (list->vector
(reverse (car f)))) (reverse (car f))))
(cdr f))))] (cdr f))))]
[((~literal U) a ...) [(~and ((~literal U) a ...) whole)
(define/with-syntax (new-a-type …) (stx-map new-type-for #'(a …))) (define/with-syntax (new-a-type …) (stx-map new-type-for #'(a …)))
#`(λ ([val : (U a ...)] [acc : acc-type]) #`(λ ([val : (U a ...)] [acc : acc-type])
: (values (U new-a-type …) 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) #:when (begin (printf "~a ~a\n" (meta-struct? #'s) #'s)
(meta-struct? #'s)) (meta-struct? #'s))
(error "Type-replace on struct unions: WIP.")] (error "Type-replace on struct unions: WIP.")]
[_ (raise-syntax-error [_
(show-backtrace)
(displayln (current-replacement))
(raise-syntax-error
'replace-in-type 'replace-in-type
(format "Type-replace on untagged Unions isn't supported yet: ~a" (~a "Type-fold-replace on untagged Unions isn't supported yet: "
(syntax->datum ta)) (syntax->datum ta)
" in "
(syntax->datum #'whole))
ta)])] ta)])]
For cases of the union which are a tagged list, we use a simple guard, and call 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> @CHUNK[<replace-in-instance2>
(define-for-syntax (replace-in-instance2 t r) (define-for-syntax (replace-in-instance2 t r)
(define/with-syntax ([from to pred? fun] ...) r) (define/with-syntax ([from to pred? fun] ...) r)
#`(λ ([val : #,t]) #`(λ ([val : #,(expand-type t)])
(first-value (first-value
(#,(fold-instance t (#,(fold-instance t
#'Void #'Void
@ -609,38 +616,38 @@ one for @tc[replace-in-type]:
@CHUNK[<template-metafunctions> @CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-replace-in-type stx) (define-template-metafunction (tmpl-replace-in-type stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-replace-in-type-6 ,(current-replacement)) #:context `(tmpl-replace-in-type-6 ,(current-replacement))
[(_ (~optional (~and debug? #:debug)) type:expr [from to] …) [(_ (~optional (~and debug? #:debug)) type:expr [from to] …)
(when (attribute debug?) (when (attribute debug?)
(displayln (format "~a" stx))) (displayln (format "~a" stx)))
(let ([res #`#,(replace-in-type #'type (let ([res #`#,(replace-in-type #'type
#'([from to] …))]) #'([from to] …))])
(when (attribute debug?) (when (attribute debug?)
(displayln (format "=> ~a" res))) (displayln (format "=> ~a" res)))
res)])))] res)])))]
And one each for @tc[fold-instance] and @tc[replace-in-instance2]: And one each for @tc[fold-instance] and @tc[replace-in-instance2]:
@CHUNK[<template-metafunctions> @CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-fold-instance stx) (define-template-metafunction (tmpl-fold-instance stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-fold-instance-7 ,(current-replacement)) #:context `(tmpl-fold-instance-7 ,(current-replacement))
[(_ type:expr acc-type:expr [from to pred? fun] …) [(_ type:expr acc-type:expr [from to pred? fun] …)
#`(begin #`(begin
"fold-instance expanded code below. Initially called with:" "fold-instance expanded code below. Initially called with:"
'(fold-instance type acc-type [from to pred? λ…] …) '(fold-instance type acc-type [from to pred? λ…] …)
#,(fold-instance #'type #,(fold-instance #'type
#'acc-type #'acc-type
#'([from to pred? fun] …)))]))) #'([from to pred? fun] …)))])))
(define-template-metafunction (tmpl-replace-in-instance stx) (define-template-metafunction (tmpl-replace-in-instance stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-replace-in-instance-8 ,(current-replacement)) #:context `(tmpl-replace-in-instance-8 ,(current-replacement))
[(_ type:expr [from to pred? fun] …) [(_ type:expr [from to pred? fun] …)
#`#,(replace-in-instance2 #'type #'([from to pred? fun] …))])))] #`#,(replace-in-instance2 #'type #'([from to pred? fun] …))])))]
These metafunctions just extract the arguments for @tc[replace-in-type] and These metafunctions just extract the arguments for @tc[replace-in-type] and
@tc[replace-in-instance2], and pass them to these functions. @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) (submod "../lib/low.rkt" untyped)
(only-in "../type-expander/type-expander.lp2.rkt" (only-in "../type-expander/type-expander.lp2.rkt"
expand-type) expand-type)
"meta-struct.rkt") "meta-struct.rkt"
"../lib/low/backtrace.rkt")
"../type-expander/multi-id.lp2.rkt" "../type-expander/multi-id.lp2.rkt"
"../type-expander/type-expander.lp2.rkt" "../type-expander/type-expander.lp2.rkt"
"../lib/low.rkt") "../lib/low.rkt")

64
graph-lib/graph/rewrite-type.scrbl Normal file
View 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.}

5
graph-lib/graph/structure.lp2.rkt
View File

@ -331,7 +331,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
@chunk[<fields→stx-name> @chunk[<fields→stx-name>
(define-for-syntax (fields→stx-name fields) (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)))] fields→stx-name-alist)))]
@subsection{Has-field} @subsection{Has-field}
@ -559,7 +559,8 @@ its arguments across compilations, and adds them to the file
;;;unstable/sequence ;;;unstable/sequence
(submod "../lib/low.rkt" untyped) (submod "../lib/low.rkt" untyped)
"meta-struct.rkt" "meta-struct.rkt"
"remember-lib.rkt") "remember-lib.rkt"
mischief/transform)
"../lib/low.rkt" "../lib/low.rkt"
"../type-expander/type-expander.lp2.rkt" "../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt") "../type-expander/multi-id.lp2.rkt")

14
graph-lib/lib/low/backtrace.rkt Normal file
View 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)));)

19
graph-lib/lib/low/syntax-parse.rkt
View File

@ -39,6 +39,11 @@
(for-meta 2 racket/base racket/syntax) (for-meta 2 racket/base racket/syntax)
racket/stxparam) racket/stxparam)
;(require "typed-untyped.rkt")
;(require-typed/untyped "backtrace.rkt")
(require (for-syntax "backtrace.rkt")
"backtrace.rkt")
(define-syntax ~maybe (define-syntax ~maybe
(pattern-expander (pattern-expander
(λ (stx) (λ (stx)
@ -105,15 +110,17 @@
(define-simple-macro (define-syntax/parse (name . args) body0 . body) (define-simple-macro (define-syntax/parse (name . args) body0 . body)
(define-syntax (name stx2) (define-syntax (name stx2)
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) (with-backtrace (syntax->datum stx2)
(syntax-parse stx2 (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
[(_ . args) body0 . body])))) (syntax-parse stx2
[(_ . args) body0 . body])))))
(define-simple-macro (λ/syntax-parse args . body) (define-simple-macro (λ/syntax-parse args . body)
(λ (stx2) (λ (stx2)
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) (with-backtrace (syntax->datum stx2)
(syntax-parse stx2 (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
[args . body])))) (syntax-parse stx2
[args . body])))))
;; λstx ;; λstx
(begin (begin

5
graph-lib/type-expander/type-expander.lp2.rkt
View File

@ -83,8 +83,6 @@ else.
@chunk[<apply-type-expander> @chunk[<apply-type-expander>
(define (apply-type-expander type-expander-stx stx) (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)]) (let ([type-expander (syntax-local-value type-expander-stx)])
(((get-prop:type-expander-value type-expander) type-expander) stx)))] (((get-prop:type-expander-value type-expander) type-expander) stx)))]
@ -184,7 +182,8 @@ else.
@CHUNK[<define-type-expander> @CHUNK[<define-type-expander>
(define-syntax/parse (define-type-expander (name:id arg:id) . body) (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]} @subsection{Tests for @racket[expand-type]}