commit 3eecf3796e83126190e77516b9658f440859b6d8
parent de8508f3cef3c9170671e912c919e4b528b084b5
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 8 Oct 2016 14:53:20 +0200
Hopefully fixed order of union elements in the cond
Diffstat:
2 files changed, 36 insertions(+), 270 deletions(-)
diff --git a/dispatch-union.rkt b/dispatch-union.rkt
@@ -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 …))))))
-\ No newline at end of file
+ (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 …))])))
+\ No newline at end of file
diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt
@@ -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)))|#
-\ No newline at end of file
