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

Finished writing rewrite-type.lp2.rkt . Fixes case 24.

Browse Source
This commit is contained in:
Georges Dupéron 2015-11-09 21:30:51 +01:00
parent 7d792f6623
commit e8ab36d022
4 changed files with 152 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
graph/graph/_examples_cond-abort.rkt
View File

@ -60,6 +60,66 @@
'(a b c))
(begin
(:
test1a
(→
(List (Pairof (List Symbol (Listof String)) String))
(List (Pairof (List Symbol (Listof Number)) Number))))
(define (test1a v)
(let-values (((temp2) (apply values v)))
(list
(let ((val-cache3 temp2))
(cons
(let-values (((Symbol5 temp6) (apply values (car val-cache3))))
(list Symbol5 (map (λ ((String9 : String)) (string-length String9)) temp6)))
(string-length (cdr val-cache3))))))))
(begin
(:
test1
(→
(List
(Pairof
(U
(List 'tag1 (List (Vector Symbol) (Listof String)))
(List 'tag2 (List (Vector Symbol) (Listof String))))
String))
(List
(Pairof
(U
(List 'tag1 (List (Vector Symbol) (Listof Number)))
(List 'tag2 (List (Vector Symbol) (Listof Number))))
Number))))
(define (test1 v)
(let-values (((temp2) (apply values v)))
(list
(let ((val-cache3 temp2))
(cons
(let ((val-cache4 (car val-cache3)))
(cond
((and (list? val-cache4) (eq? 'tag1 (car val-cache4)))
(let-values (((temp6 temp7) (apply values val-cache4)))
(list
temp6
(let-values (((temp10 temp11) (apply values temp7)))
(list
(let ((val-cache12 temp10))
(let ((Symbol13 (vector-ref val-cache12 0))) (vector Symbol13)))
(map (λ ((String16 : String)) (string-length String16)) temp11))))))
((and (list? val-cache4) (eq? 'tag2 (car val-cache4)))
(let-values (((temp20 temp21) (apply values val-cache4)))
(list
temp20
(let-values (((temp24 temp25) (apply values temp21)))
(list
(let ((val-cache26 temp24))
(let ((Symbol27 (vector-ref val-cache26 0))) (vector Symbol27)))
(map (λ ((String30 : String)) (string-length String30)) temp25))))))))
(string-length (cdr val-cache3))))))))
#|
(define-syntax-rule (map-abort lst v . body)
#;(let ([l (foldl (λ (v acc)

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

@ -14,38 +14,31 @@ For example, one could replace all strings in a data structure by their length:
(define-syntax (make-replace stx)
(syntax-case stx ()
[(_ name type . replace)
(displayln (syntax->datum #`(begin
(: name (→ type #,(replace-in-data-structure #'type #'replace)))
(define (name v)
#,(replace-in-instance #'v #'type #'replace)))))
#'(list)]))
#`(begin
(: name (→ type #,(replace-in-data-structure #'type #'replace)))
(define (name v)
#,(replace-in-instance #'v #'type #'replace)))]))
(make-replace test1
(List (Pairof (List Symbol (Listof String)) String))
(List (Pairof (U (List 'tag1 (List (Vector Symbol)
Number
(Listof String)))
(List 'tag2 (List (Vector Symbol)
Number
(Listof String))))
String))
[String Number string-length])
;(test1 '((#(sym ("ab" "abc" "abcd")) . "a")))
(begin-for-syntax
#;(displayln
(syntax->datum
(replace-in-instance #'v
#'(List (Pairof (Vector Symbol
(Vectorof String))
String))
#'([String Number string-length]))))
(displayln
(syntax->datum
(replace-in-instance #'v
#'(List Symbol String)
#'([String Number string-length])))))
(define-syntax (string→number stx)
#`(define-type new-t
#,(replace-in-data-structure
#'(List (Pairof (Vector Symbol (Vectorof String)) String))
#'([String Number string-length]))))
(string→number)]
(check-equal?
(ann (test1 '(((tag2 (#(sym) 7 ("ab" "abc" "abcd"))) . "a")))
(List (Pairof (U (List 'tag1 (List (Vector Symbol)
Number
(Listof Number)))
(List 'tag2 (List (Vector Symbol)
Number
(Listof Number))))
Number)))
'(((tag2 (#(sym) 7 (2 3 4))) . 1)))]
@CHUNK[<replace-in-data-structure>
(define-for-syntax (replace-in-data-structure t r)
@ -68,13 +61,18 @@ For example, one could replace all strings in a data structure by their length:
#`(Vectorof #,(recursive-replace #'a))]
[((~literal U) a ...)
#`(U #,@(stx-map recursive-replace #'(a ...)))]
[((~literal quote) a)
;; TODO: if the quoted type is a primitive, we should replace it too
#`(quote a)]
[x:id #'x]))]
@CHUNK[<replace-in-instance_new>
@CHUNK[<replace-in-instance>
(define-for-syntax (replace-in-instance val t r)
(define/with-syntax ([from to fun] ...) r)
<replace-in-union>
(define (recursive-replace stx-val type)
(define/with-syntax val stx-val)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type
[x:id
#:attr assoc-from-to (cdr-stx-assoc #'x
@ -83,16 +81,57 @@ For example, one could replace all strings in a data structure by their length:
#:with (to-type . to-fun) #'assoc-from-to
(define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for to-type in the pattern.
#`(match-abort val [(and tmp) (protected (to-fun tmp))])]
#`(to-fun val)]
[((~literal List) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
#`(let-values ([(tmp ...) (apply values val)])
(list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
))
(recursive-replace val t r))]
[((~literal Pairof) a b)
#`(let ([v-cache val])
(cons #,(recursive-replace #'(car v-cache) #'a)
#,(recursive-replace #'(cdr v-cache) #'b)))]
[((~literal Listof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)]
[((~literal Vector) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
(define/with-syntax (idx ...) (generate-indices #'(a ...)))
#`(let ([v-cache val])
(let ([tmp (vector-ref v-cache idx)]
...)
(vector #,@(stx-map recursive-replace
#'(tmp ...)
#'(a ...)))))]
[((~literal Vectorof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(vector-map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)]
[((~literal U) a ...)
#`(let ([v-cache val])
(cond
#,@(stx-map (λ (ta) (replace-in-union #'v-cache ta r))
#'(a ...))))]
[((~literal quote) a)
#'val]
[x:id
#'val]))
(recursive-replace val t))]
@CHUNK[<replace-in-union>
(define (replace-in-union stx-v-cache t r)
(define/with-syntax v-cache stx-v-cache)
(syntax-parse t
[(List ((~literal quote) tag:id) b ...)
<replace-in-tagged-union-instance>]
[_ (error "Type-replace on untagged Unions isn't supported yet!")]))]
@CHUNK[<replace-in-tagged-union-instance>
#`[(and (list? v-cache) (eq? 'tag (car v-cache)))
#,(recursive-replace #'v-cache t)]]
@CHUNK[<replace-in-instance>
@CHUNK[<replace-in-instance_old>
(define-for-syntax (replace-in-instance val t r)
(define/with-syntax ([from to fun] ...) r)
(define (recursive-replace stx-val type)

15
graph/lib/lib.rkt
View File

@ -6,7 +6,7 @@
;; Types
(provide AnyImmutable)
;; Functions
(provide ∘ eval-get-values generate-indices)
(provide ∘ eval-get-values)
;; Macros
(provide mapp comment)
@ -139,15 +139,4 @@
body ...)
result))
(set! l (cdr l))))))))]))
(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) (Listof Integer))
(→ (Syntax-Listof T) (Listof Nonnegative-Integer)))))
(define generate-indices
(case-lambda
[(start stx)
(for/list ([v (my-in-syntax stx)]
[i (in-naturals start)])
i)]
[(stx)
(for/list ([v (my-in-syntax stx)]
[i : Nonnegative-Integer (ann (in-naturals) (Sequenceof Nonnegative-Integer))])
i)]))

18
graph/lib/low.rkt
View File

@ -535,4 +535,22 @@
(let ((res (stx-assoc id alist)))
(if res (cdr res) #f)))
;; ==== generate-indices ====
(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) (Listof Integer))
(→ (Syntax-Listof T) (Listof Nonnegative-Integer)))))
(provide generate-indices)
(define generate-indices
(case-lambda
[(start stx)
(for/list ([v (my-in-syntax stx)]
[i (in-naturals start)])
i)]
[(stx)
(for/list ([v (my-in-syntax stx)]
[i : Nonnegative-Integer (ann (in-naturals) (Sequenceof Nonnegative-Integer))])
i)]))
;; ==== end ====