Added TreeLists to Typed-Racket along with type-checking tests.

Ryan Ficklin · Ryan Ficklin · commit 1ab8f9574986 · 2025-03-03T00:39:44.000-08:00
update

Added treelis?/sc

removed autorec files

added treelist functions to base-env

Added tests for treelists, missing identifier issues

Added Treelist to type-printer

Added a few functions and fixed all TreeList typechecking tests
diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt
@@ -8,6 +8,7 @@
   racket/unsafe/ops
   racket/unsafe/undefined
   racket/hash
+  racket/treelist
   (only-in racket/extflonum floating-point-bytes->extfl extfl->floating-point-bytes)
   ;(only-in rnrs/lists-6 fold-left)
   '#%paramz
@@ -1294,6 +1295,56 @@
 
 [unsafe-undefined -Unsafe-Undefined]
 
+;; 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-member?
+ (-poly (a)
+        (cl->* ((-treelist a) a . -> . Univ)
+               ((-treelist a) a (-> a a Univ) . -> . B)))]
+[treelist-first (-poly (a) (-> (-treelist a) a :T+ #f))]
+[treelist-last (-poly (a) (-> (-treelist a) a :T+ #f))]
+[treelist-rest (-poly (a) (-> (-treelist a) (-treelist a)))]
+[treelist-add (-poly (a) (-> (-treelist a) a (-treelist a)))]
+[treelist-cons (-poly (a) (-> (-treelist a) a (-treelist a)))]
+[treelist-delete (-poly (a) (-> (-treelist a) -Index (-treelist a)))]
+[make-treelist (-poly (a) (-> -Nat a (-treelist a)))]
+[treelist-ref (-poly (a) (-> (-treelist a) -Index a))]
+[treelist-insert (-poly (a) (-> (-treelist a) -Index a (-treelist a)))]
+[treelist-set (-poly (a) (-> (-treelist a) -Index a (-treelist a)))]
+[treelist-take (-poly (a) (-> (-treelist a) -Index (-treelist a)))]
+[treelist-drop (-poly (a) (-> (-treelist a) -Index (-treelist a)))]
+[treelist-take-right (-poly (a) (-> (-treelist a) -Index (-treelist a)))]
+[treelist-drop-right (-poly (a) (-> (-treelist a) -Index (-treelist a)))]
+[treelist-sublist (-poly (a) (-> (-treelist a) -Index -Index (-treelist a)))]
+[treelist-reverse (-poly (a) (-> (-treelist a) (-treelist a)))]
+[treelist->list (-poly (a) (-> (-treelist a) (-lst a)))]
+[list->treelist (-poly (a) (-> (-lst a) (-treelist a)))]
+[treelist->vector (-poly (a) (-> (-treelist a) (-vec a)))]
+[vector->treelist (-poly (a) (-> (-vec a) (-treelist a)))]
+[in-treelist (-poly (a) (-> (-treelist a) (-seq a)))]
+[treelist? (unsafe-shallow:make-pred-ty (-treelist Univ))]
+[treelist-append (-poly (a) (->* (list) (-treelist a) (-treelist a)))]
+[treelist-map (-poly (a b) (-> (-treelist a) (-> a b) (-treelist b)))]
+[treelist-for-each (-poly (a b) (-> (-treelist a) (-> a b) -Void))]
+[treelist-filter (-poly (a) (-> (-> a Univ) (-treelist a) (-treelist a)))]
+[treelist-find (-poly (a) (-> (-treelist a) (-> a Univ) a))]
+[treelist-index-of
+ (-poly (a)
+        (cl->* ((-treelist a) a . -> . -Index)
+               ((-treelist a) a (-> a a Univ) . -> . -Index)))]
+[treelist-flatten (-poly (a) (-> a (-treelist a)))] ;; This type isn't any more or less pratical than Univ, but Univ might not be sound
+[treelist-append* (-poly (a) (-> (-treelist (-treelist a)) (-treelist a)))] ;; Same type specificty issue as above
+[treelist-sort
+(-poly
+  (a b)
+  (cl->*
+   (->key (-treelist a) (-> a a -Boolean) #:key (-opt (-> a a :T+ #f)) #f #:cache-keys? -Boolean #f (-treelist a))
+   (->key (-treelist a) (-> b b -Boolean) #:key (-> a b :T+ #f) #t #:cache-keys? -Boolean #f (-treelist a))))]
+
+
 ;; Section 5.2 (Structure Types)
 [make-struct-type
  (->opt -Symbol
diff --git a/typed-racket-lib/typed-racket/base-env/base-types.rkt b/typed-racket-lib/typed-racket/base-env/base-types.rkt
@@ -197,6 +197,7 @@
 [Async-Channelof -async-channel]
 [Ephemeronof -Ephemeron]
 [Setof -set]
+[TreeListof -treelist]
 [Evtof -evt]
 [Continuation-Mark-Set -Cont-Mark-Set]
 [False -False]
diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt
@@ -155,6 +155,8 @@
      `(-CustodianBox ,(type->sexp ty))]
     [(Set: ty)
      `(make-Set ,(type->sexp ty))]
+    [(TreeList: ty)
+     `(make-TreeList ,(type->sexp ty))]
     [(Evt: ty)
      `(make-Evt ,(type->sexp ty))]
     [(Future: ty)
diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt
@@ -827,6 +827,8 @@
          (cg e e*)]
         [((Set: a) (Set: a*))
          (cg a a*)]
+        [((TreeList: a) (TreeList: a*))
+         (cg a a*)]
         [((Evt: a) (Evt: a*))
          (cg a a*)]
         [((? Base:Semaphore?) (Evt: t))
diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -42,6 +42,7 @@
  racket/format
  racket/string
  racket/set
+ racket/treelist
  syntax/flatten-begin
  (only-in "../types/abbrev.rkt" -Bottom -Boolean)
  "../static-contracts/instantiate.rkt"
@@ -564,6 +565,7 @@
        [(? Fun? t) (t->sc/fun t)]
        [(? DepFun? t) (t->sc/fun t)]
        [(Set: t) (set/sc (t->sc t))]
+       [(TreeList: t) (treelist/sc (t->sc t))]
        [(Sequence: (list t))
         #:when (subtype t:-Nat t)
         ;; sequence/c is always a wrapper, so avoid it when we just have a number
@@ -930,6 +932,7 @@
         none/sc
         (make-procedure-arity-flat/sc num-mand-args '() '()))]
      [(Set: _) set?/sc]
+     [(TreeList: _) treelist?/sc] 
      [(or (Sequence: _)
           (SequenceTop:)
           (SequenceDots: _ _ _))
diff --git a/typed-racket-lib/typed-racket/rep/type-mask.rkt b/typed-racket-lib/typed-racket/rep/type-mask.rkt
@@ -143,6 +143,7 @@
  mask:future
  mask:other-box
  mask:set
+ mask:treelist
  mask:procedure
  mask:prompt-tag
  mask:continuation-mark-key
diff --git a/typed-racket-lib/typed-racket/rep/type-rep.rkt b/typed-racket-lib/typed-racket/rep/type-rep.rkt
@@ -353,6 +353,14 @@
 (def-structural Set ([elem #:covariant])
   [#:mask mask:set])
 
+;;------
+;; Treelist
+;;------
+
+;; TODO separate mutable/immutable treelist types
+(def-structural TreeList ([elem #:covariant])
+  [#:mask mask:treelist])
+
 ;;------------
 ;; HashTable
 ;;------------
diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt
@@ -11,6 +11,7 @@
                        racket/list
                        racket/promise
                        racket/set
+                       racket/treelist
                        racket/unit)
          "simple.rkt"
          "structural.rkt")
@@ -30,6 +31,10 @@
 (define set?/sc (flat/sc #'(lambda (x) (or (set? x) (set-mutable? x) (set-weak? x)))))
 (define empty-set/sc (and/sc set?/sc (flat/sc #'set-empty?)))
 
+;; TODO: Split TreeList into Mutable and Immutable
+(define treelist?/sc (flat/sc #'treelist?))
+(define empty-treelist/sc (and/sc treelist?/sc (flat/sc #'treelist-empty?)))
+
 (define vector?/sc (flat/sc #'vector?))
 (define immutable-vector?/sc (and/sc vector?/sc
                                      (flat/sc #'immutable?)))
diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
@@ -9,10 +9,12 @@
          racket/match
          (for-syntax racket/base racket/syntax syntax/stx syntax/parse)
          racket/set
+         racket/treelist
          racket/sequence
          (for-template racket/base
                        racket/contract/base
                        racket/set
+                       racket/treelist
                        racket/async-channel
                        racket/sequence
                        racket/promise
@@ -160,6 +162,7 @@
   ((listof/sc (#:covariant)) listof #:flat)
   ((cons/sc (#:covariant) (#:covariant)) cons/c #:flat)
   ((set/sc (#:covariant #:chaperone)) set/c #:flat)
+  ((treelist/sc (#:covariant #:chaperone)) treelist/c #:flat)
   ((struct-property/sc (#:invariant)) struct-type-property/c #:impersonator)
   ((immutable-vectorof/sc (#:covariant)) immutable-vectorof/c #:flat)
   ((mutable-vectorof/sc (#:invariant)) mutable-vectorof/c #:chaperone)
diff --git a/typed-racket-lib/typed-racket/types/abbrev.rkt b/typed-racket-lib/typed-racket/types/abbrev.rkt
@@ -49,6 +49,7 @@
 (define -thread-cell make-ThreadCell)
 (define -Promise make-Promise)
 (define -set make-Set)
+(define -treelist make-TreeList)
 (define -mvec make-Mutable-Vector)
 (define -ivec make-Immutable-Vector)
 
diff --git a/typed-racket-lib/typed-racket/types/printer.rkt b/typed-racket-lib/typed-racket/types/printer.rkt
@@ -687,6 +687,7 @@
     [(Ephemeron: e) `(Ephemeronof ,(t->s e))]
     [(CustodianBox: e) `(CustodianBoxof ,(t->s e))]
     [(Set: e) `(Setof ,(t->s e))]
+    [(TreeList: e) `(TreeListof ,(t->s e))]
     [(Evt: r) `(Evtof ,(t->s r))]
     [(? Union? (app normalize-type type))
      (match type
diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt
@@ -381,6 +381,7 @@
   racket/port
   racket/sequence
   racket/set
+  racket/treelist
   racket/string
   racket/system
   racket/tcp
@@ -1900,6 +1901,63 @@
         (tc-e (list->seteqv (list 'one 'two)) (-set (one-of/c 'one 'two)))
         (tc-e (set->list (set 'one 'two)) (-lst (one-of/c 'one 'two)))
 
+        ;;Treelist operations
+        
+        (tc-e (treelist-empty? (treelist)) -Boolean)
+        (tc-e (treelist-empty? (treelist "a" "b")) -Boolean)
+        (tc-e (treelist-length (treelist "a" "b" "c")) -Index)
+        (tc-e (treelist-member? (treelist 1) 1 =) -Boolean)
+        (tc-e (treelist-first (treelist "a")) -String)
+        (tc-e (treelist-last (treelist "a")) -String)
+        (tc-e (treelist-rest (treelist "a" "b")) (-treelist -String))
+        (tc-e (treelist-add (treelist "a") "b") (-treelist -String))
+        (tc-e (treelist-cons (treelist "a") "b") (-treelist -String))
+        (tc-e (treelist-cons (treelist "a") 9) (-treelist (t:Un -PosByte -String)))
+        (tc-e (treelist-delete (treelist "a") 0) (-treelist -String))
+        (tc-err (treelist-delete (treelist "a") "b"))
+        (tc-e (make-treelist 5 "a") (-treelist -String))
+        (tc-e (treelist-ref (treelist "a" "b") 1) -String)
+        (tc-err (treelist-ref (treelist "a" "b") "b"))
+        (tc-e (treelist-insert (treelist "a" "c") 1 "b") (-treelist -String))
+        (tc-e (treelist-insert (treelist "a" "c") 1 9) (-treelist (t:Un -PosByte -String)))
+        (tc-err (treelist-insert (treelist "a" "c") "b" "b"))
+        (tc-e (treelist-set (treelist "a" "c") 1 "b") (-treelist -String))
+        (tc-e (treelist-set (treelist "a" "c") 1 9) (-treelist (t:Un -PosByte -String)))
+        (tc-err (treelist-set (treelist "a" "c") "b" "b"))
+        (tc-e (treelist-take (treelist "a" "b") 1) (-treelist -String))
+        (tc-err (treelist-take (treelist "a" "b") "a"))
+        (tc-e (treelist-drop (treelist "a" "b") 1) (-treelist -String))
+        (tc-err (treelist-drop (treelist "a" "b") "a"))
+        (tc-e (treelist-take-right (treelist "a" "b") 1) (-treelist -String))
+        (tc-err (treelist-take-right (treelist "a" "b") "a"))
+        (tc-e (treelist-drop-right (treelist "a" "b") 1) (-treelist -String))
+        (tc-err (treelist-drop-right (treelist "a" "b") "a"))
+        (tc-e (treelist-sublist (treelist "a" "b" "c") 1 2) (-treelist -String))
+        (tc-err (treelist-sublist (treelist "a" "b" "c") 1 "c"))
+        (tc-err (treelist-sublist (treelist "a" "b" "c") "b" 1))
+        (tc-e (treelist-reverse (treelist "a" "b")) (-treelist -String))
+        (tc-e (treelist->list (treelist "a")) (-lst -String))
+        (tc-e (treelist->vector (treelist "a")) (-vec -String))
+        ;;(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? (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))
+        (tc-e (treelist-append (treelist "a") (treelist 9)) (-treelist (t:Un -PosByte -String)))
+        (tc-e (treelist-map (treelist "a" "b") (λ (x) "c")) (-treelist -String))
+        (tc-e (treelist-map (treelist "a" "b") (λ (x) 9)) (-treelist -PosByte))
+        (tc-e (treelist-for-each (treelist "a" "b") (λ (x) x)) -Void)
+        (tc-e (treelist-find (treelist "a" "b") (λ (x) (if (equal? x "a") #t #f))) -String)
+        (tc-e (treelist-filter even? (treelist 1 2 3 4 5)) (-treelist -PosByte))
+        (tc-e (treelist-flatten (treelist (treelist (treelist (treelist "a")))))
+              (-treelist (-treelist (-treelist (-treelist (-treelist -String)))))) ;;FIXME: this type is unpleasant
+        (tc-e (treelist-flatten "a") (-treelist -String))
+        (tc-e (treelist-append* (treelist (treelist "a" "b") (treelist "c" (treelist "d") "e") (treelist))) (-treelist Univ))
+        (tc-e (treelist-index-of (treelist "a" "b" "c") "b") -Index)
+        (tc-e (treelist-index-of (treelist "a" "b" "c") "b" equal?) -Index)
+        (tc-e (treelist-sort (treelist "c" "a" "b") string<?) (-treelist -String))
 
         ;Syntax
 
