Added support for type-to-replaceᵢ directly within a union.
This commit is contained in:
Georges Dupéron
parent
dc11b3014e
commit
de8508f3ce
|
|
@ -1,14 +1,16 @@
|
|||
#lang typed/racket
|
||||
#lang typed/racket/base
|
||||
|
||||
(require phc-toolkit
|
||||
(require racket/require
|
||||
phc-toolkit
|
||||
phc-adt
|
||||
(for-syntax racket/base
|
||||
(for-syntax (subtract-in racket/base "subtemplate.rkt")
|
||||
phc-toolkit/untyped
|
||||
racket/syntax
|
||||
syntax/parse
|
||||
(subtract-in syntax/parse "subtemplate.rkt")
|
||||
syntax/parse/experimental/template
|
||||
type-expander/expander
|
||||
"free-identifier-tree-equal.rkt")
|
||||
"free-identifier-tree-equal.rkt"
|
||||
"subtemplate.rkt")
|
||||
(for-meta 2 racket/base)
|
||||
(for-meta 2 phc-toolkit/untyped)
|
||||
(for-meta 2 syntax/parse))
|
||||
|
|
@ -19,15 +21,23 @@
|
|||
([type-to-replaceᵢ Aᵢ predicateᵢ] …)
|
||||
[Xⱼ result] …)
|
||||
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
|
||||
#`(cond
|
||||
(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
|
||||
(λ (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 …)))))
|
||||
#'(result …))))))
|
||||
|
|
@ -1,3 +1,4 @@
|
|||
#lang s-exp phc-adt/declarations
|
||||
(remembered! tagged-structure (tg a b))
|
||||
(remembered! tagged-structure (tg a c))
|
||||
(remembered! tagged-structure (t0))
|
||||
|
|
|
|||
|
|
@ -3,17 +3,28 @@
|
|||
(require "../traversal.hl.rkt"
|
||||
type-expander
|
||||
phc-adt
|
||||
"ck.rkt")
|
||||
"ck.rkt"
|
||||
"../dispatch-union.rkt") ;; DEBUG
|
||||
(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-fold f₄ t₄ (U (tagged tg [a String] [b Boolean])
|
||||
String
|
||||
(tagged tg [a Boolean] [c String]))
|
||||
String)
|
||||
#;(define-fold f₄ t₄ (U (tagged t0)
|
||||
String
|
||||
(tagged tg [a Boolean] [c String]))
|
||||
String)
|
||||
(define-fold f₆ t₆ (U String
|
||||
(tagged tg [a String] [b Boolean]))
|
||||
String)
|
||||
|
||||
(define (string->symbol+acc [x : String] [acc : Integer])
|
||||
(values (string->symbol x) (add1 acc)))
|
||||
|
|
@ -40,4 +51,278 @@
|
|||
: (Values (U (tagged tg [a Symbol] [b Boolean])
|
||||
(tagged tg [a Boolean] [c Symbol]))
|
||||
Integer)
|
||||
(tagged tg [a #t] [c 'def]) 1)
|
||||
(tagged tg [a #t] [c 'def]) 1)
|
||||
|
||||
#;(check-equal?-values:
|
||||
((f₄ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0)
|
||||
: (Values (U (tagged tg [a Symbol] [b Boolean])
|
||||
Symbol
|
||||
(tagged tg [a Boolean] [c Symbol]))
|
||||
Integer)
|
||||
(tagged tg [a #t] [c 'def]) 1)
|
||||
|
||||
#;(check-equal?-values:
|
||||
((f₄ string? string->symbol+acc) "ghi" 0)
|
||||
: (Values (U (tagged tg [a Symbol] [b Boolean])
|
||||
Symbol
|
||||
(tagged tg [a Boolean] [c Symbol]))
|
||||
Integer)
|
||||
'ghi 1)
|
||||
|
||||
(check-equal?-values:
|
||||
((f₆ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
|
||||
: (Values (U (tagged tg [a Symbol] [b Boolean])
|
||||
Symbol)
|
||||
Integer)
|
||||
(tagged tg [a 'abc] [b #f]) 1)
|
||||
|
||||
(check-equal?-values:
|
||||
((f₆ string? string->symbol+acc) "ghi" 0)
|
||||
: (Values (U (tagged tg [a Symbol] [b Boolean])
|
||||
Symbol)
|
||||
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)))|#
|
||||
|
|
@ -171,12 +171,10 @@ way up, so that a simple identity function can be applied in these cases.
|
|||
|
||||
@chunk[<type-cases>
|
||||
[t
|
||||
#:with info (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
|
||||
(syntax->list
|
||||
(subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
|
||||
#:when (attribute info)
|
||||
#:with (_ update T) #'info
|
||||
|
||||
#:with (_ update T)
|
||||
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
|
||||
(syntax->list (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
|
||||
|
||||
#:to
|
||||
T
|
||||
|
||||
|
|
@ -273,7 +271,7 @@ way up, so that a simple identity function can be applied in these cases.
|
|||
(let*-values ([(_resultⱼ acc) ((_fxⱼ . _args) (uniform-get v _fieldⱼ)
|
||||
acc)]
|
||||
…)
|
||||
(values (tagged _name [_fieldⱼ _resultⱼ] …)
|
||||
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
|
||||
acc))
|
||||
|
||||
#:with-defintitions
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user