Hopefully fixed order of union elements in the cond
This commit is contained in:
Georges Dupéron
parent
de8508f3ce
commit
3eecf3796e
|
|
@ -3,14 +3,14 @@
|
||||||
(require racket/require
|
(require racket/require
|
||||||
phc-toolkit
|
phc-toolkit
|
||||||
phc-adt
|
phc-adt
|
||||||
(for-syntax (subtract-in racket/base "subtemplate.rkt")
|
(for-syntax racket/base
|
||||||
phc-toolkit/untyped
|
phc-toolkit/untyped
|
||||||
racket/syntax
|
racket/syntax
|
||||||
(subtract-in syntax/parse "subtemplate.rkt")
|
racket/format
|
||||||
|
syntax/parse
|
||||||
syntax/parse/experimental/template
|
syntax/parse/experimental/template
|
||||||
type-expander/expander
|
type-expander/expander
|
||||||
"free-identifier-tree-equal.rkt"
|
"free-identifier-tree-equal.rkt")
|
||||||
"subtemplate.rkt")
|
|
||||||
(for-meta 2 racket/base)
|
(for-meta 2 racket/base)
|
||||||
(for-meta 2 phc-toolkit/untyped)
|
(for-meta 2 phc-toolkit/untyped)
|
||||||
(for-meta 2 syntax/parse))
|
(for-meta 2 syntax/parse))
|
||||||
|
|
@ -19,25 +19,35 @@
|
||||||
|
|
||||||
(define-syntax/parse (dispatch-union v
|
(define-syntax/parse (dispatch-union v
|
||||||
([type-to-replaceᵢ Aᵢ predicateᵢ] …)
|
([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)
|
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
|
||||||
(quasisyntax/top-loc stx
|
(syntax-parse #'([Xⱼ resultⱼ] …)
|
||||||
(cond
|
[({~or to-replace:to-replace
|
||||||
;; TODO: put first the type-to-replaceᵢ, then afterwards the other Xⱼ, otherwise it can fail to typecheck.
|
tagged:tagged
|
||||||
. #,(stx-map
|
{~between other:other 0 1
|
||||||
(λ (Xⱼ result)
|
#:too-many (~a "only one non-tagged type can be part of"
|
||||||
(syntax-parse Xⱼ
|
" the union")}}
|
||||||
#:literals (tagged)
|
…)
|
||||||
[t
|
(quasisyntax/top-loc stx
|
||||||
#:with (_ predicate)
|
(cond
|
||||||
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
|
to-replace.clause …
|
||||||
(syntax->list
|
tagged.clause …
|
||||||
(subtemplate ([type-to-replaceᵢ predicateᵢ] …))))
|
other.clause …))])))
|
||||||
#`[(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 …))))))
|
|
||||||
|
|
@ -83,246 +83,3 @@
|
||||||
Integer)
|
Integer)
|
||||||
'ghi 1)
|
'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)))|#
|
|
||||||
Loading…
Reference in New Issue
Block a user