From 20802f257f3cd29ad4ad1b5eb15fdfbb951a31eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 31 Mar 2016 18:36:01 +0200 Subject: [PATCH] Uncommited changes. --- graph-lib/graph/adt.scrbl | 7 +- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 155 +++++++++++- graph-lib/graph/graph-test.rkt | 2 +- graph-lib/graph/graph.lp2.rkt | 13 +- graph-lib/graph/rewrite-type.scrbl | 25 ++ graph-lib/lib/low/in.rkt | 6 +- graph-lib/lib/low/percent.rkt | 10 +- graph-lib/lib/low/percent.scrbl | 58 +++++ graph-lib/lib/low/template.scrbl | 252 +++++++++++++++++++ 9 files changed, 505 insertions(+), 23 deletions(-) create mode 100644 graph-lib/lib/low/percent.scrbl create mode 100644 graph-lib/lib/low/template.scrbl diff --git a/graph-lib/graph/adt.scrbl b/graph-lib/graph/adt.scrbl index 18de762a..fc99c38f 100644 --- a/graph-lib/graph/adt.scrbl +++ b/graph-lib/graph/adt.scrbl @@ -6,6 +6,7 @@ @doc-lib-setup @defform[#:kind "type expander" + #:literals (:) (tagged tag field-desc) #:grammar [(tag Identifier) @@ -32,7 +33,8 @@ (tagged)]{ } -@defform*[((tagged maybe-instance tag just-field …) +@defform*[#:literals (:) + ((tagged maybe-instance tag just-field …) (tagged maybe-make-instance tag field+value …)) #:grammar [(maybe-instance (code:line) @@ -72,7 +74,8 @@ @defform[(tagged? tag #:with-struct with-struct - field)]{ + field) + #:contracts ([with-struct struct-type?])]{ The @racket[#:with-struct] option is reserved for internal use. It is used by @racket[#:private] and @racket[#:uninterned] in @racket[define-contructor] and diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index fd0f5584..d76faf75 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -111,6 +111,8 @@ plain list. (define/with-syntax (node* …) #'(node …)) (define-temp-ids "~a/first-step" name) (define-temp-ids "first-step-expander2" name) + (define-temp-ids "top1-accumulator-type" name) + (define-temp-ids "~a/accumulator" (node …)) (define-temp-ids "~a/simple-mapping" (node …)) (define-temp-ids "~a/node" (mapping …)) (define-temp-ids "~a/extract/mapping" (node …)) @@ -120,6 +122,9 @@ plain list. (define-temp-ids "~a/from-first-pass" (node …)) (define-temp-ids "second-step-~a/node-of-first" (mapping …)) (define-temp-ids "second-step-~a-of-first" (node …)) + (define-temp-ids "~a/node-index" (mapping …)) + (define-temp-ids "~a/node-index-marker" (mapping …)) + (define-temp-ids "~a/node-index?" (mapping …)) ;(define step2-introducer (make-syntax-introducer)) ;(define/with-syntax id-~> (datum->syntax #'name '~>)) ;(define/with-syntax introduced-~> (datum->syntax #'name '~>)) @@ -130,7 +135,8 @@ plain list. (quasitemplate (define-graph name/first-step #:definitions [] - [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 field …)]] … @@ -189,7 +195,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 + [mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here [node (name #:placeholder City)]) #;(U (name/first-step mapping/node) (tmpl-replace-in-type result-type @@ -197,7 +203,7 @@ produced by the first step. [node (name/first-step node)]))) … - ;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-type-expander (second-step-marker-expander stx) (syntax-parse stx ;; TODO: should be ~literal @@ -216,10 +222,11 @@ produced by the first step. (define-type-expander (second-step-marker2-expander stx) (syntax-parse stx ;; TODO: should be ~literal - [(_ (~datum mapping)) #'(U second-step-mapping/node-of-first - result-type #;(tmpl-replace-in-type result-type - [mapping/node (name/first-step mapping/node)] - [node (name/first-step node)]))] + [(_ (~datum mapping)) + #'(U second-step-mapping/node-of-first + result-type #;(tmpl-replace-in-type result-type + [mapping/node (name/first-step mapping/node)] + [node (name/first-step node)]))] … ;; TODO: should fall-back to outer definition of ~>, if any? ))] @@ -275,7 +282,7 @@ in all of its fields: @chunk[ ;; inline from the field-type of the old node. - (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ()) (get from field)) …)] @@ -291,7 +298,8 @@ recursively: (syntax-parse stx [(_ i-ty seen) (define/with-syntax replt - (replace-in-type #'(Let (id-~> second-step-marker2-expander) i-ty) + (replace-in-type #'(Let (id-~> second-step-marker2-expander) + i-ty) #'([node second-step-node-of-first] …))) (displayln (list "replt=" #'replt)) @@ -328,6 +336,8 @@ recursively: We need to inline the mapping nodes between the root mapping node and the first layer of actual nodes. We do this in three steps: +@; TODO: example + test + @itemlist[ @item{First, we replace the actual nodes with placeholders, which contain just an index, and aggregate @@ -337,6 +347,130 @@ 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[ + (define-constructor mapping/node-index + #:private + #:? mapping/node-index? + Index) + … + (define-type mapping/node-index-marker mapping/node-index) + … + + (define-type top1-accumulator-type + (pairof Index ;; max + (list (listof (name/first-step node)) + …)))] + +@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-expander) + i-ty) + #'([node second-step-node-of-first] + …))) + (displayln (list "replt=" #'replt)) + #'(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 + #'( + ))])))] + +@chunk[ + [second-step-mapping/node-of-first ;; from + (inline-type result-type (mapping/node . seen)) ;; to + (name/first-step #:? mapping/node) ;; pred? + (λ ([x : second-step-mapping/node-of-first] ;; fun + [acc : top1-accumulator-type]) + (values ((inline-instance-top1* result-type (mapping/node . seen)) + (get x returned)) + ACC))] + …] + +@chunk[ + [second-step-node-of-first ;; node of first step ;; from + mapping/node-index-marker ;; new type ;; to + (name/first-step #:? node) ;; pred? + ;node/extract/mapping] ;; call mapping ;; fun + (λ ([x : second-step-node-of-first] + [acc : top1-accumulator-type]) + : (values mapping/node-index-marker + top1-accumulator-type) + (% (idx . (node/accumulator …)) = acc + + in + (values PLACEHOLDER + (cons (add1 idx) + (NEW-NDS …)))))] + …] + +@chunk[ + ;; Call the second step graph constructor: + (name #:roots (ann (cdr LAST-ACCUMULATOR) + (list (vectorof (name/first-step mapping/node)))))] + +@chunk[ + (replace-in-instance #'TYPE?? + #'([mapping/node-index ;; from + (name node) ;; to + mapping/node-index? ;; pred? + (λ ([idx : mapping/node-index]) ;; fun + (VECTOR-REF ??? (constructor-values idx))) + ]))] + +@(begin #| +@CHUNK[ + (define-syntax (inline-instance-top3* stx) + (dbg + ("inline-instance-top3*" 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-top3 replt seen)]))) + + (define-syntax (inline-instance-top3 stx) + (dbg + ("inline-instance-top3" stx) + (syntax-parse stx + [(_ i-t (~and seen (:id (… …)))) + + (replace-in-instance #'i-t + #'( + ))])))] + +@chunk[ + [second-step-mapping/node-of-first ;; from + (inline-type result-type (mapping/node . seen)) ;; to + (name/first-step #:? mapping/node) ;; pred? + (λ ([x : second-step-mapping/node-of-first]) ;; fun + ((inline-instance-top3* result-type (mapping/node . seen)) + (get x returned)))] + …] + +@chunk[ + [second-step-node-of-first ;; node of first step ;; from + (name #:placeholder node) ;; new type ;; to + (name/first-step #:? node) ;; pred? + node/extract/mapping] ;; call mapping ;; fun + …] +|#) + @subsection{Inlining types} The input type for the inlining of field @tc[streets] of the node @tc[City] is: @@ -558,7 +692,8 @@ encapsulating the result types of mappings. ;(display ">>> ")(displayln (list . log)) (let ((res (let () . body))) ;(display "<<< ")(displayln (list . log)) - ;(display "<<<= ")(display (car (list . log)))(display res)(displayln ".") + ;(display "<<<= ")(display (car (list . log))) + ;(display res)(displayln ".") res)))) )] diff --git a/graph-lib/graph/graph-test.rkt b/graph-lib/graph/graph-test.rkt index 7e0242b5..87257f9d 100644 --- a/graph-lib/graph/graph-test.rkt +++ b/graph-lib/graph/graph-test.rkt @@ -32,7 +32,7 @@ ;; Check that the two requests for (splash) give the same node: ;; Also, (n2) is disconnected from the rest of the graph. (check-true: - (% ((a b c d) (e) ()) + (% (#(a b c d) #(e) #()) = (gr-simple #:roots [Fountain '((splash) (splish) (splash) (soak))] [Node2 '((n2))] diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index d124b181..eba02edb 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -453,16 +453,17 @@ node. @chunk[ (: name/multi-constructor (→ (Listof (List param-type …)) - … - (List (Listof node/promise-type) …))) + … + (List (Vectorof node/promise-type) …))) (define (name/multi-constructor node/multi-rest …) (% (node/multi-indices …) (node/database …) = in (begin ) … - (list (map (λ ([idx : Index]) - (node/with-indices→with-promises - (vector-ref node/database idx))) - node/multi-indices) + (list (list->vector + (map (λ ([idx : Index]) + (node/with-indices→with-promises + (vector-ref node/database idx))) + node/multi-indices)) …)))] @chunk[ diff --git a/graph-lib/graph/rewrite-type.scrbl b/graph-lib/graph/rewrite-type.scrbl index 96c1e099..a194c6fe 100644 --- a/graph-lib/graph/rewrite-type.scrbl +++ b/graph-lib/graph/rewrite-type.scrbl @@ -61,4 +61,29 @@ new type. 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.} + +@defform[#:kind "procedure" + (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 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]. The generated function takes as a second + argument an initial value for the accumulator. The + accumulator is passed to @racket[fun] and the one returned + is used as the accumulator for the next call. No guarantee + is made on the order of traversal. + + @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/lib/low/in.rkt b/graph-lib/lib/low/in.rkt index e2aa0af2..45b8124f 100644 --- a/graph-lib/lib/low/in.rkt +++ b/graph-lib/lib/low/in.rkt @@ -5,4 +5,8 @@ (require racket/stxparam) (define-syntax-parameter in - (λ _ "`in' used out of context. It can only be used in some forms.")) \ No newline at end of file + (λ (stx) + (raise-syntax-error + 'in + "used out of context. It can only be used in some forms." + stx))) \ No newline at end of file diff --git a/graph-lib/lib/low/percent.rkt b/graph-lib/lib/low/percent.rkt index 7b1acd3c..a41dbb3a 100644 --- a/graph-lib/lib/low/percent.rkt +++ b/graph-lib/lib/low/percent.rkt @@ -3,8 +3,10 @@ (define-typed/untyped-modules #:no-test (provide % define% in) - (require (for-syntax syntax/parse)) - (require "in.rkt") + (require (for-syntax syntax/parse + "typed-untyped.rkt") + "in.rkt") + (begin-for-syntax (require-typed/untyped "aliases.rkt")) #|(define-syntax (% stx) (syntax-parse stx #:literals (= → :) @@ -21,7 +23,9 @@ (pattern () #:with expanded #'(list)) (pattern (x:%pat . rest:%pat) - #:with expanded #'(cons x.expanded rest.expanded))) + #:with expanded #'(cons x.expanded rest.expanded)) + (pattern #(x:%pat …) + #:with expanded #'(vector x.expanded …))) (define-splicing-syntax-class %assignment #:attributes ([pat.expanded 1] [expr 0]) #:literals (= in) diff --git a/graph-lib/lib/low/percent.scrbl b/graph-lib/lib/low/percent.scrbl new file mode 100644 index 00000000..46a0439f --- /dev/null +++ b/graph-lib/lib/low/percent.scrbl @@ -0,0 +1,58 @@ +#lang scribble/manual + +@(require (for-label typed/racket/base + "percent.rkt")) + +@title{@racket[let-in] binding and destructuring form} + +@defform[#:literals (in = and) + (% parallel-binding … + maybe-in + body …) + #:grammar + [(parallel-binding (code:line binding and parallel-binding) + binding) + (binding (code:line pattern … = expr)) + (maybe-in (code:line) + in) + (expr expression)]]{ + Locally binds the variables in the @racket[pattern]s to the + @racket[expr]. Each binding clause should contain as many + @racket[pattern]s as @racket[expr] produces values. The + @racket[body …] forms are evaluated with the given + variables bound. + + The bindings are executed in sequence, as if bound with + @racket[let*], unless grouped using @racket[and], in which + case they are executed in parallel, as if bound with + @racket[let]. + + NOTE: TODO: for now bindings are run in sequence, and + parallel bindings have not been implemented yet.} + + +@defform[#:literals (: :: …) + (define% (name pattern …) + body …) + #:grammar + [(pattern variable + [variable : type] + cons-pattern + list-pattern + vector-pattern) + (cons-pattern (pattern . pattern) + (pattern :: pattern)) + (list-pattern (pattern …) + (pattern … :: tail-pattern)) + (tail-pattern pattern) + (vector-pattern #(pattern …)) + (variable identifier)]]{ + Locally binds the variables in the @racket[pattern]s to the + @racket[expr]. Each binding clause should contain as many + @racket[pattern]s as @racket[expr] produces values. The + @racket[body …] forms are evaluated with the given + variables bound. + + The bindings are executed in parallel, as if bound with + @racket[let].} + diff --git a/graph-lib/lib/low/template.scrbl b/graph-lib/lib/low/template.scrbl new file mode 100644 index 00000000..c33c8f3b --- /dev/null +++ b/graph-lib/lib/low/template.scrbl @@ -0,0 +1,252 @@ +#lang scribble/manual + +@(require (for-label typed/racket/base + syntax/parse + ;"template.rkt" + )) + +@(define ellipses (racket ...)) + +@title{Versatile parser and template library} + +Keywords: grammar, parser, template. + +@defform[(parse expr [pattern body …] …)]{ + Analogous to @racket[syntax-parse], except it isn't + specialized for syntax, but rather works for arbitrary + s-expressions, including syntax ones (denoted by + @racket[#'(…)] in the pattern).} + +@defform[#:literals (: :: ... else struct) + (tmpl template) + #:grammar + [(template variable + [variable : type] ;; (ann variable type) + ;; cons-template + (template . template) + (template :: template) + + ;; list + (template**) + ;; list* + template**-dotted + + ;; vector + #(template**) + (vector . template**-dotted) + + ;; hash-template: template** must expand to a list of pairs. + (hash . template**-dotted) ;; TODO: how to distinguish + (hasheq . template**-dotted) ;; mutable and immutable? + (hasheqv . template**-dotted) + #hash([template . template]) + #hasheq([template . template]) + #hasheqv([template . template]) + + ;; struct-template + (struct-id template …) + (struct struct-id template …) + #s(prefab-id template …) + #s(template template …) ;; Only allowed in untyped racket + + ;; box + #&template + + ;; call-template + (~identifier args …) ;; calls (identifier args …) + (~ expr args …) ;; calls (expr args …) + + ;; unquote-template + ,expr + ,@(list expr) + ,@(list* expr) ;; must appear in last position. + + + ;; template-expander + template-expander-id + (template-expander-id args …) + + ;; maybe-template (should all be template expanders + ;; which means the system is extensible enough to express + ;; these special cases). + (?? alt-template …) + (?@ . template**-dotted) + (??@ . template**-dotted) + (?if condition template template) + (|@if| condition template template) + (if@ condition template template) + (|@cond| [condition template] …) + (|@cond| [condition template] … [else template]) + (cond@ condition template template) + + ;; like #,@(with-syntax ([meta-var #'template]) + ;; #'(template**)) + (~let ([meta-var+args template]) + . template**-dotted) + + (~sort key template ooo) + (~loc stxloc . template) + + ;; escaped + (ddd escaped) + + ;; + + ;; literal + #t + #f + string + bytes + number + char + keyword + regexp + pregexp) + + (meta-var+args meta-var + (meta-var meta-arg …)) + + (tail-template template) + + ;; specialize mid-sequence in repetition (diagonal-matrix-style) + + (variable identifier) + + (template**-dotted (template* … . template) + template**) + (template** (code:line template* …) + (code:line template* … :: template) + (code:line template* … (~rest . template))) + (template* template + (code:line template ooo) + special-cased-template) + (special-cased-template (code:line template vardd) + (code:line template ddvar)) + ;; Where var is an iterated variable. + (vardd var.. ;; exclude the current iteration + var...) ;; include the current iteration + (ddvar ..var ;; exclude the current iteration + ...var) ;; include the current iteration + + (ooo #,ellipses ;; TODO: make it a hyperlink + ___ + ..k ;; k positive integer + __k ;; k positive integer + (code:line .. expr) ;; expr must return a positive integer + (code:line __ expr)) ;; expr must return a positive integer + (ddd #,ellipses) + ]]{ + TODO: implement the versatile template library. + @racket[...] + + TODO: support for typed/racket. + + The patterns for @racket[parse] should all have a way to + create a symmetric counterpart for @racket[tmpl], which + produces the original value. This symmetry is important + because allows lens-like macros, which operate on only part + of the data structure, leaving everything else intact. + + @racket[??] works like @racket[??] from + @racket[syntax/parse/experimental/template], except it + allows any number of alternatives (including 0, to avoid + special-casing in macros). It is more or less equivalent to + @racket[(?? a (?? b (?? c …)))], following syntax/parse's + semantics. + + @racket[?@] has the same meaning as in syntax/parse. + + @racket[(??@ t* …)] is a shortcut for + @racket[(?? (?@ t* …))] + + For better compatibility with at-exp, @racket[|@if|] can be + written @racket[if@], and the same goes for + @racket[|@cond|] etc. + + TODO: what's the difference between @racket[~], + @racket[template-expander] and @racket[unquote]? + @racket[template-expander] runs at compile-time and should + treat its arguments as syntax. + + Concerning unquoting, unlike @racket[racket]'s default + behaviour in @RACKET[#'([x #,(y …)] …)], unquoting should + not break the nesting of ellipses. How should we express + voluntary variation of the level of nesting? @racket[~let] + already allows expanding part of the template at some level + and inserting it verbatim somewhere below, but it's not a + silver bullet. One case which comes to mind is when some of + the nested data should be mixed with less-nested data, for + example going from + @racket[([10 1 2 3] [100 4 5] [1000 6])] to + @racket[([10 20 30] [400 500] [6000])] should be relatively + easy to express. Maybe @racket[~let] with parameters can be + a suitable generalized solution: + @RACKET[({~let ([(addx v) #,(+ x v)]) [(addx y) …]} …)] + + The special-cased template syntax should allow special + treatment of the @racket[i]-th iteration in a doubly-nested + loop: matching @racket[x] on @racket[(1 2 3 4 5)], and + using the template @racket[(0 x.. ,(* x x) ..x 1) …] will + produce @racket[(1 1 1 1 1) + (0 4 1 1 1) + (0 0 9 1 1) + (0 0 0 16 1) + (0 0 0 0 24)]. The pattern before + @racket[x..] and the pattern after @racket[..x] can expand + to multiple items which will be spliced in by wrapping it + with @racket[?@].} + +@section{Ideas for implementation} + +@subsection{Extensibility (expanders)} + +Allow normal, inline-prefix, inline-postfix and inline-infix +expanders, which can bind using regular expressions. This +allows implementing exotic syntax like @racket[var..] +(postfix, operates on the pattern preceeding it), +@racket[..var] (postfix, operates on the pattern after it), +@racket[(… escaped-pattern)] (normal, operates on the +containing s-exp) + +@subsection{Customization} + +For things that are likely to be customized by the user in +the whole file scope, define a grammar/custom module, used +as follows: + +@racketblock[(require grammar/custom) + (grammar/custom option …)] + +The @racket[grammar/custom] macro expands to +@racket[(require grammar/core)] followed by a bunch of +@racket[define-syntax] which wrap the core macros, providing +them the custom options: + +@racketblock[(require grammar/core) + (define-syntax-rule (parse . rest) + (parse/core #:global-options (option …) . rest)) + (define-syntax-rule (tmpl . rest) + (parse/core #:global-options (option …) . rest))] + +This can also be used to rename the @racket[parse] and +@racket[tmpl] macros, if desired (for example, +@racket[tmpl] could be renamed to @racket[quasisyntax], or +something similar). + +Or maybe we should just use units? Can they be customized in +a similar way? + +The idea is to avoid having to wrap the whole file in a +@racket[(parameterize …)], and be able to easily +@racket[provide] a customized variation of this library: + +@racketblock[(provide (customized-out grammar/custom))] + +@subsection{Things to look at} + +@itemlist[ + @item{@racket[math/arry], for @racket[::] and array + broadcasting.} + @item{Quasipatterns in @racket[match].} + @item{The @racket[lens] library}] +