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

Finished testing implementation for FB case 58 “Add fold to replace-in-type (to extract information from the instance)”.

Browse Source
This commit is contained in:
Georges Dupéron 2015-11-11 22:25:42 +01:00
parent d6347b52ce
commit 6b42be29b9
2 changed files with 124 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
graph/graph/rewrite-type.lp2.rkt
View File

@ -272,30 +272,73 @@ functions is undefined.
(List String Number (List String String Symbol String)) (List String Number (List String String Symbol String))
Number Number
[String Number (λ ([x : String] [acc : Number]) [String Number (λ ([x : String] [acc : Number])
(values (+ (string-length x) acc) (values (string-length x)
(+ acc 1)))]) (+ acc (string-length x))))])
(test-fold-1 '("a" 7 ("b" "c" x "d")) 0)] (check-equal? (test-fold-1 '("a" 7 ("bb" "cccc" x "dddddddd")) 0)
'((1 7 (2 4 x 8)) . 15))]
@CHUNK[<test-fold-instance> @CHUNK[<test-fold-instance>
(make-fold test-fold-2 (make-fold test-fold-list
(List String Number (Pairof String String) Symbol) (List String Number (Pairof String String) Symbol)
Number Number
[String Number (λ ([x : String] [acc : Number]) [String Number (λ ([x : String] [acc : Number])
(values (+ (string-length x) acc) (values (string-length x)
(+ acc 1)))]) (+ acc (string-length x))))])
(test-fold-2 '("a" 7 ("b" . "c") x) 0)] (check-equal? (test-fold-list '("a" 9 ("bb" . "cccc") x) 0)
'((1 9 (2 . 4) x) . 7))]
@CHUNK[<test-fold-instance>
(make-fold test-fold-pairof
(Pairof String (Pairof Number String))
Number
[String Number (λ ([x : String] [acc : Number])
(values (string-length x)
(+ acc (string-length x))))])
(check-equal? (test-fold-pairof '("a" 7 . "bb") 0)
'((1 7 . 2) . 3))]
@CHUNK[<test-fold-instance> @CHUNK[<test-fold-instance>
(make-fold test-fold-listof (make-fold test-fold-listof
(List String Number (Listof String) Symbol String) (List String Number (Listof String) Symbol String)
Number Number
[String Number (λ ([x : String] [acc : Number]) [String Number (λ ([x : String] [acc : Number])
(values (+ (string-length x) acc) (values (string-length x)
(+ acc 1)))]) (+ acc (string-length x))))])
(check-equal? (test-fold-listof
'("a" 7 ("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
0)
'((1 7 (2 4 8) x 16) . 31))]
@CHUNK[<test-fold-instance>
(make-fold test-fold-vector
(Vector String Number (Vectorof String) Symbol String)
Number
[String Number (λ ([x : String] [acc : Number])
(values (string-length x)
(+ acc (string-length x))))])
(check-equal? (test-fold-vector
'#("a" 7 #("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
0)
'(#(1 7 #(2 4 8) x 16) . 31))]
@CHUNK[<test-fold-instance>
(make-fold test-fold-vectorof
(Vectorof (U (List 'tag1 String String) (List 'tag2 Number)))
Number
[String Number (λ ([x : String] [acc : Number])
(values (string-length x)
(+ acc (string-length x))))])
(check-equal? (test-fold-vectorof
'#((tag1 "a" "bb") (tag2 7) (tag1 "cccc" "dddddddd"))
0)
'(#((tag1 1 2) (tag2 7) (tag1 4 8)) . 15))]
(test-fold-listof '("a" 7 ("b" "c" "d") x "e") 0)]
@CHUNK[<test-fold-instance> @CHUNK[<test-fold-instance>
(make-fold test-fold-big (make-fold test-fold-big
@ -308,12 +351,12 @@ functions is undefined.
String)) String))
Number Number
[String Number (λ ([x : String] [acc : Number]) [String Number (λ ([x : String] [acc : Number])
(values (+ (string-length x) acc) (values (string-length x)
(+ acc 1)))]) (+ acc (string-length x))))])
(test-fold-big '(((tag2 (#(sym) 7 ("ab" "abc" "abcd"))) . "a")) 0)]
(check-equal?
(test-fold-big '(((tag2 (#(sym) 7 ("a" "bb" "cccc"))) . "dddddddd")) 0)
'((((tag2 (#(sym) 7 (1 2 4))) . 8)) . 15))]
@CHUNK[<test-make-fold> @CHUNK[<test-make-fold>
(define-syntax (make-fold stx) (define-syntax (make-fold stx)
@ -322,13 +365,19 @@ functions is undefined.
#`(begin #`(begin
(: name (→ type (: name (→ type
acc-type acc-type
(values #,(replace-in-type #'type #'([from to] ...)) (Pairof #,(replace-in-type #'type #'([from to] ...))
acc-type))) acc-type)))
(define name (define (name [val : type] [acc : acc-type])
#,(fold-instance #'v (let-values ([([res : #,(replace-in-type #'type
#'([from to] ...))]
[res-acc : acc-type])
(#,(fold-instance #'v
#'type #'type
#'acc-type #'acc-type
#'([from to fun] ...))))]))] #'([from to fun] ...))
val
acc)])
(cons res res-acc))))]))]
@subsection{The code} @subsection{The code}
@ -344,12 +393,12 @@ functions is undefined.
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache))) (define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type (syntax-parse type
[x:id [x:id
#:attr assoc-from-to (cdr-stx-assoc #'x #'((from . (to . fun)) ...)) #:attr assoc-from-to-fun (stx-assoc #'x #'((from to fun) ...))
#:when (attribute assoc-from-to) #:when (attribute assoc-from-to-fun)
#:with (to-type . to-fun) #'assoc-from-to #:with (x-from x-to x-fun) #'assoc-from-to-fun
(define/with-syntax (tmp) (generate-temporaries #'(x))) (define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for x-to in the pattern. ;; TODO: Add predicate for x-to in the pattern.
#`to-fun] #`(ann x-fun (→ x-from acc-type (values x-to acc-type)))]
[((~literal List) a ...) [((~literal List) a ...)
(define/with-syntax (tmp1 ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp1 ...) (generate-temporaries #'(a ...)))
(define/with-syntax (tmp2 ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp2 ...) (generate-temporaries #'(a ...)))
@ -408,6 +457,7 @@ functions is undefined.
(define/with-syntax new-a-type (define/with-syntax new-a-type
(replace-in-type #'a #'([from to] ...))) (replace-in-type #'a #'([from to] ...)))
#`(λ ([val : (Vectorof a)] [acc : acc-type]) #`(λ ([val : (Vectorof a)] [acc : acc-type])
: (values (Vectorof new-a-type) acc-type)
(let ([f (foldl (let ([f (foldl
(λ ([x : a] (λ ([x : a]
[acc1 : (Pairof (Listof new-a-type) acc-type)]) [acc1 : (Pairof (Listof new-a-type) acc-type)])
@ -426,9 +476,9 @@ functions is undefined.
#'(a ...)) #'(a ...))
[(typecheck-fail #'#,type)]))] [(typecheck-fail #'#,type)]))]
[((~literal quote) a) [((~literal quote) a)
#'values] #'(inst values 'a acc-type)]
[x:id [x:id
#'values]))] #'(inst values x acc-type)]))]
@CHUNK[<replace-fold-union> @CHUNK[<replace-fold-union>
(syntax-parse ta (syntax-parse ta

49
graph/lib/low.rkt
View File

@ -499,6 +499,17 @@
;; ==== syntax.rkt ==== ;; ==== syntax.rkt ====
(provide stx-assoc cdr-stx-assoc) (provide stx-assoc cdr-stx-assoc)
#|
(require/typed syntax/stx
[stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))]
[stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))])
|#
(: stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A)))
(define (stx-car p) (car (syntax-e p)))
(: stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B)))
(define (stx-cdr p) (cdr (syntax-e p)))
;(require/typed racket/base [(assoc assoc3) (∀ (a b) (→ Any (Listof (Pairof a b)) (U False (Pairof a b))))]) ;(require/typed racket/base [(assoc assoc3) (∀ (a b) (→ Any (Listof (Pairof a b)) (U False (Pairof a b))))])
(require/typed racket/base (require/typed racket/base
[(assoc assoc3) [(assoc assoc3)
@ -510,30 +521,50 @@
(→ c a Boolean) (→ c a Boolean)
(U False (Pairof a b))]))]) (U False (Pairof a b))]))])
(: stx-assoc (∀ (T) (→ Identifier (: stx-assoc (∀ (T) (case→
(→ Identifier
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier T)))) (U (Syntaxof (Listof (Syntaxof (Pairof Identifier T))))
(Listof (Syntaxof (Pairof Identifier T))) (Listof (Syntaxof (Pairof Identifier T))))
(Listof (Pairof Identifier T))) (U (Syntaxof (Pairof Identifier T)) #f))
(U (Pairof Identifier T) #f)))) (→ Identifier
(Listof (Pairof Identifier T))
(U (Pairof Identifier T) #f)))))
(define (stx-assoc id alist) (define (stx-assoc id alist)
(let* ([e-alist (if (syntax? alist) (let* ([e-alist (if (syntax? alist)
(syntax->list alist) (syntax->list alist)
alist)] alist)]
[e-e-alist (cond [e-e-alist (cond
[(null? e-alist) '()] [(null? e-alist) '()]
[(syntax? (car e-alist)) (map (inst syntax-e (Pairof Identifier T)) e-alist)] [(syntax? (car e-alist))
[else e-alist])]) (map (λ ([x : (Syntaxof (Pairof Identifier T))])
(assoc3 id e-e-alist free-identifier=?))) (cons (stx-car x) x))
e-alist)]
[else
(map (λ ([x : (Pairof Identifier T)])
(cons (car x) x))
e-alist)])]
[result (assoc3 id e-e-alist free-identifier=?)])
(if result (cdr result) #f)))
(: cdr-stx-assoc (: cdr-stx-assoc
(∀ (T) (→ Identifier (∀ (T) (case→ (→ Identifier
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier T)))) (U (Syntaxof (Listof (Syntaxof (Pairof Identifier T))))
(Listof (Syntaxof (Pairof Identifier T))) (Listof (Syntaxof (Pairof Identifier T)))
(Listof (Pairof Identifier T))) (Listof (Pairof Identifier T)))
(U T #f)))) (U T #f)))))
(define (cdr-stx-assoc id alist) (define (cdr-stx-assoc id alist)
(if (null? alist)
#f
;; The typechecker is not precise enough, and the code below does not work
;; if we factorize it: (if (and (list? alist) (syntax? (car alist))) … …)
(if (list? alist)
(if (syntax? (car alist))
(let ((res (stx-assoc id alist)))
(if res (stx-cdr res) #f))
(let ((res (stx-assoc id alist))) (let ((res (stx-assoc id alist)))
(if res (cdr res) #f))) (if res (cdr res) #f)))
(let ((res (stx-assoc id alist)))
(if res (stx-cdr res) #f)))))
;; ==== generate-indices ==== ;; ==== generate-indices ====