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

Managed to force TR to propagate Nothing types (by intersecting with a (∀) type which has the same shape as the desired one, deep enough to cause the containers of Nothing types to be re-examined

Browse Source
This commit is contained in:
Georges Dupéron 2017-05-12 22:05:20 +02:00
parent fc7e1552ee
commit 36d6630906
2 changed files with 55 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
flexible-with-generalized-ctor-test.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang type-expander
(require (lib "phc-graph/flexible-with-generalized-ctor.hl.rkt"))
(define-type τ-4-2 (builder-τ 4 2))
(: f τ-4-2)
(define (f kx x ky y)
(error "Not Yet"))
(define-syntax-rule (F KX X KY Y)
(inst f propagate-τ
KX X KY Y))
(ann (F 0 Number 1 String)
(-> 0 Number 1 String
(List
(Pairof Zero (Some Number))
(Pairof One (Some String))
(Pairof 2 (None (List Zero One)))
(Pairof 3 (None (List Zero One))))))
#|
(: g (∀ (A) (case→ [→ (Some A) A]
[→ (None Any) 'none])))
(define (g a)
(if (Some? a)
(Some-f a)
'none))
|#

101
flexible-with-generalized-ctor.hl.rkt
View File

@ -9,7 +9,7 @@
Some Some
Some? Some?
Some-f Some-f
N/S) propagate-τ)
(require racket/require (require racket/require
(for-syntax (subtract-in racket/base subtemplate/override) (for-syntax (subtract-in racket/base subtemplate/override)
@ -17,9 +17,8 @@
racket/function racket/function
subtemplate/override)) subtemplate/override))
(struct N/S ()) (struct (T) Some ([f : T]))
(struct (T) Some N/S ([f : T])) (struct (T) None ([f : T]))
(struct (T) None N/S ([f : T]))
(define-type-expander BinaryTree (define-type-expander BinaryTree
(syntax-parser (syntax-parser
@ -35,6 +34,7 @@
#:with ((Kᵢⱼ …) …) (map (const (Kⱼ …)) (Nᵢ …)) #:with ((Kᵢⱼ …) …) (map (const (Kⱼ …)) (Nᵢ …))
#:with ((Xᵢⱼ …) …) (map (const (Xⱼ …)) (Nᵢ …)) #:with ((Xᵢⱼ …) …) (map (const (Xⱼ …)) (Nᵢ …))
#:with ((Nᵢⱼ …) …) (map (λ (ni) (map (const ni) (Xⱼ …))) (Nᵢ …)) #:with ((Nᵢⱼ …) …) (map (λ (ni) (map (const ni) (Xⱼ …))) (Nᵢ …))
#:with ((Nⱼᵢ …) …) (map (const (Nᵢ …)) (Mⱼ …))
(define Ns (Nᵢ …)) (define Ns (Nᵢ …))
(define Ms (Mⱼ …)) (define Ms (Mⱼ …))
;(define/with-syntax exceptⱼ (remove Mⱼ Ns)) … ;(define/with-syntax exceptⱼ (remove Mⱼ Ns)) …
@ -45,81 +45,38 @@
((map (const (remove Nᵢ Ns)) Ms) …)) ((map (const (remove Nᵢ Ns)) Ms) …))
#'(∀ (A (?@ Kⱼ Xⱼ) …) #'(∀ (A (?@ Kⱼ Xⱼ) …)
(→ A (→ (?@ (∩ Kⱼ (U Nⱼᵢ …)) Xⱼ) …
(?@ Kⱼ Xⱼ) …
(BinaryTree (BinaryTree
(U (Pairof Nᵢ (∩ (U (Pairof Nᵢ
;; If Kⱼ is Nᵢ, then {∩ Kᵢⱼ {U . exceptᵢⱼ}} will ;; If Kⱼ is Nᵢ, then {∩ Kᵢⱼ {U . exceptᵢⱼ}} will
;; Nothing. We multiply the Nothing together by ;; Nothing. We multiply the Nothing together by
;; building a List out of them (a single occurrence ;; building a List out of them (a single occurrence
;; of Nothing should collapse the list), so that the ;; of Nothing should collapse the list), so that the
;; result should be Nothing only if there is no Kⱼ ;; result should be Nothing only if there is no Kⱼ
;; equal to Nᵢ. To force TR to propagate Nothing as ;; equal to Nᵢ. To force TR to propagate Nothing as
;; much as possible, we intersect it with ;; much as possible, we intersect it with
;; (None Any), which should be a no-op, but makes ;; (None Any), which should be a no-op, but makes
;; sure the simplifier which runs with ∩ kicks in. ;; sure the simplifier which runs with ∩ kicks in.
;; Therefore, the (None whatever) should appear only ;; Therefore, the (None whatever) should appear only
;; if there is indeed no key provided for that leaf. ;; if there is indeed no key provided for that leaf.
(∩ (None (List {∩ Kᵢⱼ {U . exceptᵢⱼ}} …)) (None (List {∩ Kᵢⱼ {U . exceptᵢⱼ}} …)))
A)) (∩ (Pairof Kᵢⱼ (Some Xᵢⱼ))
(∩ (Pairof Kᵢⱼ (Some Xᵢⱼ)) (Pairof Nᵢⱼ Any))
(Pairof Nᵢⱼ A)) …)
…) A)
…)))])) …)))]))
; ../../../.racket/snapshot/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt:40:0: mask-accessor: contract violation (define-type propagate-τ
(Pairof Natural
(U (None (Listof Natural))
(Some Any))))
; ../../../.racket/snapshot/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt
;:40:0: mask-accessor: contract violation
; expected: mask? ; expected: mask?
; given: #f ; given: #f
;(define-type τ-4-2 (builder-τ 4 2)) ;(define-type τ-4-2 (builder-τ 4 2))
(define-type t-4-2
(All (A 0/K 0/X 1/K 1/X)
(-> A
0/K
0/X
1/K
1/X
(List
(U (Pairof (∩ 0/K Zero) (∩ (Some 0/X) A))
(Pairof (∩ 1/K Zero) (∩ (Some 1/X) A))
(Pairof
Zero
(∩
(None
(List
(U (∩ 0/K 2) (∩ 0/K 3) (∩ 0/K One))
(U (∩ 1/K 2) (∩ 1/K 3) (∩ 1/K One))))
A)))
(U (Pairof (∩ 0/K One) (∩ (Some 0/X) A))
(Pairof (∩ 1/K One) (∩ (Some 1/X) A))
(Pairof
One
(∩
(None
(List
(U (∩ 0/K 2) (∩ 0/K 3) (∩ 0/K Zero))
(U (∩ 1/K 2) (∩ 1/K 3) (∩ 1/K Zero))))
A)))
(U (Pairof (∩ 0/K 2) (∩ (Some 0/X) A))
(Pairof (∩ 1/K 2) (∩ (Some 1/X) A))
(Pairof
2
(∩
(None
(List
(U (∩ 0/K 3) (∩ 0/K One) (∩ 0/K Zero))
(U (∩ 1/K 3) (∩ 1/K One) (∩ 1/K Zero))))
A)))
(U (Pairof (∩ 0/K 3) (∩ (Some 0/X) A))
(Pairof (∩ 1/K 3) (∩ (Some 1/X) A))
(Pairof
3
(∩
(None
(List
(U (∩ 0/K 2) (∩ 0/K One) (∩ 0/K Zero))
(U (∩ 1/K 2) (∩ 1/K One) (∩ 1/K Zero))))
A)))))))
;] ;]