suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Finished implementing FB case 86 (Graph: Multiple constructors).

Browse Source
This commit is contained in:
Georges Dupéron 2016-02-02 21:38:09 +01:00
parent 75210b1209
commit 4d911ef7d6
8 changed files with 161 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
graph-lib/graph/__DEBUG_graph5.rkt
View File

@ -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)

2
graph-lib/graph/dotlang.rkt
View File

@ -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 "…"))

56
graph-lib/graph/fold-queues.lp2.rkt
View File

@ -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>

54
graph-lib/graph/graph-5-multi-ctors.lp2.rkt
View File

@ -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,7 +70,8 @@ And @tc[<mapping-declaration>] is:
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
#`(debug
(quasitemplate
;(debug
(begin
(define-graph name/wrapped
#:definitions
@ -88,7 +94,7 @@ And @tc[<mapping-declaration>] is:
[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] …)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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])
(? '<bdy>))))
. 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)
[(eq? (car node/arg↓) 'grouped-mapping)
(apply grouped-mapping/function
#,@#'(node …)
grouped-result-node
(cdr a))]
…))]
;#,@#'(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"

14
graph-lib/graph/graph.lp2.rkt
View File

@ -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:

7
graph-lib/graph/remember.rkt
View File

@ -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)

28
graph-lib/lib/low.rkt
View File

@ -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 ====

35
graph-lib/test/regression/2016-02-02--all-nodes-point-to-root.rkt Normal file
View File

@ -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)