diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index 6924960e..73606a80 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -1,78 +1,38 @@ #lang typed/racket -(require "graph-6-rich-returns.lp2.rkt" - "../lib/low.rkt" - "graph.lp2.rkt" - "get.lp2.rkt" - "../type-expander/type-expander.lp2.rkt" - "../type-expander/multi-id.lp2.rkt" - "adt.lp2.rkt" ; debug - "fold-queues.lp2.rkt"; debug - "rewrite-type.lp2.rkt"; debug - "meta-struct.rkt"; debug - racket/splicing; debug - (for-syntax syntax/parse) - (for-syntax syntax/parse/experimental/template)) - - -#| -(require "__DEBUG_graph6B.rkt") - -(frozen (~>)) -|# - -(define-type blob String) -(define-type-expander (bubble stx) #'String) - -(require (for-syntax syntax/strip-context)) - -(define-syntax (super-define-graph/rich-return stx) - (syntax-case stx () - [(_ name . rest) - (with-syntax ([(b (d (dgi n) . r) (dgi2 n2)) - (replace-context - stx - #'(begin - (define-syntax-rule (dg1 name) - (define-graph/rich-return name ~> . rest)) - (dg1 name)))]) - #'(b (d (dgX n) . r) (dgX n2)))])) - -(super-define-graph/rich-return - grr3 - ([City [streets : (~> m-streets)]] - [Street [sname : String]]) - [(m-cities [cnames : (Listof (Listof bubble))]) - : (Listof City) - (define (strings→city [s : (Listof blob)]) - (City (m-streets s))) - (map strings→city cnames)] - [(m-streets [snames : (Listof String)]) - : (Listof Street) - (map Street snames)]) - -(% (x y) = ((car DBG) '(("a" "b" "c") ("d"))) - in - (list (get x streets … sname) - (get y streets … sname))) - -#;(super-define-graph/rich-return - grr4 - ([City [streets : (~> m-streets)]] - [Street [sname : String]]) - [(m-cities [cnames : (Listof (Listof bubble))]) - : (Listof City) - (define (strings→city [s : (Listof blob)]) - (City (m-streets s))) - (map strings→city cnames)] - [(m-streets [snames : (Listof String)]) - : (Listof Street) - (map Street snames)]) - -#| - -(define-syntax-rule (dg grr) - (define-graph/rich-return grr ~> +(module test-~>-bound typed/racket + (require "graph-6-rich-returns.lp2.rkt" + "../lib/low.rkt" + ;"graph.lp2.rkt" + "get.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + + (define-type blob String) + (define-type-expander (bubble stx) #'String) + + (define-graph + grr3 + ([City [streets : (~> m-streets)]] + [Street [sname : String]]) + [(m-cities [cnames : (Listof (Listof bubble))]) + : (Listof City) + (define (strings→city [s : (Listof blob)]) + (City (m-streets s))) + (map strings→city cnames)] + [(m-streets [snames : (Listof String)]) + : (Listof Street) + (map Street snames)]) + + (check-equal?: (% (x y) = (grr3 '(("a" "b" "c") ("d"))) + in + (list (get x streets … sname) + (get y streets … sname))) + '(("a" "b" "c") ("d"))) + + ;; Check that there are no collisions: + ;; Same as above with just the graph name changed + (define-graph + grr4 ([City [streets : (~> m-streets)]] [Street [sname : String]]) [(m-cities [cnames : (Listof (Listof bubble))]) @@ -84,7 +44,48 @@ : (Listof Street) (map Street snames)])) -(dg grr) -(dg grra) -|# +(module test-~>-unbound typed/racket + (require "graph-6-rich-returns.lp2.rkt" + "get.lp2.rkt" + typed/rackunit + "../type-expander/type-expander.lp2.rkt") + + (define-type blob String) + (define-type-expander (bubble stx) #'String) + + (define-graph + grr3 + ([City [streets : (~> m-streets)]] + [Street [sname : String]]) + [(m-cities [cnames : (Listof (Listof bubble))]) + : (Listof City) + (define (strings→city [s : (Listof blob)]) + (City (m-streets s))) + (map strings→city cnames)] + [(m-streets [snames : (Listof String)]) + : (Listof Street) + (map Street snames)]) + + (check-equal? (let ([l (grr3 '(("a" "b" "c") ("d")))]) + (list (get (car l) streets … sname) + (get (cadr l) streets … sname))) + '(("a" "b" "c") ("d"))) + + ;; Check that there are no collisions: + ;; Same as above with just the graph name changed + (define-graph + grr4 + ([City [streets : (~> m-streets)]] + [Street [sname : String]]) + [(m-cities [cnames : (Listof (Listof bubble))]) + : (Listof City) + (define (strings→city [s : (Listof blob)]) + (City (m-streets s))) + (map strings→city cnames)] + [(m-streets [snames : (Listof String)]) + : (Listof Street) + (map Street snames)])) +(module test typed/racket + (require (submod ".." test-~>-bound)) + (require (submod ".." test-~>-unbound))) diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index 8d144fcd..6752a5c4 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -56,7 +56,7 @@ mapping declarations from the node definitions: @chunk[ (define-graph/rich-return name:id id-~> - (~optional (~and #:debug debug)) + (~optkw #:debug) ((~commit [node:id …]) …) (~commit ) @@ -110,9 +110,12 @@ plain list. (define-syntax/parse (define/with-syntax (node* …) #'(node …)) (define-temp-ids "~a/first-step" name) + (define/with-syntax name/second-step ((make-syntax-introducer) #'name)) + (define/with-syntax (root-mapping/result-type . _) #'(result-type …)) (define-temp-ids "first-step-expander2" name) (define-temp-ids "top1-accumulator-type" name) - (define-temp-ids "~a/constructor-top2" (mapping …)) + (define-temp-ids "~a/constructor-top2" (mapping …) + #:first-base root-mapping) (define-temp-ids "~a/accumulator" (node …)) (define-temp-ids "~a/top2-roots" (node …)) (define-temp-ids "~a/next-idx" (node …)) @@ -133,22 +136,18 @@ plain list. ;(define/with-syntax introduced-~> (datum->syntax #'name '~>)) (quasitemplate/debug debug (begin - #,(dbg - ("first-pass" stx) - (quasitemplate - (define-graph name/first-step - #:definitions [] - [node [field c (Let [id-~> first-step-expander2] field-type)] - #| |#… - [(node/simple-mapping [field c field-type] …) - ;] …) - (node field …)]] … - [mapping/node [returned cm result-type] - [(mapping [param cp param-type] …) - (mapping/node - (let ([node node/simple-mapping] …) - . body))]] - …))) + (define-graph name/first-step + #:definitions [] + [node [field c (Let [id-~> first-step-expander2] field-type)] … + [(node/simple-mapping [field c field-type] …) + ;] …) + (node field …)]] … + [mapping/node [returned cm result-type] + [(mapping [param cp param-type] …) + (mapping/node + (let ([node node/simple-mapping] …) + . body))]] + …) ;; TODO: how to return something else than a node?? ;; Possibility 1: add a #:main function to define-graph, which can ;; call (make-root). @@ -199,7 +198,7 @@ produced by the first step. (define-type mapping/node-marker (tmpl-replace-in-type result-type [mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here - [node (name #:placeholder node)]) + [node (name/second-step #:placeholder node)]) #;(U (name/first-step mapping/node) (tmpl-replace-in-type result-type [mapping/node (name/first-step mapping/node)] @@ -235,13 +234,7 @@ produced by the first step. [(_ (~datum mapping)) (syntax-local-introduce #'(U second-step-mapping/node-of-first - result-type - - ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<, if any? ))] @@ -281,23 +274,22 @@ identifier, so that it can be matched against by @CHUNK[ - #,(quasitemplate/debug name - (define-graph name - #:definitions [-expander> - - - ] - [node [field c (Let [id-~> ~>-to-result-type] field-type)] … - [(node/extract/mapping [from : (name/first-step node)]) - ]] - …)) + (define-graph name/second-step + #: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: @@ -314,27 +306,22 @@ recursively: @CHUNK[ (define-syntax (inline-instance* stx) - (dbg - ("inline-instance*" stx) - (syntax-parse stx - [(_ i-ty seen) - (define/with-syntax replt - (replace-in-type #'(Let (id-~> second-step-marker2-expander) - i-ty) - #'([node second-step-node-of-first] - …))) - (displayln (list "replt=" #'replt)) - #'(inline-instance replt seen)]))) + (syntax-parse stx + [(_ i-ty seen) + (define/with-syntax replt + (replace-in-type #'(Let (id-~> second-step-marker2-expander) + i-ty) + #'([node second-step-node-of-first] + …))) + #'(inline-instance replt seen)])) (define-syntax (inline-instance stx) - (dbg - ("inline-instance" stx) - (syntax-parse stx - [(_ i-t (~and seen (:id (… …)))) - - (replace-in-instance #'i-t - #'( - ))])))] + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-instance #'i-t + #'( + ))]))] @chunk[ [second-step-mapping/node-of-first ;; from @@ -347,7 +334,7 @@ recursively: @chunk[ [second-step-node-of-first ;; node of first step ;; from - (name #:placeholder node) ;; new type ;; to + (name/second-step #:placeholder node) ;; new type ;; to (name/first-step #:? node) ;; pred? node/extract/mapping] ;; call mapping ;; fun …] @@ -368,11 +355,6 @@ layer of actual nodes. We do this in three steps: @item{Finally, we replace the placeholders with the second-pass nodes returned by the graph.}] -@CHUNK[ - (inline-instance-top1* result-type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ()) - …] - @CHUNK[ (define-constructor mapping/node-index #:private @@ -399,29 +381,24 @@ layer of actual nodes. We do this in three steps: @CHUNK[ (define-syntax (inline-instance-top1* stx) - (dbg - ("inline-instance-top1*" stx) - (syntax-parse stx - [(_ i-ty seen) - (define/with-syntax replt - (replace-in-type #'(Let (id-~> second-step-marker2-top-expander) - i-ty) - #'([node second-step-node-of-first] - …))) - (displayln (list "replt-top=" #'replt)) - #'(inline-instance-top1 replt seen)]))) + (syntax-parse stx + [(_ i-ty seen) + (define/with-syntax replt + (replace-in-type #'(Let (id-~> second-step-marker2-top-expander) + i-ty) + #'([node second-step-node-of-first] + …))) + #'(inline-instance-top1 replt seen)])) (define-syntax (inline-instance-top1 stx) - (dbg - ("inline-instance-top1" stx) - (syntax-parse stx - [(_ i-t (~and seen (:id (… …)))) - - ;(replace-in-instance #'i-t - (fold-instance #'i-t - #'top1-accumulator-type - #'( - ))])))] + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + ;(replace-in-instance #'i-t + (fold-instance #'i-t + #'top1-accumulator-type + #'( + ))]))] @chunk[ [second-step-mapping/node-of-first ;; from @@ -457,14 +434,12 @@ layer of actual nodes. We do this in three steps: @chunk[ (define-type-expander (inline-type-top1 stx) - (dbg - ("inline-type-top1" stx) - (syntax-parse stx - [(_ i-t (~and seen (:id (… …)))) - - (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) - #'( - ))])))] + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) + #'( + ))]))] @chunk[ @@ -480,10 +455,7 @@ layer of actual nodes. We do this in three steps: @chunk[ (define (mapping/constructor-top2 [param cp param-type] …) (% )) - … - - (define #,(datum->syntax #'name 'DBG) - (list mapping/constructor-top2 …))] + …] @chunk[ first-graph = (name/first-step #:root mapping/node param …) @@ -496,56 +468,74 @@ layer of actual nodes. We do this in three steps: (assert (= (length node/accumulator) node/next-idx)) ;; Call the second step graph constructor: (% (node/top2-roots …) - = (name #:roots [node (reverse (lists (cdrs node/accumulator)))] …) + = (name/second-step + #:roots [node (reverse (lists (cdrs node/accumulator)))] …) in ((replace-markers-top3 result-type node/top2-roots …) with-indices-top1))] @chunk[ - (define-syntax (replace-markers-top3 stx) - (dbg - ("inline-instance-top3*" stx) - (syntax-parse stx - [(_ i-ty node/top2-roots …) - (displayln (replace-in-type #'(inline-type-top1 i-ty ()) - #'[])) - (replace-in-instance #'(inline-type-top1 i-ty ()) - #'([mapping/node-index-marker ;; from - (name node) ;; to - mapping/node-index? ;; pred? - (λ ([idx : mapping/node-index]) ;; fun - (vector-ref node/top2-roots - (constructor-values idx)))] - …))]))) - #;(define-syntax (inline-instance-top3* stx) - (dbg - ("inline-instance-top3*" stx) - (syntax-parse stx - [(_ i-ty seen node/top2-roots …) - (define/with-syntax replt - (replace-in-type #'(Let (id-~> second-step-marker2-top-expander) - i-ty) - #'([node second-step-node-of-first] - …))) - (displayln (list "replt-top=" #'replt)) - #'(inline-instance-top3 replt seen node/top2-roots …)]))) + (define-type-expander (inline-type-top3 stx) + (syntax-parse stx + [(_ i-ty) + (replace-in-type #'(inline-type-top1 i-ty ()) + #'([mapping/node-index-marker ;; from + (name/second-step node)] ;; to + …))])) - #;(define-syntax (inline-instance-top3 stx) - (dbg - ("inline-instance-top3" stx) - (syntax-parse stx - [(_ i-t (~and seen (:id (… …))) node/top2-roots …) - - ;(replace-in-instance #'i-t - (replace-in-instance #'i-t - #'([mapping/node-index-marker ;; from - (name node) ;; to - mapping/node-index? ;; pred? - (λ ([idx : mapping/node-index]) ;; fun - (vector-ref node/top2-roots - (constructor-values idx)))] - …))])))] + (define-syntax (replace-markers-top3 stx) + (syntax-parse stx + [(_ i-ty node/top2-roots …) + (replace-in-instance #'(inline-type-top1 i-ty ()) + #'([mapping/node-index-marker ;; from + (name/second-step node) ;; to + mapping/node-index? ;; pred? + (λ ([idx : mapping/node-index]) ;; fun + (vector-ref node/top2-roots + (constructor-values idx)))] + …))]))] + +@subsection{The main graph macro} + +@; TODO: move this to a separate file: +@chunk[ + (define-multi-id name + #:type-expander + #:call (λ (stx) + (syntax-parse stx + ;; TODO: move this to a dot expander, so that writing + ;; g.a gives a constructor for the a node of g, and + ;; (g.a foo bar) or (let ((c .g.a)) (c foo bar)) both + ;; call it + [(_ #:λroot (~datum mapping)) + #'root-mapping/constructor-top2] + … + [(_ #:root (~datum mapping) . rest) + (syntax/loc stx (mapping/constructor-top2 . rest))] + … + + #;[(_ #:roots [(~datum node) node/multi-rest] …) + (syntax/loc stx + (name/multi-constructor node/multi-rest …))] + ;; TODO: TR has issues with occurrence typing and promises, + ;; so we should wrap the nodes in a tag, which contains a + ;; promise, instead of the opposite (tag inside promise). + [(_ #:? (~datum node)) + ;; TODO: implement node? properly here! FB case 107 + (syntax/loc stx (name/second-step #:? node))] + … + [(_ . rest) + (syntax/loc stx (root-mapping/constructor-top2 . rest))])) + #:id (λ (stx) #'root-mapping/constructor-top2))] + +@chunk[ + (λ (stx) + (syntax-parse stx + [:id #'(inline-type-top3 root-mapping/result-type)] + [(_ (~datum mapping)) #'(inline-type-top3 result-type)] + … + [(_ . rest) #'(name/second-step . rest)]))] @subsection{Inlining types} @@ -660,24 +650,22 @@ which does not allow variants of (~> …). @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) - #'( - ))])))] + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) + #'( + ))]))] @chunk[ - [second-step-mapping/node-of-first ;; from - (inline-type result-type (mapping/node . seen))] ;; to + [second-step-mapping/node-of-first ;; from + (inline-type result-type (mapping/node . seen))] ;; to …] @chunk[ [node ;second-step-node-of-first ;; generated by the first pass - (name #:placeholder node)] ;; new type + (name/second-step #:placeholder node)] ;; new type …] We detect the possibility of unbounded recursion when @@ -733,45 +721,49 @@ encapsulating the result types of mappings. @section{Conclusion} +@CHUNK[ + (define-syntax (super-define-graph/rich-return stx) + (syntax-case stx () + [(_ name . rest) + (with-syntax ([(b (d (dgi n) . r) (dgi2 n2)) + #`(begin + (define-syntax-rule (dg1 name) + (define-graph/rich-return name + #,(replace-context stx #'~>) + . rest)) + (dg1 name))]) + #'(b (d (dgX n) . r) (dgX n2)))]))] + @chunk[ (module main typed/racket + (provide define-graph/rich-return) + (require (for-syntax syntax/parse syntax/parse/experimental/template racket/syntax (submod "../lib/low.rkt" untyped) - "rewrite-type.lp2.rkt" #|debug|# - syntax/id-set - racket/format - mischief/transform) - (rename-in "../lib/low.rkt" [~> threading:~>]) + "rewrite-type.lp2.rkt" + racket/format) + "../lib/low.rkt" "graph.lp2.rkt" "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "../type-expander/multi-id.lp2.rkt" - "adt.lp2.rkt" ; debug - "fold-queues.lp2.rkt"; debug - "rewrite-type.lp2.rkt"; debug - "meta-struct.rkt"; debug - racket/stxparam - racket/splicing) - (provide define-graph/rich-return - (for-syntax dbg) ;; DEBUG - ) + "adt.lp2.rkt" + "rewrite-type.lp2.rkt") - (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 "<<<= ")(display (car (list . log))) - (display res)(displayln ".") - res)))) )] -@chunk[ +@chunk[ + (module wrapper typed/racket + (provide (rename-out [super-define-graph/rich-return define-graph])) + + (require (submod ".." main) + (for-syntax syntax/strip-context)) + + )] + +@chunk[ (module test-syntax racket (provide tests) (define tests @@ -782,8 +774,9 @@ encapsulating the result types of mappings. @chunk[<*> (begin + - (require 'main) - (provide (all-from-out 'main)) + (require 'wrapper) + (provide (all-from-out 'wrapper)) - )] \ No newline at end of file + )] \ No newline at end of file diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index eba02edb..715a765c 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -320,11 +320,9 @@ The graph name will be used in several ways: [(_ #:roots [(~datum node) node/multi-rest] …) (syntax/loc stx (name/multi-constructor node/multi-rest …))] - ;; TODO: TR has issues with occurrence typing and promises, - ;; so we should wrap the nodes in a tag, which contains a - ;; promise, instead of the opposite (tag inside promise). [(_ #:? (~datum node)) - (syntax/loc stx node?)] ;;;;;;;;;;;;;;;TODO: implement node? properly here! FB case 107 + ;; TODO: implement node? properly here! FB case 107 + (syntax/loc stx node?)] … [(_ . rest) (syntax/loc stx (root/constructor . rest))])) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index 17e0afec..12be09b3 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -40,7 +40,7 @@ relies on the lower-level utilities provided by this module, namely (: name (→ type #,(replace-in-type #'type #'([from to] ...)))) (define (name v) (#,(replace-in-instance #'type - #'([from to pred? fun] ...)) + #'([from to pred? fun] ...)) v)))]))] @subsection{A bigger example} @@ -146,10 +146,10 @@ offloaded to a separate subroutine. (define (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)))] + (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 @@ -174,55 +174,55 @@ The other cases are similarly defined: (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))))] - [(~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])))] + (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. @@ -289,12 +289,13 @@ functions is undefined. @CHUNK[ (define (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)))] + (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)))] @CHUNK[ (define (new-type-for stx) (replace-in-type stx #'([from to] ...))) @@ -503,38 +504,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)) - [(_ (~optkw #: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)) + [(_ (~optkw #: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. diff --git a/graph-lib/lib/doc/unicode-chars.sty.rkt b/graph-lib/lib/doc/unicode-chars.sty.rkt index 2aee4b24..9cbc1c6c 100644 --- a/graph-lib/lib/doc/unicode-chars.sty.rkt +++ b/graph-lib/lib/doc/unicode-chars.sty.rkt @@ -3,12 +3,15 @@ (define unicode-chars @string-append|<<<{ \makeatletter -% Must be loaded after MnSymbol!!! MnSymbol improperly defines × and ¬ in such a way that they don't work in math mode. +% Must be loaded after MnSymbol!!! MnSymbol improperly defines × and ¬ in such a +% way that they don't work in math mode. % definition of some characters, for use with % \usepackage[utf8]{inputenc} % \usepackage[T1]{fontenc} % Author: Christoph Lange -% Some math characters taken from John Wickerson's MathUnicode.sty (http://tex.stackexchange.com/questions/110042/entering-unicode-math-symbols-into-latex-direct-from-keyboard-on-a-mac) +% Some math characters taken from John Wickerson's MathUnicode.sty +% (http://tex.stackexchange.com/questions/110042/ +% entering-unicode-math-symbols-into-latex-direct-from-keyboard-on-a-mac) % https://github.com/clange/latex \NeedsTeXFormat{LaTeX2e}[1999/12/01] \ProvidesPackage{unicode-chars}[2013/10/08] @@ -24,7 +27,8 @@ \catcode`\^^a0=13\relax\def {~}% " " (nbsp) \catcode`\^^a3=13\relax\def£{\pounds}% £ \catcode`\^^ae=13\relax\def®{\textsuperscript{\textregistered}}% ® -\catcode`\^^af=13\relax\def¯{\ensuremath{^-}}% ¯ % macron (overline, overbar) +% macron: overline, overbar +\catcode`\^^af=13\relax\def¯{\ensuremath{^-}}% ¯ % macron % \catcode`\^^f1=13\relax\defñ{\~{n}}% ñ % Declared by MnSymbol: % \catcode`\^^d7=13\relax\def×{\ensuremath{\times}}% × @@ -51,13 +55,15 @@ \DeclareUnicodeCharacter{03A1}{\ensuremath{\Rho}}% Ρ \DeclareUnicodeCharacter{2190}{\ensuremath{\leftarrow}}% ← \DeclareUnicodeCharacter{2192}{\ensuremath{\rightarrow}}% → -% 2192: \textrightarrow is not available in all fonts, and we need the right arrow in math mode +% 2192: \textrightarrow is not available in all fonts, +% and we need the right arrow in math mode \DeclareUnicodeCharacter{2193}{\ensuremath{\downarrow}}% ↓ \DeclareUnicodeCharacter{2194}{\ensuremath{\leftrightarrow}}% ↔ \DeclareUnicodeCharacter{21A6}{\ensuremath{\mapsto}}% ↦ \DeclareUnicodeCharacter{21C0}{\ensuremath{\rightharpoonup}}% ⇀ \DeclareUnicodeCharacter{21D2}{\ensuremath{\Rightarrow}}% ⇒ -\DeclareUnicodeCharacter{2200}{\ensuremath{\operatorname{\forall}}}% ∀ % Georges — added \operatorname{} +% Georges — added \operatorname{} in ∀ . +\DeclareUnicodeCharacter{2200}{\ensuremath{\operatorname{\forall}}}% ∀ \DeclareUnicodeCharacter{2203}{\ensuremath{\exists}}% ∃ \DeclareUnicodeCharacter{2208}{\ensuremath{\in}}% ∈ \DeclareUnicodeCharacter{2209}{\ensuremath{\not\in}}% ∉ @@ -161,7 +167,11 @@ % \DeclareUnicodeCharacter{2026}{\ensuremath{\dots}}% … % Generated from ~/.XCompose using: -% cat /tmp/cal.txt | cut -d '"' -f 2- | tr '"' ' ' | cut -d ' ' -f 1,6 | while IFS=' ' read a b; do echo "\\DeclareUnicodeCharacter{$(printf "%X" "'$a")}{\\\\ensuremath{\\mathcal{$b}}}% $a"; done +% cat /tmp/cal.txt | cut -d '"' -f 2- | tr '"' ' ' | cut -d ' ' -f 1,6 \ +% | while IFS=' ' read a b; do +% echo -n "\\DeclareUnicodeCharacter{$(printf "%X" "'$a")}" +% echo "{\\\\ensuremath{\\mathcal{$b}}}% $a"; +% done \DeclareUnicodeCharacter{1D49C}{\ensuremath{\mathcal{A}}}% 𝒜 \DeclareUnicodeCharacter{212C}{\ensuremath{\mathcal{B}}}% ℬ diff --git a/graph-lib/lib/low/percent.rkt b/graph-lib/lib/low/percent.rkt index a41dbb3a..6081b83c 100644 --- a/graph-lib/lib/low/percent.rkt +++ b/graph-lib/lib/low/percent.rkt @@ -29,7 +29,8 @@ (define-splicing-syntax-class %assignment #:attributes ([pat.expanded 1] [expr 0]) #:literals (= in) - (pattern (~seq (~and maybe-pat (~not (~or = in))) ... (~datum =) expr:expr) + (pattern (~seq (~and maybe-pat (~not (~or = in))) ... + (~datum =) expr:expr) #:with [pat:%pat ...] #'(maybe-pat ...)))) (define-syntax (% stx) diff --git a/graph-lib/make/make.rkt b/graph-lib/make/make.rkt index c2173ef5..b33696eb 100644 --- a/graph-lib/make/make.rkt +++ b/graph-lib/make/make.rkt @@ -18,7 +18,7 @@ "-exec" "cp" "-af" "{}" "./build/" ";")) (current-directory "build")) -#;(run! (list (find-executable-path-or-fail "sh") +(run! (list (find-executable-path-or-fail "sh") "-c" @string-append{ found_long_lines=0