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

Union of two tagged structures works

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-04 13:23:37 +02:00
parent 4862573453
commit 88102c7263
4 changed files with 63 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
dispatch-union.rkt
View File

@ -1,24 +1,33 @@
#lang typed/racket
(require phc-toolkit
(for-syntax racket/base
phc-toolkit/untyped
racket/syntax
syntax/parse
syntax/parse/experimental/template
type-expander/expander
"free-identifier-tree-equal.rkt")
(for-meta 2 racket/base)
(for-meta 2 phc-toolkit/untyped)
(for-meta 2 syntax/parse))
phc-adt
(for-syntax racket/base
phc-toolkit/untyped
racket/syntax
syntax/parse
syntax/parse/experimental/template
type-expander/expander
"free-identifier-tree-equal.rkt")
(for-meta 2 racket/base)
(for-meta 2 phc-toolkit/untyped)
(for-meta 2 syntax/parse))
(provide dispatch-union)
(define-syntax/parse (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
[X v result] …)
(stx-map
(λ (X v result)
(cond
[(meta-struct? X) #`[((struct-predicate #,X) #,v) #,result]]
[else (raise-syntax-error 'graph "Unhandled union type" #'X)]))
#'(X …)
#'(v …)
#'(result …)))
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
#`(cond
. #,(stx-map
(λ (X v result)
(syntax-parse X
#:literals (tagged)
[(tagged name [fieldᵢ (~optional :colon) typeᵢ] …)
#`[((tagged? name fieldᵢ …) #,v) #,result]]
[other (raise-syntax-error 'graph
"Unhandled union type"
#'other)]))
#'(X …)
#'(v …)
#'(result …)))))

1
test/adt-pre-declarations.rkt
View File

@ -1,2 +1,3 @@
#lang s-exp phc-adt/declarations
(remembered! tagged-structure (tg a b))
(remembered! tagged-structure (tg a c))

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

@ -6,9 +6,14 @@
"ck.rkt")
(adt-init)
#;(define-type Foo (Listof String))
(define-type Foo (Listof String))
(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
(define-fold f₂ t₂ (U (tagged tg [a String] [b Boolean])) String)
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
(tagged tg [a Boolean] [c String]))
String)
(define (string->symbol+acc [x : String] [acc : Integer])
(values (string->symbol x) (add1 acc)))
@ -18,4 +23,21 @@
: (Values (tagged tg [a Symbol] [b Boolean]) Integer)
(tagged tg [a 'abc] [b #f]) 1)
(check-equal?-values:
((f₂ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
: (Values (U (tagged tg [a Symbol] [b Boolean])) Integer)
(tagged tg [a 'abc] [b #f]) 1)
#;(check-equal?-values:
((f₃ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
: (Values (U (tagged tg [a Symbol] [b Boolean])
(tagged tg [a Boolean] [c Symbol]))
Integer)
(tagged tg [a 'abc] [b #f]) 1)
#;(check-equal?-values:
((f₃ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0)
: (Values (U (tagged tg [a Symbol] [b Boolean])
(tagged tg [a Boolean] [c Symbol]))
Integer)
(tagged tg [a #t] [c 'def]) 1)

17
traversal.hl.rkt
View File

@ -130,9 +130,13 @@ way up, so that a simple identity function can be applied in these cases.
whole-type:type
type-to-replaceᵢ:type …)
<define-fold-prepare>
((λ (x)
(local-require racket/pretty)
#;(pretty-write (syntax->datum x))
x)
(template
(begin
<define-fold-result>))]))]
<define-fold-result>)))]))]
@chunk[<define-fold-prepare>
(define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
@ -231,18 +235,20 @@ way up, so that a simple identity function can be applied in these cases.
@chunk[<type-cases>
[(U X …)
(define-temp-ids "_fx" (X …))
(define-temp-ids "_tx" (X …))
#:to
(U (tx _Tᵢ …))
(U (_tx _Tᵢ …) …)
#:using
(dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ]
…)
[X v ((fx . _args) v acc)]
[X v ((_fx . _args) v acc)]
…)
#:with-defintitions
(define-fold fx tx X type-to-replaceᵢ …)
(define-fold _fx _tx X type-to-replaceᵢ …)
…]]
@chunk[<type-cases>
@ -332,6 +338,7 @@ where @racket[foldl-map] is defined as:
(require phc-toolkit
type-expander
phc-adt
"dispatch-union.rkt"
(for-syntax racket/base
phc-toolkit/untyped
racket/syntax