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[ - (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[ @@ -284,8 +232,6 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable]. (provide fold-queues) - - <Δ-hash> )] @chunk[ 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[] 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[] 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[] 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 …))) - ) - [node [field c field-type] … - ((node/mapping [node/arg : ]) - )] - …))))] + (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 …))) + ) + [node [field c field-type] … + ((node/mapping [node/arg : ]) + )] + …))#|)|#))] 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 (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]) - (? ')))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (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[ - (let ([node-names… node_] - ;[mapping mapping/grouped] … - [node-name_ node_]) - body)] - We then select in the grouped mapping which one to call. @chunk[ - (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 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[ (λ (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)) + #'(→ … node/incomplete-type)] … + [(_ #:incomplete (~datum node) fld) + (syntax-parse #'fld + [(~datum field) #'] …)] … + [(_ #: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