From d175d154c3d6594d53c57fc70a76b2854595972d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Mon, 4 Apr 2016 12:50:01 +0200
Subject: [PATCH] Part 2 of inline-instance-top
---
graph-lib/graph/graph-6-rich-returns.lp2.rkt | 22 ++++++++++++++---
graph-lib/graph/graph.scrbl | 26 ++++++++++++++++++++
graph-lib/lib/low.rkt | 1 +
graph-lib/lib/low/list.rkt | 5 ++++
graph-lib/lib/low/template.scrbl | 13 ++++++++++
graph-lib/lib/low/tmpl.rkt | 14 +++++++++++
graph-lib/lib/low/type-inference-helpers.rkt | 7 ++++--
7 files changed, 83 insertions(+), 5 deletions(-)
create mode 100644 graph-lib/graph/graph.scrbl
create mode 100644 graph-lib/lib/low/tmpl.rkt
diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
index e7bc65f2..14b35a1f 100644
--- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt
+++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
@@ -112,6 +112,7 @@ plain list.
(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/constructor-top2" (mapping …))
(define-temp-ids "~a/accumulator" (node …))
(define-temp-ids "~a/simple-mapping" (node …))
(define-temp-ids "~a/node" (mapping …))
@@ -292,7 +293,8 @@ identifier, so that it can be matched against by
<inline-type-top1>
<inline-instance-top1-types>
<inline-instance-top1>
- <outer-inline>]
+ <outer-inline>
+ <inline-instance-top2>]
We create the inlined-node by inlining the temporary nodes
in all of its fields:
@@ -473,9 +475,23 @@ layer of actual nodes. We do this in three steps:
…]
@chunk[<inline-instance-top2>
+ (define (mapping/constructor-top2 [param cp param-type] …)
+ (% <constructor-top2-body>))
+ …
+
+ (define #,(datum->syntax #'name 'DBG)
+ (list mapping/constructor-top2 …))]
+
+@chunk[<constructor-top2-body>
+ first-graph = (name/first-step #:root mapping/node param …)
+ alists = (list (!each mapping '()) …)
+ with-indices-top1 last-acc = ((inline-instance-top1* result-type ())
+ (get first-graph returned)
+ (cons 1 alists))
+ (_ . (node/accumulator …)) = last-acc
+ in
;; Call the second step graph constructor:
- (name #:roots (ann (cdr LAST-ACCUMULATOR)
- (list (vectorof (name/first-step mapping/node)))))]
+ (name #:roots [node (lists (cdrs node/accumulator))] …)]
@chunk[<inline-instance-top3>
(replace-in-instance #'TYPE??
diff --git a/graph-lib/graph/graph.scrbl b/graph-lib/graph/graph.scrbl
new file mode 100644
index 00000000..b342bfef
--- /dev/null
+++ b/graph-lib/graph/graph.scrbl
@@ -0,0 +1,26 @@
+#lang scribble/manual
+
+@(require scribble-enhanced/manual-form)
+
+@(require (for-label typed/racket/base
+ "graph.lp2.rkt"))
+
+@title{Low-level graph macro}
+
+
+@defform[(graph …)
+ #:result graph-id
+ #:contracts ([old-type (syntax-for type)]
+ [from (and/c identifier? (syntax-for type))]
+ [to (syntax-for type)])]{
+ …}
+
+@defform[(graph-id #:roots [node args] …)
+ #:result (List (Vectorof node/promise-type) …)
+ #:contracts ([args (Listof (List arg-type …))])]{
+ Create a graph instance, starting from the given root
+ arguments. Each element of the returned list contains a
+ vector with all the graph roots for that node type, in the
+ same order as their arguments were given. If there are some
+ duplicates in the lists of arguments, the same node will be
+ returned for both.}
\ No newline at end of file
diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt
index 18831c6e..5996b48f 100644
--- a/graph-lib/lib/low.rkt
+++ b/graph-lib/lib/low.rkt
@@ -12,6 +12,7 @@
"low/typed-rackunit.rkt"
"low/typed-rackunit-extensions.rkt"
"low/syntax-parse.rkt"
+ "low/tmpl.rkt"
"low/threading.rkt"
"low/aliases.rkt"
"low/sequence.rkt"
diff --git a/graph-lib/lib/low/list.rkt b/graph-lib/lib/low/list.rkt
index fa2b7eda..1b74312e 100644
--- a/graph-lib/lib/low/list.rkt
+++ b/graph-lib/lib/low/list.rkt
@@ -7,6 +7,11 @@
AListof)
(define-type (AListof K V) (Listof (Pairof K V)))
+ (define-match-expander alistof
+ (λ (stx)
+ (syntax-case stx ()
+ [(keys-pat vals-pat)
+ #'(list (cons keys-pat vals-pat) …)])))
(: indexof (∀ (A B) (→ A (Listof B) (→ A B Any) (U #f Integer))))
(define (indexof elt lst [compare equal?])
diff --git a/graph-lib/lib/low/template.scrbl b/graph-lib/lib/low/template.scrbl
index c33c8f3b..e8f0f551 100644
--- a/graph-lib/lib/low/template.scrbl
+++ b/graph-lib/lib/low/template.scrbl
@@ -86,6 +86,13 @@ Keywords: grammar, parser, template.
(~sort key template ooo)
(~loc stxloc . template)
+ ;; Like (template . template), but discards the first and
+ ;; keeps just the second. If the first contains pattern
+ ;; variables which are repeated, this has the effect of
+ ;; repeating the second as many times as the first. Example:
+ ;; #'(vector (~each some-pattern-var '()))
+ ;; => (vector '() '() '() '() '())
+ (~each template template)
;; escaped
(ddd escaped)
@@ -233,6 +240,12 @@ This can also be used to rename the @racket[parse] and
@racket[tmpl] could be renamed to @racket[quasisyntax], or
something similar).
+Otherwise, @racket[grammar/custom] could just @racket[set!]
+some for-syntax variable which stores the options. A second
+boolean for-syntax variable could be used to check if
+@racket[grammar/custom] was called twice, and throw an error
+in that case.
+
Or maybe we should just use units? Can they be customized in
a similar way?
diff --git a/graph-lib/lib/low/tmpl.rkt b/graph-lib/lib/low/tmpl.rkt
new file mode 100644
index 00000000..ade54aa9
--- /dev/null
+++ b/graph-lib/lib/low/tmpl.rkt
@@ -0,0 +1,14 @@
+#lang typed/racket
+(require "typed-untyped.rkt")
+(define-typed/untyped-modules #:no-test
+ (provide !each)
+
+ (module m-!each racket
+ (provide !each)
+ (require syntax/parse/experimental/template)
+
+ (define-template-metafunction (!each stx)
+ (syntax-case stx ()
+ [(_ a b) #'b])))
+
+ (require 'm-!each))
\ No newline at end of file
diff --git a/graph-lib/lib/low/type-inference-helpers.rkt b/graph-lib/lib/low/type-inference-helpers.rkt
index 9db433d0..afe221c8 100644
--- a/graph-lib/lib/low/type-inference-helpers.rkt
+++ b/graph-lib/lib/low/type-inference-helpers.rkt
@@ -1,7 +1,7 @@
#lang typed/racket
(require "typed-untyped.rkt")
(define-typed/untyped-modules #:no-test
- (provide cars cdrs)
+ (provide cars cdrs lists)
#|
;; This does not work, in the end.
@@ -22,4 +22,7 @@
(define (cars l) ((inst map A (Pairof A Any)) car l))
(: cdrs (∀ (B) (→ (Listof (Pairof Any B)) (Listof B))))
- (define (cdrs l) ((inst map B (Pairof Any B)) cdr l)))
\ No newline at end of file
+ (define (cdrs l) ((inst map B (Pairof Any B)) cdr l))
+
+ (: lists (∀ (A) (→ (Listof A) (Listof (List A)))))
+ (define (lists l) ((inst map (List A) A) (λ (x) (list x)) l)))
\ No newline at end of file