suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

dispatch-union seems to work

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-07 22:42:20 +02:00
parent 74c707b65d
commit dc11b3014e
3 changed files with 12 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
dispatch-union.rkt
View File

@ -15,19 +15,19 @@
(provide dispatch-union) (provide dispatch-union)
(define-syntax/parse (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] …) (define-syntax/parse (dispatch-union v
[X v result] …) ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
[Xⱼ result] …)
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
#`(cond #`(cond
. #,(stx-map . #,(stx-map
(λ (X v result) (λ (X result)
(syntax-parse X (syntax-parse X
#:literals (tagged) #:literals (tagged)
[(tagged name [fieldᵢ (~optional :colon) typeᵢ] …) [(tagged name [fieldₖ (~optional :colon) typeₖ] …)
#`[((tagged? name fieldᵢ …) #,v) #,result]] #`[((tagged? name fieldₖ …) v) #,result]]
[other (raise-syntax-error 'graph [other (raise-syntax-error 'graph
"Unhandled union type" "Unhandled union type"
#'other)])) #'other)]))
#'(X …) #'(Xⱼ …)
#'(v …)
#'(result …))))) #'(result …)))))

4
test/test-traversal-2.rkt
View File

@ -28,14 +28,14 @@
: (Values (U (tagged tg [a Symbol] [b Boolean])) Integer) : (Values (U (tagged tg [a Symbol] [b Boolean])) Integer)
(tagged tg [a 'abc] [b #f]) 1) (tagged tg [a 'abc] [b #f]) 1)
#;(check-equal?-values: (check-equal?-values:
((f₃ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0) ((f₃ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
: (Values (U (tagged tg [a Symbol] [b Boolean]) : (Values (U (tagged tg [a Symbol] [b Boolean])
(tagged tg [a Boolean] [c Symbol])) (tagged tg [a Boolean] [c Symbol]))
Integer) Integer)
(tagged tg [a 'abc] [b #f]) 1) (tagged tg [a 'abc] [b #f]) 1)
#;(check-equal?-values: (check-equal?-values:
((f₃ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0) ((f₃ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0)
: (Values (U (tagged tg [a Symbol] [b Boolean]) : (Values (U (tagged tg [a Symbol] [b Boolean])
(tagged tg [a Boolean] [c Symbol])) (tagged tg [a Boolean] [c Symbol]))

7
traversal.hl.rkt
View File

@ -255,10 +255,9 @@ way up, so that a simple identity function can be applied in these cases.
(U (_txⱼ _Tᵢ …) …) (U (_txⱼ _Tᵢ …) …)
#:using #:using
(dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] (dispatch-union v
…) ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
[_Xⱼ v ((_fxⱼ . _args) v acc)] [_Xⱼ ((_fxⱼ . _args) v acc)] …)
…)
#:with-defintitions #:with-defintitions
(define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …) (define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …)