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

Hopefully fixed order of union elements in the cond

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-08 14:53:20 +02:00
parent de8508f3ce
commit 3eecf3796e
2 changed files with 35 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
dispatch-union.rkt
View File

@ -3,14 +3,14 @@
(require racket/require
phc-toolkit
phc-adt
(for-syntax (subtract-in racket/base "subtemplate.rkt")
(for-syntax racket/base
phc-toolkit/untyped
racket/syntax
(subtract-in syntax/parse "subtemplate.rkt")
racket/format
syntax/parse
syntax/parse/experimental/template
type-expander/expander
"free-identifier-tree-equal.rkt"
"subtemplate.rkt")
"free-identifier-tree-equal.rkt")
(for-meta 2 racket/base)
(for-meta 2 phc-toolkit/untyped)
(for-meta 2 syntax/parse))
@ -19,25 +19,35 @@
(define-syntax/parse (dispatch-union v
([type-to-replaceᵢ Aᵢ predicateᵢ] …)
[Xⱼ result] …)
[Xⱼ resultⱼ] …)
(define-syntax-class to-replace
(pattern [t result]
#:with (_ predicate)
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
(syntax->list
#'([type-to-replaceᵢ predicateᵢ] …)))
#:with clause #`[(predicate v) result]))
(define-syntax-class tagged
#:literals (tagged)
(pattern [(tagged name [fieldₖ (~optional :colon) typeₖ] …) result]
#:with clause #`[((tagged? name fieldₖ …) v) result]))
(define-syntax-class other
(pattern [other result]
#:with clause #`[else result]))
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
(quasisyntax/top-loc stx
(cond
;; TODO: put first the type-to-replaceᵢ, then afterwards the other Xⱼ, otherwise it can fail to typecheck.
. #,(stx-map
(λ (Xⱼ result)
(syntax-parse Xⱼ
#:literals (tagged)
[t
#:with (_ predicate)
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
(syntax->list
(subtemplate ([type-to-replaceᵢ predicateᵢ] …))))
#`[(predicate v) #,result]]
[(tagged name [fieldₖ (~optional :colon) typeₖ] …)
#`[((tagged? name fieldₖ …) v) #,result]]
[other (raise-syntax-error 'graph
"Unhandled union type"
#'other)]))
#'(Xⱼ …)
#'(result …))))))
(syntax-parse #'([Xⱼ resultⱼ] …)
[({~or to-replace:to-replace
tagged:tagged
{~between other:other 0 1
#:too-many (~a "only one non-tagged type can be part of"
" the union")}}
…)
(quasisyntax/top-loc stx
(cond
to-replace.clause …
tagged.clause …
other.clause …))])))

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

@ -83,246 +83,3 @@
Integer)
'ghi 1)
#|
(begin
#;(define-fold
_Xⱼ/_fxⱼ-test-traversal-2279088
_Xⱼ/_txⱼ-test-traversal-2279086
(tagged tg (a String) (b Boolean))
String)
#;(define-fold
_Xⱼ/_fxⱼ-test-traversal-2279089
_Xⱼ/_txⱼ-test-traversal-2279087
String
String)
(define-type
(t₄ type-to-replaceᵢ/_Tᵢ-test-traversal-2279083)
(U
(_Xⱼ/_txⱼ-test-traversal-2279086
type-to-replaceᵢ/_Tᵢ-test-traversal-2279083)
(_Xⱼ/_txⱼ-test-traversal-2279087
type-to-replaceᵢ/_Tᵢ-test-traversal-2279083)))
(:
f₄
(∀
(type-to-replaceᵢ/_Aᵢ-test-traversal-2279094
type-to-replaceᵢ/_Bᵢ-test-traversal-2279093
Acc)
(→
(→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279094)
(→
type-to-replaceᵢ/_Aᵢ-test-traversal-2279094
Acc
(Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279093 Acc))
(→
(t₄ type-to-replaceᵢ/_Aᵢ-test-traversal-2279094)
Acc
(Values (t₄ type-to-replaceᵢ/_Bᵢ-test-traversal-2279093) Acc)))))
(define ((f₄
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082
type-to-replaceᵢ/updateᵢ-test-traversal-2279081)
v
acc)
(cond
((type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 v)
((_Xⱼ/_fxⱼ-test-traversal-2279089
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082
type-to-replaceᵢ/updateᵢ-test-traversal-2279081)
v
acc))
(((tagged? tg a b) v)
((_Xⱼ/_fxⱼ-test-traversal-2279088
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082
type-to-replaceᵢ/updateᵢ-test-traversal-2279081)
v
acc)))
#;(dispatch-union
v
((String
type-to-replaceᵢ/Aᵢ-test-traversal-2279091
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082))
((tagged tg (a String) (b Boolean))
((_Xⱼ/_fxⱼ-test-traversal-2279088
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082
type-to-replaceᵢ/updateᵢ-test-traversal-2279081)
v
acc))
(String
((_Xⱼ/_fxⱼ-test-traversal-2279089
type-to-replaceᵢ/predicateᵢ-test-traversal-2279082
type-to-replaceᵢ/updateᵢ-test-traversal-2279081)
v
acc)))))
(begin
#;(define-fold
_Xⱼ/_fxⱼ-test-traversal-2279102
_Xⱼ/_txⱼ-test-traversal-2279100
String
String)
#;(define-fold
_Xⱼ/_fxⱼ-test-traversal-2279103
_Xⱼ/_txⱼ-test-traversal-2279101
Boolean
String)
(define-type
(_Xⱼ/_txⱼ-test-traversal-2279086
type-to-replaceᵢ/_Tᵢ-test-traversal-2279098)
(tagged
tg
(a
:
(_Xⱼ/_txⱼ-test-traversal-2279100
type-to-replaceᵢ/_Tᵢ-test-traversal-2279098))
(b
:
(_Xⱼ/_txⱼ-test-traversal-2279101
type-to-replaceᵢ/_Tᵢ-test-traversal-2279098))))
(:
_Xⱼ/_fxⱼ-test-traversal-2279088
(∀
(type-to-replaceᵢ/_Aᵢ-test-traversal-2279108
type-to-replaceᵢ/_Bᵢ-test-traversal-2279107
Acc)
(→
(→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279108)
(→
type-to-replaceᵢ/_Aᵢ-test-traversal-2279108
Acc
(Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279107 Acc))
(→
(_Xⱼ/_txⱼ-test-traversal-2279086
type-to-replaceᵢ/_Aᵢ-test-traversal-2279108)
Acc
(Values
(_Xⱼ/_txⱼ-test-traversal-2279086
type-to-replaceᵢ/_Bᵢ-test-traversal-2279107)
Acc)))))
(define ((_Xⱼ/_fxⱼ-test-traversal-2279088
type-to-replaceᵢ/predicateᵢ-test-traversal-2279097
type-to-replaceᵢ/updateᵢ-test-traversal-2279096)
v
acc)
(let*-values (((_Xⱼ/_resultⱼ-test-traversal-2279104 acc)
((_Xⱼ/_fxⱼ-test-traversal-2279102
type-to-replaceᵢ/predicateᵢ-test-traversal-2279097
type-to-replaceᵢ/updateᵢ-test-traversal-2279096)
(uniform-get v a)
acc))
((_Xⱼ/_resultⱼ-test-traversal-2279105 acc)
((_Xⱼ/_fxⱼ-test-traversal-2279103
type-to-replaceᵢ/predicateᵢ-test-traversal-2279097
type-to-replaceᵢ/updateᵢ-test-traversal-2279096)
(uniform-get v b)
acc)))
(values
(tagged
tg
#:instance
(a _Xⱼ/_resultⱼ-test-traversal-2279104)
(b _Xⱼ/_resultⱼ-test-traversal-2279105))
acc))))
(begin
(define-type
(_Xⱼ/_txⱼ-test-traversal-2279100
type-to-replaceᵢ/_Tᵢ-test-traversal-2279112)
type-to-replaceᵢ/_Tᵢ-test-traversal-2279112)
(:
_Xⱼ/_fxⱼ-test-traversal-2279102
(∀
(type-to-replaceᵢ/_Aᵢ-test-traversal-2279115
type-to-replaceᵢ/_Bᵢ-test-traversal-2279114
Acc)
(→
(→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279115)
(→
type-to-replaceᵢ/_Aᵢ-test-traversal-2279115
Acc
(Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279114 Acc))
(→
(_Xⱼ/_txⱼ-test-traversal-2279100
type-to-replaceᵢ/_Aᵢ-test-traversal-2279115)
Acc
(Values
(_Xⱼ/_txⱼ-test-traversal-2279100
type-to-replaceᵢ/_Bᵢ-test-traversal-2279114)
Acc)))))
(define ((_Xⱼ/_fxⱼ-test-traversal-2279102
type-to-replaceᵢ/predicateᵢ-test-traversal-2279111
type-to-replaceᵢ/updateᵢ-test-traversal-2279110)
v
acc)
(type-to-replaceᵢ/updateᵢ-test-traversal-2279110 v acc)))
(begin
(define-type
(_Xⱼ/_txⱼ-test-traversal-2279101
type-to-replaceᵢ/_Tᵢ-test-traversal-2279119)
Boolean)
(:
_Xⱼ/_fxⱼ-test-traversal-2279103
(∀
(type-to-replaceᵢ/_Aᵢ-test-traversal-2279122
type-to-replaceᵢ/_Bᵢ-test-traversal-2279121
Acc)
(→
(→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279122)
(→
type-to-replaceᵢ/_Aᵢ-test-traversal-2279122
Acc
(Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279121 Acc))
(→
(_Xⱼ/_txⱼ-test-traversal-2279101
type-to-replaceᵢ/_Aᵢ-test-traversal-2279122)
Acc
(Values
(_Xⱼ/_txⱼ-test-traversal-2279101
type-to-replaceᵢ/_Bᵢ-test-traversal-2279121)
Acc)))))
(define ((_Xⱼ/_fxⱼ-test-traversal-2279103
type-to-replaceᵢ/predicateᵢ-test-traversal-2279118
type-to-replaceᵢ/updateᵢ-test-traversal-2279117)
v
acc)
(values v acc)))
(begin
(define-type
(_Xⱼ/_txⱼ-test-traversal-2279087
type-to-replaceᵢ/_Tᵢ-test-traversal-2279128)
type-to-replaceᵢ/_Tᵢ-test-traversal-2279128)
(:
_Xⱼ/_fxⱼ-test-traversal-2279089
(∀
(type-to-replaceᵢ/_Aᵢ-test-traversal-2279131
type-to-replaceᵢ/_Bᵢ-test-traversal-2279130
Acc)
(→
(→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279131)
(→
type-to-replaceᵢ/_Aᵢ-test-traversal-2279131
Acc
(Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279130 Acc))
(→
(_Xⱼ/_txⱼ-test-traversal-2279087
type-to-replaceᵢ/_Aᵢ-test-traversal-2279131)
Acc
(Values
(_Xⱼ/_txⱼ-test-traversal-2279087
type-to-replaceᵢ/_Bᵢ-test-traversal-2279130)
Acc)))))
(define ((_Xⱼ/_fxⱼ-test-traversal-2279089
type-to-replaceᵢ/predicateᵢ-test-traversal-2279127
type-to-replaceᵢ/updateᵢ-test-traversal-2279126)
v
acc)
(type-to-replaceᵢ/updateᵢ-test-traversal-2279126 v acc)))|#