From 7d792f662368226d17e28caccfe455968b922a83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 9 Nov 2015 18:10:32 +0100 Subject: [PATCH] Before simplifying the strategy fro rewrite-type.lp2.rkt --- graph/graph/_examples_cond-abort.rkt | 103 ++++++++++-------- .../graph/_examples_differentiate_unions.rkt | 16 +++ graph/graph/rewrite-type.lp2.rkt | 24 +++- 3 files changed, 98 insertions(+), 45 deletions(-) create mode 100644 graph/graph/_examples_differentiate_unions.rkt diff --git a/graph/graph/_examples_cond-abort.rkt b/graph/graph/_examples_cond-abort.rkt index ad4dde6..759258e 100644 --- a/graph/graph/_examples_cond-abort.rkt +++ b/graph/graph/_examples_cond-abort.rkt @@ -1,6 +1,7 @@ #lang typed/racket (require "cond-abort.rkt") +(require "variant.lp2.rkt") (match-abort '(1 (a b) 3) [(list x y z) @@ -11,6 +12,12 @@ [new-z z]) (list new-x new-y new-z))]) +(λ ([x : (U (Vector Number) (Vector String String))]) + (if (= (vector-length x) 1) + x + x)) + +#| (λ ((v : (List Symbol String))) (match-abort @@ -37,11 +44,43 @@ ((Symbol3 (protected Symbol1)) (String4 (match-abort String2 ((and String5) (protected (string-length String5)))))) (protected (list (unprotect Symbol3) (unprotect String4)))))))) +|# + + + + +(foldl + (λ (x acc) + (if (null? x) + acc;(reverse acc) + (if (eq? x 'boo) + 'continue + (cons x acc)))) + '() + '(a b c)) + + +#| +(define-syntax-rule (map-abort lst v . body) + #;(let ([l (foldl (λ (v acc) + (let ([result (let () . body)]) + (if (eq? result 'continue) + 'continue + (if (eq? result 'break) + 'break + (cons (unprotect result) acc))))) + '() + lst)]) + (if (or (eq? l 'continue) (eq? l 'break)) + l + (reverse l)))) (begin (: test1 - (→ (List (Pairof (List Symbol (Listof String)) String)) (List (Pairof (List Symbol (Listof Number)) Number)))) + (→ + (List (Pairof (List Symbol (Listof String)) String)) + (List (Pairof (List Symbol (Listof Number)) Number)))) (define (test1 v) (unprotect (match-abort @@ -60,50 +99,26 @@ (let-abort ((Symbol9 (protected Symbol7)) (temp10 + #;(match-abort + temp8 + ((list String11 ...) + (begin String11 (error "e")))) (match-abort temp8 ((list String11 ...) - #;(map (λ ([String12 : String]) - (unprotect (match-abort String12 ((and String13) (protected (string-length String13)))))) - String11) - #;(map-abort - String11 - String12 - 3 #;(match-abort String12 ((and String13) (protected (string-length String13))))) - - - - (let ([l String11]) - (if (null? l) - ;; Special-case to avoid type inference issues with an empty - ;; result-list. - '() - (let ([result-list (list (let ([String12 (car l)]) 3))]) - (set! l (cdr l)) - (do : (U 'continue 'break (Listof Number)) ([stop : (U #f #t 'continue 'break) - #f]) - (stop (if (eq? stop 'continue) - 'continue - (if (eq? stop 'break) - 'break - (reverse result-list)))) - (if (null? l) - (set! stop #t) - (let ([result (let ([String12 (car l)]) 3)]) - (if (or (eq? result 'continue) (eq? result 'break)) - (set! stop result) - (begin - (set! result-list (cons result result-list)) - (set! l (cdr l)))))))))) - - - - - - - - )))) - (protected (list (unprotect Symbol9) (unprotect temp10))))))) - (String6 (match-abort String4 ((and String14) (protected (string-length String14)))))) + (map-abort + String11 + String12 + (match-abort + String12 + ((and String13) + (protected (string-length String13))))))))) + (protected + (list (unprotect Symbol9) (unprotect temp10))))))) + (String6 + (match-abort + String4 + ((and String14) (protected (string-length String14)))))) (protected (cons (unprotect temp5) (unprotect String6)))))))) - (protected (list (unprotect temp2))))))))) \ No newline at end of file + (protected (list (unprotect temp2))))))))) +|# \ No newline at end of file diff --git a/graph/graph/_examples_differentiate_unions.rkt b/graph/graph/_examples_differentiate_unions.rkt new file mode 100644 index 0000000..ac5cd37 --- /dev/null +++ b/graph/graph/_examples_differentiate_unions.rkt @@ -0,0 +1,16 @@ +#lang typed/racket + + +#;(λ ([x : (U (Vector Number) (Vector String String))]) + (ann (vector-ref x 0) (U Number String))) + +(ann (λ ([x : (U (Vector Number) (Vector String String) Symbol)]) + (if (vector? x) + x + #f)) + (→ (U (Vector Number) (Vector String String) Symbol) + (U False (Vector Number) (Vector String String)))) + + +(λ ([x : (U (→ Number Number Number) (→ Number Number))]) + (procedure-arity x)) \ No newline at end of file diff --git a/graph/graph/rewrite-type.lp2.rkt b/graph/graph/rewrite-type.lp2.rkt index e0947d3..50c905e 100644 --- a/graph/graph/rewrite-type.lp2.rkt +++ b/graph/graph/rewrite-type.lp2.rkt @@ -70,6 +70,28 @@ For example, one could replace all strings in a data structure by their length: #`(U #,@(stx-map recursive-replace #'(a ...)))] [x:id #'x]))] +@CHUNK[ + (define-for-syntax (replace-in-instance val t r) + (define/with-syntax ([from to fun] ...) r) + (define (recursive-replace stx-val type) + (define/with-syntax val stx-val) + (syntax-parse type + [x:id + #:attr assoc-from-to (cdr-stx-assoc #'x + #'((from . (to . fun)) ...)) + #:when (attribute assoc-from-to) + #: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))])] + [((~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))] + + @CHUNK[ (define-for-syntax (replace-in-instance val t r) (define/with-syntax ([from to fun] ...) r) @@ -138,7 +160,7 @@ For example, one could replace all strings in a data structure by their length: @chunk[<*> (begin - (module main typed/racket;;;;;;;;;; + (module main typed/racket (require (for-syntax syntax/parse racket/syntax syntax/stx