From af5b9bcfea0c3e485214bcd0f604111e28096010 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 18 Mar 2016 00:10:26 +0100 Subject: [PATCH] Debugging define-graph/rich-returns. --- graph-lib/graph/__DEBUG_Let.rkt | 25 ++ graph-lib/graph/__DEBUG_graph6.rkt | 5 +- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 339 ++++++++++++++---- graph-lib/graph/remember-lib.rkt | 22 +- graph-lib/graph/rewrite-type.lp2.rkt | 192 +++++----- graph-lib/graph/rewrite-type.scrbl | 64 ++++ graph-lib/graph/structure.lp2.rkt | 5 +- graph-lib/lib/low/backtrace.rkt | 14 + graph-lib/lib/low/syntax-parse.rkt | 19 +- graph-lib/type-expander/type-expander.lp2.rkt | 5 +- 10 files changed, 502 insertions(+), 188 deletions(-) create mode 100644 graph-lib/graph/__DEBUG_Let.rkt create mode 100644 graph-lib/graph/rewrite-type.scrbl create mode 100644 graph-lib/lib/low/backtrace.rkt diff --git a/graph-lib/graph/__DEBUG_Let.rkt b/graph-lib/graph/__DEBUG_Let.rkt new file mode 100644 index 00000000..727575b3 --- /dev/null +++ b/graph-lib/graph/__DEBUG_Let.rkt @@ -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)) \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index a6c45dd4..01eac8d7 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -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) |# -|# \ No newline at end of file diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index a1531b11..c5dab4f1 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -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[ (define-syntax/parse - (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 '~>)) - + ;(define/with-syntax introduced-~> (datum->syntax #'name '~>)) (quasitemplate/debug debug (begin - (define-graph first-step + (define-graph name/first-step #:definitions [] [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 [] - [node [field c field-type] … - [(node/extract/mapping [from : (first-step node)]) - (node ( (get from field)) - …) - …]] - …) + + #| (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[ - (tmpl-replace-in-instance - (Let (introduced-~> second-step-marker-expander) field-type) - )] +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[ - (define-type-expander (id-~> stx) +@chunk[-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[ + (define-syntax/parse (pass-2-mapping-body name + ) + + (template + (node ( (get from field)) + …)))] + +We need to provide to that staged macro all the identifiers it needs: + +@chunk[ + 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[ + (!inline-temp-nodes/instance field-type) + #;(tmpl-replace-in-instance (Let (id-~> second-step-marker-expander) + field-type) + )] + +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[ + ;; 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[ [mapping/node-marker (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[ (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-introducer + ; (quasitemplate + #,(quasitemplate/debug name + (define-graph name;#,(step2-introducer #'name) + #:definitions [-expander> + + + ] + [node [field c (Let [id-~> ~>-to-result-type] field-type)] … + [(node/extract/mapping [from : (name/first-step node)]) + ]] + …))] + +We create the inlined-node by inlining the temporary nodes +in all of its fields: + +@chunk[ + (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[ + (define-syntax (inline-instance stx) + (dbg + ("inline-instance" stx) + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-instance #'(Let (id-~> second-step-marker-expander) i-t) + #'( + ))])))] + +@chunk[ + (define-type-expander (inline-type stx) + (dbg + ("inline-type" stx) + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t) + #'( + ))])))] + +@chunk[ + [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[ + [node ;; generated by the first pass + (name #:placeholder node) ;; new type + (first-pass #:? node) + node/extract/mapping] ;; call mapping + …] + +@chunk[ + [mapping/node-marker ;; from + (inline-type result-type (mapping/node . seen))] ;; to + …] + +@chunk[ + [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[ + (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)) + ; + (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)))) )] @chunk[ diff --git a/graph-lib/graph/remember-lib.rkt b/graph-lib/graph/remember-lib.rkt index 6c2b4a69..1a18bf18 100644 --- a/graph-lib/graph/remember-lib.rkt +++ b/graph-lib/graph/remember-lib.rkt @@ -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[ (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 diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index 03c589e4..a80a3407 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -145,11 +145,11 @@ offloaded to a separate subroutine. @CHUNK[ (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 val t)))] + `(replace-in-instance ,val ,t ,r)]) + (define/with-syntax ([from to fun] ...) r) + + + (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[ (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 ...))))] - - [((~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 ...))))] + + [((~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[ - (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. ] [_ (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[ (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 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 whole-type)))] @CHUNK[ (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[ (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[ (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[ (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") diff --git a/graph-lib/graph/rewrite-type.scrbl b/graph-lib/graph/rewrite-type.scrbl new file mode 100644 index 00000000..b95f9eed --- /dev/null +++ b/graph-lib/graph/rewrite-type.scrbl @@ -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.} \ No newline at end of file diff --git a/graph-lib/graph/structure.lp2.rkt b/graph-lib/graph/structure.lp2.rkt index 5b474e2d..bfd13371 100644 --- a/graph-lib/graph/structure.lp2.rkt +++ b/graph-lib/graph/structure.lp2.rkt @@ -331,7 +331,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted. @chunk[ (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") diff --git a/graph-lib/lib/low/backtrace.rkt b/graph-lib/lib/low/backtrace.rkt new file mode 100644 index 00000000..36e66e72 --- /dev/null +++ b/graph-lib/lib/low/backtrace.rkt @@ -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)));) \ No newline at end of file diff --git a/graph-lib/lib/low/syntax-parse.rkt b/graph-lib/lib/low/syntax-parse.rkt index 1de8575f..d965ac11 100644 --- a/graph-lib/lib/low/syntax-parse.rkt +++ b/graph-lib/lib/low/syntax-parse.rkt @@ -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 diff --git a/graph-lib/type-expander/type-expander.lp2.rkt b/graph-lib/type-expander/type-expander.lp2.rkt index b0a091fa..9c9c3c0c 100644 --- a/graph-lib/type-expander/type-expander.lp2.rkt +++ b/graph-lib/type-expander/type-expander.lp2.rkt @@ -83,8 +83,6 @@ else. @chunk[ (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-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]}