Fixed treelist subtyping and added more treelist test

Author: Ryan Ficklin

typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -1298,8 +1298,8 @@
 ;; Section 4.21 (TreeLists)
 
 [treelist (-poly (a) (->* (list) a (-treelist a)))]
-[treelist-empty? (-poly (a) (-> (-treelist a) B))]
-[treelist-length (-poly (a) (-> (-treelist a) -Index))]
+[treelist-empty? (-> (-treelist Univ) B)]
+[treelist-length (-> (-treelist Univ) -Index)]
 [treelist-member?
  (-poly (a)
         (cl->* ((-treelist a) a . -> . Univ)

typed-racket-lib/typed-racket/types/subtype.rkt

@@ -1278,6 +1278,12 @@
      [(? ThreadCellTop?) A]
      [(ThreadCell: elem2) (type≡? A elem1 elem2)]
      [_ (continue<: A t1 t2 obj)])]
+  [(case: TreeList (TreeList: elem1))
+   (match t2
+     [(TreeList: elem2) (subtype* A elem1 elem2)]
+     [(SequenceTop:) A]
+     [(Sequence: (list seq-t)) (subtype* A elem1 seq-t)]
+     [_ (continue<: A t1 t2 obj)])]
   [(case: Union (Union/set: base1 ts1 elems1))
    (let ([A (subtype* A base1 t2 obj)])
      (and A

typed-racket-test/succeed/treelist-contract.rkt

@@ -0,0 +1,9 @@
+#lang typed/racket
+
+(require racket/treelist)
+
+(define-predicate string-treelist? (TreeListof String))
+
+(string-treelist? (treelist 1 2 3))
+
+(string-treelist? (treelist "1" "2" "3"))

typed-racket-test/succeed/treelist.rkt

@@ -0,0 +1,69 @@
+#lang typed/racket
+
+(require racket/treelist)
+
+(define tl (treelist 0 1 2 3))
+
+(treelist-empty? tl)
+
+(treelist-length tl)
+
+(treelist-member? tl 1)
+
+(treelist-first tl)
+
+(treelist-rest tl)
+
+(treelist-last tl)
+
+(treelist-add tl 1)
+
+(treelist-cons tl 1)
+
+(treelist-delete tl 1)
+
+(make-treelist 5 1)
+
+(treelist-ref tl 1)
+
+(treelist-insert tl 1 1)
+
+(treelist-set tl 0 1)
+
+(treelist-take tl 2)
+
+(treelist-take tl 2)
+(treelist-drop tl 2)
+(treelist-take-right tl 2)
+(treelist-drop-right tl 2)
+
+(treelist-sublist tl 1 3)
+
+(treelist-reverse tl)
+
+(treelist->list tl)
+(list->treelist (list 0 1 2 3))
+
+(treelist->vector tl)
+(vector->treelist (vector 0 1 2 3))
+
+(treelist? treelist)
+
+(treelist-append tl tl tl)
+
+(treelist-map tl (λ ([x : Byte]) (+ x 1)))
+
+(treelist-for-each tl  (λ ([x : Byte]) (+ x 1)))
+
+(treelist-filter (λ ([x : Byte]) (equal? x 1)) tl)
+
+(treelist-find tl (λ ([x : Byte]) (equal? x 1)))
+
+(treelist-index-of tl 3)
+(treelist-index-of tl 3 equal?)
+
+(treelist-flatten (treelist tl tl))
+
+(treelist-append (treelist (treelist tl) tl))
+
+(treelist-sort tl >)

typed-racket-test/unit-tests/subtype-tests.rkt

@@ -179,6 +179,7 @@
     [make-Immutable-Vector ()]
     [make-Immutable-HashTable () ()]
     [make-Set ()]
+    [make-TreeList ()]
     [make-Evt ()]
     [make-Syntax ()]
     [make-Future ()])
@@ -298,6 +299,10 @@
    [(-mu x (make-Listof x)) (-mu x* (make-Listof x*))]
    [(-pair -Number -Number) (-pair Univ -Number)]
    [(-pair -Number -Number) (-pair -Number -Number)]
+   ;; simple treelist types
+   [(-treelist -Number) (-treelist Univ)]
+   [(-treelist -Number) (-treelist -Number)]
+   [FAIL (-treelist -Number) (-treelist -Symbol)]
    ;; from page 7 (my favorite page! But seriously, page 7 of... what???)
    [(-mu t (-> t t)) (-mu s (-> s s))]
    [(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))]

typed-racket-test/unit-tests/typecheck-tests.rkt

@@ -1941,7 +1941,7 @@
         ;;(tc-e (in-treelist (treelist "a")) (-seq -String)) FIXME: "missing type identifier"
         (tc-e (list->treelist (list "a")) (-treelist -String))
         (tc-e (vector->treelist (vector "a")) (-treelist -String))
-        (tc-e (treelist? (treelist "a")) -Boolean)
+        (tc-e (treelist? (treelist "a")) #:ret (tc-ret -Boolean -true-propset))
         (tc-e (treelist? (list "a")) #:ret (tc-ret -Boolean -false-propset))
         (tc-e (treelist-append (treelist "a") (treelist "b")) (-treelist -String))
         (tc-e (treelist-append (treelist "a") (treelist "b") (treelist "c")) (-treelist -String))