From 4d911ef7d6dabc400d84a2f9d022aaa748d7e002 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 2 Feb 2016 21:38:09 +0100
Subject: [PATCH] Finished implementing FB case 86 (Graph: Multiple
constructors).
---
graph-lib/graph/__DEBUG_graph5.rkt | 52 ++++-----
graph-lib/graph/dotlang.rkt | 2 +-
graph-lib/graph/fold-queues.lp2.rkt | 56 +---------
graph-lib/graph/graph-5-multi-ctors.lp2.rkt | 104 ++++++++++--------
graph-lib/graph/graph.lp2.rkt | 14 ++-
graph-lib/graph/remember.rkt | 7 ++
graph-lib/lib/low.rkt | 28 ++++-
.../2016-02-02--all-nodes-point-to-root.rkt | 35 ++++++
8 files changed, 161 insertions(+), 137 deletions(-)
create mode 100644 graph-lib/test/regression/2016-02-02--all-nodes-point-to-root.rkt
diff --git a/graph-lib/graph/__DEBUG_graph5.rkt b/graph-lib/graph/__DEBUG_graph5.rkt
index e274e8bf..7d412d70 100644
--- a/graph-lib/graph/__DEBUG_graph5.rkt
+++ b/graph-lib/graph/__DEBUG_graph5.rkt
@@ -10,7 +10,6 @@
: (g2 b)
(error "niy!"))|#
-;#|
#|
(module mm typed/racket
(require ;(submod "graph.lp2.rkt" test)
@@ -41,41 +40,36 @@
(define-graph g2 [a [v : Number] ((ma) (a 1))])
|#
-(require "graph-5-multi-ctors.lp2.rkt")
-(require "../lib/low.rkt"
+(require "graph-5-multi-ctors.lp2.rkt"
+ "../lib/low.rkt"
"graph.lp2.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt"
- "../type-expander/multi-id.lp2.rkt")
+ "../type-expander/multi-id.lp2.rkt"
+ (for-syntax syntax/parse))
-(define-graph/multi-ctor gm ([a [b1 : b] [b2 : b] [v : Number]]
+(define-graph/multi-ctor gm ([a [b1 : b] [b2 : b] [s : String] [v : Number]]
[b [a : a] [s : String] [v : Number]])
- [(r [v : Number] [w : String])
+ [(r [v : Integer] [w : String])
: a
- (a (bx (if (> 0 v) (sub1 v) (+ v (string-length w))))
- (by (if (> 0 v) (sub1 v) (+ v (string-length w))) "xyz")
+ (printf "r ~a ~a\n" v w)
+ (a (bx (if (> v 0) (sub1 v) (string-length w)))
+ (by (if (> v 0) (sub1 v) (string-length w)) "xyz")
+ w
v)]
- [(bx [v : Number])
+ [(bx [v : Integer])
: b
- (b (r v) "x" v)]
- [(by [v : Number] [w : String])
+ (printf "bx ~a\n" v)
+ (b (r v "one") "x" v)]
+ [(by [v : Integer] [w : String])
: b
- (b (r v) "y" (+ v (string-length w)))])
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+ (printf "by ~a ~a\n" v w)
+ (b (r v "two") "y" (+ v (string-length w)))])
+(define gmi (gm 3 "b"))
+(check-equal?: (get gmi v) 3)
+(check-equal?: (get gmi b1 v) 2)
+(check-equal?: (get gmi b1 s) "x")
+(check-equal?: (get gmi b1 a v) 2)
+;(check-equal?: (get gmi b1 a b1 a v) 1)
+;(check-equal?: (get gmi b1 a b1 a b1 v) 1)
diff --git a/graph-lib/graph/dotlang.rkt b/graph-lib/graph/dotlang.rkt
index 0c0aaced..e53a2aa8 100644
--- a/graph-lib/graph/dotlang.rkt
+++ b/graph-lib/graph/dotlang.rkt
@@ -154,7 +154,7 @@
(check-equal?: 'aa.….bb.cc.d (list 'get 'aa '… 'bb 'cc 'd))
(check-equal?: 'aa…bb (list 'get 'aa '… 'bb))
- (check-equal?: 'aa… (slen 2 "a…"))
+ (check-equal?: 'aa… (slen 3 "aa…"))
(check-equal?: '… (slen 1 "…"))
diff --git a/graph-lib/graph/fold-queues.lp2.rkt b/graph-lib/graph/fold-queues.lp2.rkt
index 09f20585..386e0f00 100644
--- a/graph-lib/graph/fold-queues.lp2.rkt
+++ b/graph-lib/graph/fold-queues.lp2.rkt
@@ -133,7 +133,7 @@ database type opaque, and use an accessor with signature
(match q
[(list h (cons e rest-rs) s i)
(values e
- (list h rest-rs s (assert (- i 1) index?)))]
+ (list h rest-rs s i #;(assert (- i 1) index?)))]
[(list h '() s i)
(Δ-hash2-dequeue (list h (reverse s) '() i))]))]
@@ -219,58 +219,6 @@ position in the vector equal to the index associated to it in the hash table:
Δ-hash2-enqueue)
(process-queues new-Δ-queues (name/Δ-results-add results result)))]
-@subsection{Δ-Hash}
-
-@tc[Δ-Hash] is a type encapsulating both a hash, and a set of key-value pairs
-added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable].
-
-@chunk[<Δ-hash>
- (module Δ-hash typed/racket
- (require "../lib/low.rkt")
- (define-type (Δ-Hash A B)
- (Pairof (HashTable A B)
- (Setof (Pairof A B))))
-
- (: empty-Δ-hash (∀ (K V) (→ (Δ-Hash K V))))
- (define (empty-Δ-hash)
- (cons ((inst hash K V)) ((inst set (Pairof K V)))))
-
- (: Δ-hash (∀ (K V) (→ (HashTable K V) (Δ-Hash K V))))
- (define (Δ-hash h)
- (cons h ((inst set (Pairof K V)))))
-
- (: Δ-hash-add (∀ (K V Acc) (→ (Δ-Hash K V)
- K
- Acc
- (→ K Acc (values V Acc))
- (values (Δ-Hash K V)
- Acc))))
- (define (Δ-hash-add Δ-hash k acc make-v)
- (if (hash-has-key? (car Δ-hash) k)
- (values Δ-hash acc)
- (% v new-acc = (make-v k acc)
- (values (cons (hash-set (car Δ-hash) k v)
- (set-add (cdr Δ-hash) (cons k v)))
- new-acc))))
-
- (: Δ-hash-get-Δ (∀ (K V) (→ (Δ-Hash K V) (Setof (Pairof K V)))))
- (define (Δ-hash-get-Δ Δ-hash) (cdr Δ-hash)))]
-
-@section{@racket{cond-let}}
-
-@CHUNK[<cond-let>
- (define-syntax (cond-let stx)
- (syntax-parse stx
- [(_)
- #'(typecheck-fail #,stx)]
- [(_ #:let bindings:expr clause …)
- #'(let bindings (cond-let clause …))]
- [(_ [condition:expr (~seq #:else-let binding …) … . body] clause …)
- #'(if condition
- (begin . body)
- (let (binding … …)
- (cond-let clause …)))]))]
-
@section{Conclusion}
@chunk[<module-main>
@@ -284,8 +232,6 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable].
(provide fold-queues)
- <cond-let>
- <Δ-hash>
<fold-queue-multi-sets-immutable-tags>)]
@chunk[<module-test>
diff --git a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
index 83759a50..3d021f80 100644
--- a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
+++ b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
@@ -38,8 +38,11 @@ And @tc[<mapping-declaration>] is:
(define-temp-ids "~a/mapping" (node …))
(define-temp-ids "~a/arg" (node …))
(define-temp-ids "~a/function" (mapping …))
+ (define-temp-ids "~a/placeholder" (mapping …))
(define-temp-ids "~a/hide" (node …))
(define-temp-ids "~a/hide" (result-node …))
+ ;(define/with-syntax (result-node/hide …)
+ ; (cdr-assoc-syntax #'([node . node/hide] …)))
(define/with-syntax ([(grouped-mapping
grouped-mapping/function
[(grouped-param . grouped-param-type) …]
@@ -53,6 +56,8 @@ And @tc[<mapping-declaration>] is:
result-node
body) …)))
#'(node …)))
+ (define/with-syntax ((node/arg↓ …) …)
+ (repeat-stx (node/arg …) ((grouped-mapping …) …)))
(define/with-syntax (mapping/grouped …)
(stx-map (λ (mr) (cdr-assoc-syntax mr #'([node . node/mapping] …)))
#'(result-node …)))
@@ -65,30 +70,31 @@ And @tc[<mapping-declaration>] is:
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
- #`(debug
- (begin
- (define-graph name/wrapped
- #:definitions
- ((define-multi-id name
- #:type-expander
- (λ (stx)
- (syntax-case stx ()
- [(_ . rest) #'(name/wrapped . rest)]))
- #:call (λ (stx)
- (syntax-parse stx
- [(_ . rest)
- (syntax/loc stx
- (name/constructor . rest))]))
- #:id (λ (stx)
- (syntax/loc stx name/constructor)))
- (define (name/constructor [root-param : root-param-type] …)
- (name/wrapped #:root root-node (list 'root-mapping
- root-param …)))
- <define-mappings>)
- [node [field c field-type] …
- ((node/mapping [node/arg : <node-arg-type>])
- <mapping-body>)]
- …))))]
+ (quasitemplate
+ ;(debug
+ (begin
+ (define-graph name/wrapped
+ #:definitions
+ ((define-multi-id name
+ #:type-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ . rest) #'(name/wrapped . rest)]))
+ #:call (λ (stx)
+ (syntax-parse stx
+ [(_ . rest)
+ (syntax/loc stx
+ (name/constructor . rest))]))
+ #:id (λ (stx)
+ (syntax/loc stx name/constructor)))
+ (define (name/constructor [root-param : root-param-type] …)
+ (name/wrapped #:root root-node (list 'root-mapping
+ root-param …)))
+ <define-mappings>)
+ [node [field c field-type] …
+ ((node/mapping [node/arg : <node-arg-type>])
+ <mapping-body>)]
+ …))#|)|#))]
Where the type for the merged mapping is:
@@ -96,32 +102,39 @@ Where the type for the merged mapping is:
(U (List 'grouped-mapping grouped-param-type …) …)]
@chunk[<define-mappings>
- (define (mapping/function node/hide … ; nodes
- result-node/hide ; self
- [param : param-type] …)
- : (name result-node)
- (let ([node node/hide] …)
- (let ([result-node result-node/hide])
- (? '<bdy>))))
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (begin
+ (: mapping/placeholder (→ param-type …
+ (name/wrapped #:placeholder result-node)))
+ (define (mapping/placeholder param …)
+ ((tmpl-cdr-assoc-syntax result-node [node . node/mapping] …)
+ (list 'mapping param …)))
+ (: mapping/function (→ ;(name/wrapped #:make-placeholder node) …
+ ;(name/wrapped #:make-incomplete result-node)
+ param-type …
+ (name/wrapped #:incomplete result-node)))
+ (define (mapping/function ;node/hide … ; nodes
+ ;result-node/hide ; self
+ param …)
+ (let ([result-node/hide result-node])
+ (let ([mapping mapping/placeholder] …)
+ (let ([result-node result-node/hide])
+ . body)))))
…]
-@chunk[<bdy>
- (let ([node-names… node_]
- ;[mapping mapping/grouped] …
- [node-name_ node_])
- body)]
-
We then select in the grouped mapping which one to call.
@chunk[<mapping-body>
- (let ((a node/arg))
- (cond
- [(eq? (car a) 'grouped-mapping)
- (apply grouped-mapping/function
- #,@#'(node …)
- grouped-result-node
- (cdr a))]
- …))]
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (cond
+ [(eq? (car node/arg↓) 'grouped-mapping)
+ (apply grouped-mapping/function
+ ;#,@#'(node …)
+ ;grouped-result-node
+ (cdr node/arg↓))]
+ …)]
TODO: At the call site, use a macro and annotate the function (given by its
name) with the right type, so that the user doesn't see all the types in the
@@ -135,6 +148,7 @@ name) with the right type, so that the user doesn't see all the types in the
@chunk[<module-main>
(module main typed/racket
(require (for-syntax syntax/parse
+ syntax/parse/experimental/template
racket/syntax
syntax/stx
"../lib/low-untyped.rkt"
diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt
index d7761ba2..65c54107 100644
--- a/graph-lib/graph/graph.lp2.rkt
+++ b/graph-lib/graph/graph.lp2.rkt
@@ -553,10 +553,16 @@ via @tc[(g Street)].
@chunk[<graph-type-expander>
(λ (stx)
(syntax-parse stx
- [(_ (~datum node)) #'node/with-promises-type]
- …
- [(_ #:incomplete (~datum node)) #'node/incomplete-type]
- …))]
+ [(_ (~datum node)) #'node/with-promises-type] …
+ [(_ #:incomplete (~datum node)) #'node/incomplete-type] …
+ [(_ #:make-incomplete (~datum node))
+ #'(→ <field/incomplete-type> … node/incomplete-type)] …
+ [(_ #:incomplete (~datum node) fld)
+ (syntax-parse #'fld
+ [(~datum field) #'<field/incomplete-type>] …)] …
+ [(_ #:make-placeholder (~datum node))
+ #'(→ param-type … node/placeholder-type)] …
+ [(_ #:placeholder (~datum node)) #'node/placeholder-type] …))]
We will be able to use this type expander in function types, for example:
diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt
index ca8c6904..3fc40263 100644
--- a/graph-lib/graph/remember.rkt
+++ b/graph-lib/graph/remember.rkt
@@ -78,3 +78,10 @@
(structure v w)
(structure v w)
(structure v w)
+(structure b1 b2 s v)
+(structure b1 b2 s v)
+(structure b1 b2 s v)
+(structure ab v)
+(structure ba v)
+(structure ab v)
+(structure ab v)
diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt
index 2eca2d1c..ed5cf997 100644
--- a/graph-lib/lib/low.rkt
+++ b/graph-lib/lib/low.rkt
@@ -1423,12 +1423,34 @@
;; ==== low/typed-not-implemented-yet.rkt ====
-(provide ?)
+(provide ? ?*)
+(define-syntax (?* stx)
+ (syntax-case stx ()
+ [(q . rest)
+ (quasisyntax/loc stx
+ ((λ () : (U) #,(syntax/loc #'q (error "Not implemented yet"))
+ . rest)))]))
+
(define-syntax (? stx)
(syntax-case stx ()
[(q t . rest)
(quasisyntax/loc stx
- ((λ () : t #,(syntax/loc #'q (error "Not implemented yet"))
- . rest)))]))
+ ((ann (λ () #,(syntax/loc #'q (error "Not implemented yet"))
+ . rest)
+ (→ t))))]))
+
+;; ==== low/cond-let.rkt ====
+
+(define-syntax (cond-let stx)
+ (syntax-parse stx
+ [(_)
+ #'(typecheck-fail #,stx)]
+ [(_ #:let bindings:expr clause …)
+ #'(let bindings (cond-let clause …))]
+ [(_ [condition:expr (~seq #:else-let binding …) … . body] clause …)
+ #'(if condition
+ (begin . body)
+ (let (binding … …)
+ (cond-let clause …)))]))
;; ==== end ====
\ No newline at end of file
diff --git a/graph-lib/test/regression/2016-02-02--all-nodes-point-to-root.rkt b/graph-lib/test/regression/2016-02-02--all-nodes-point-to-root.rkt
new file mode 100644
index 00000000..1073a0c5
--- /dev/null
+++ b/graph-lib/test/regression/2016-02-02--all-nodes-point-to-root.rkt
@@ -0,0 +1,35 @@
+#lang typed/racket
+
+(require "../../lib/low.rkt"
+ "../../graph/graph.lp2.rkt"
+ "../../graph/get.lp2.rkt"
+ "../../type-expander/type-expander.lp2.rkt")
+
+(define-graph g2
+ [a [v : Number] [ab : b]
+ ((ma [arga2 : Integer] [arg3 : String])
+ (a arga2 (mb (max 0 (sub1 arga2)))))]
+ [b [v : Number] [ba : a]
+ ((mb [argb2 : Integer])
+ (b argb2 (ma (sub1 argb2) "z")))])
+
+(define gi (g2 3 "b"))
+(check-equal?: (get gi v) 3)
+(check-equal?: (get gi ab v) 2)
+(check-equal?: (get gi ab ba v) 1) ;; should be 1, but was 3 (bug now fixed)
+
+(define-graph g3
+ [a [v : Number] [ab : b]
+ ((ma [arg : (List 'r Integer String)])
+ (a (cadr arg) (mb (list 'b1 (if (> (cadr arg) 0)
+ (sub1 (cadr arg))
+ (string-length (caddr arg)))))))]
+ [b [v : Number] [ba : a]
+ ((mb [arg : (List 'b1 Integer)])
+ (b (cadr arg) (ma (list 'r (cadr arg) "z"))))])
+
+(define gi3 (g3 (list 'r 3 "b")))
+
+(check-equal?: (get gi3 v) 3)
+(check-equal?: (get gi3 ab v) 2)
+(check-equal?: (get gi3 ab ba v) 2) ;; should be 2, but was 3 (bug now fixed)
\ No newline at end of file