[list] implemented some functions, need tests

trivial/define.rkt

@@ -14,6 +14,9 @@
   (only-in trivial/private/format
     format-define
     format-let)
+  (only-in trivial/private/list
+    lst-define
+    lst-let)
   (only-in trivial/private/math
     num-define
     num-let)
@@ -31,6 +34,7 @@
   (lambda (stx)
     (or (format-define stx)
         (num-define stx)
+        (lst-define stx)
         (rx-define stx)
         (fun-define stx)
         (vec-define stx)))))
@@ -40,5 +44,6 @@
     (or (format-let stx)
         (fun-let stx)
         (num-let stx)
+        (lst-let stx)
         (rx-let stx)
         (vec-let stx)))))

trivial/list.rkt

@@ -0,0 +1,43 @@
+#lang typed/racket/base
+
+(provide
+  set!
+  (all-from-out racket/list)
+
+  define-list:
+  let-list:
+  pair?:
+  null?:
+  cons:
+  car:
+  cdr:
+  list?:
+  length:
+  list-ref:
+  list-tail:
+  append:
+  reverse:
+  map:
+)
+
+;; -----------------------------------------------------------------------------
+
+(require
+  racket/list
+  trivial/private/set-bang
+  (only-in trivial/private/list
+    define-list:
+    let-list:
+    pair?:
+    null?:
+    cons:
+    car:
+    cdr:
+    list?:
+    length:
+    list-ref:
+    list-tail:
+    append:
+    reverse:
+    map:
+))

trivial/list/no-colon.rkt

@@ -0,0 +1,19 @@
+#lang typed/racket/base
+(provide (rename-out
+  (define-list:            define-list)
+  (let-list:               let-list)
+  (pair?:                  pair?)
+  (null?:                  null?)
+  (cons:                   cons)
+  (car:                    car)
+  (cdr:                    cdr)
+  (list?:                  list?)
+  (length:                 length)
+  (list-ref:               list-ref)
+  (list-tail:              list-tail)
+  (append:                 append)
+  (reverse:                reverse)
+  (map:                    map)
+))
+(require trivial/list)
+

trivial/private/list.rkt

@@ -0,0 +1,198 @@
+#lang typed/racket/base
+
+(provide
+  define-list:
+  let-list:
+  pair?:
+  null?:
+  cons:
+  car:
+  cdr:
+  list?:
+  length:
+  list-ref:
+  list-tail:
+  append:
+  reverse:
+  map:
+  ;andmap:
+  ;ormap:
+  ;for-each:
+  ;foldl:
+  ;foldr:
+  ;filter:
+  ;remove:
+  ;remq:
+  ;remv:
+  ;remove*:
+  ;remq*:
+  ;remv*:
+  ;sort:
+  ;member:
+
+  ;; --- private
+  (for-syntax
+    lst-define
+    lst-let
+    parse-list-length
+    lst-length-key ;; TODO generic "data structure length" key?
+  )
+)
+
+;; -----------------------------------------------------------------------------
+
+(require
+  trivial/private/math
+  typed/racket/unsafe
+  racket/list
+  (for-syntax
+    trivial/private/common
+    trivial/private/sequence
+    typed/racket/base
+    syntax/parse))
+
+(unsafe-require/typed racket/unsafe/ops
+  (unsafe-car (All (A) (-> (Listof A) A)))
+  (unsafe-cdr (All (A) (-> (Listof A) (Listof A))))
+  (unsafe-cons-list (All (A) (-> A (Listof A) (Listof A))))
+  (unsafe-list-ref (All (A) (-> (Listof A) Integer A)))
+  (unsafe-list-tail (All (A) (-> (Listof A) Integer (Listof A)))))
+
+;; =============================================================================
+
+(begin-for-syntax
+  (define (parse-list-length stx)
+    (syntax-parse stx #:literals (#%plain-app cons list list* make-list build-list null)
+     [(~or '(e* ...)
+            (list e* ...)
+            (#%plain-app list e* ...))
+      (length (syntax-e #'(e* ...)))]
+     [(~or (make-list n e* ...)
+           (#%plain-app make-list n e* ...)
+           (build-list n e* ...)
+           (#%plain-app build-list n e* ...))
+      #:with n-stx (stx->num #'n)
+      #:when (syntax-e #'n-stx)
+      (syntax-e #'n-stx)]
+     [(~or (cons e es)
+           (#%plain-app cons e es))
+      #:with n+ (parse-list-length #'es)
+      #:when (syntax-e #'n+)
+      (+ 1 (syntax-e #'n+))]
+     [(~or (list* e* ... es)
+           (#%plain-app list* e* ... es))
+      #:with n+ (parse-list-length #'es)
+      #:when (syntax-e #'n+)
+      (+ (length (syntax-e #'(e* ...))) (syntax-e #'n+))]
+     [(~or (null)
+           (#%plain-app null))
+      0]
+     [+ #f]))
+
+  (define-values (lst-length-key lst? lst-define lst-let)
+    (make-value-property 'list:length parse-list-length))
+  (define-syntax-class/predicate list/length lst?)
+)
+
+;; -----------------------------------------------------------------------------
+
+(define-syntax define-list: (make-keyword-alias 'define lst-define))
+(define-syntax let-list: (make-keyword-alias 'let lst-let))
+
+(define-syntax pair?: (make-alias #'pair?
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (quasisyntax/loc stx '#,(not (zero? (syntax-e #'l.evidence))))]
+   [_ #f]))))
+
+(define-syntax null?: (make-alias #'null?
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (quasisyntax/loc stx '#,(zero? (syntax-e #'l.evidence)))]
+   [_ #f]))))
+
+(define-syntax cons: (make-alias #'cons
+  (lambda (stx) (syntax-parse stx
+   [(_ x l:list/length)
+    #:with l+ (syntax-property
+                (syntax/loc stx (unsafe-cons-list x l.expanded))
+                lst-length-key (+ 1 (syntax-e #'l.evidence)))
+    (syntax/loc stx l+)]
+   [_ #f]))))
+
+(define-syntax car: (make-alias #'car
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (when (zero? (syntax-e #'l.evidence))
+      (bounds-error 'car: #'l 0))
+    (syntax/loc stx (unsafe-car l.expanded))]
+   [_ #f]))))
+
+(define-syntax cdr: (make-alias #'cdr
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (when (zero? (syntax-e #'l.evidence))
+      (bounds-error 'cdr: #'l 0))
+    (syntax/loc stx (unsafe-cdr l.expanded))]
+   [_ #f]))))
+
+(define-syntax list?: (make-alias #'list?
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (syntax/loc stx '#t)]
+   [_ #f]))))
+
+(define-syntax length: (make-alias #'length
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    (syntax/loc stx 'l.evidence)]
+   [_ #f]))))
+
+(define-syntax list-ref: (make-alias #'list-ref
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length e)
+    #:with i-stx (stx->num #'e)
+    #:when (syntax-e #'i-stx)
+    (let ([i (syntax-e #'i-stx)])
+      (unless (< i (syntax-e #'l.evidence))
+        (bounds-error 'list-ref: #'l i))
+      (syntax/loc stx (unsafe-list-ref l.expanded 'i-stx)))]
+   [_ #f]))))
+
+(define-syntax list-tail: (make-alias #'list-tail
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length e)
+    #:with i-stx (stx->num #'e)
+    #:when (syntax-e #'i-stx)
+    (let ([i (syntax-e #'i-stx)])
+      (unless (< i (syntax-e #'l.evidence))
+        (bounds-error 'list-tail: #'l i))
+      (syntax/loc stx (unsafe-list-tail l.expanded 'i-stx)))]
+   [_ #f]))))
+
+(define-syntax append: (make-alias #'append
+  (lambda (stx) (syntax-parse stx
+   [(_ l1:list/length l2:list/length)
+    #:with l+ (syntax-property (syntax/loc stx (append l1.expanded l2.expanded))
+                lst-length-key (+ (syntax-e #'l1.evidence) (syntax-e #'l2.evidence)))
+    (quasisyntax/loc stx l+)]
+   [_ #f]))))
+
+(define-syntax reverse: (make-alias #'reverse
+  (lambda (stx) (syntax-parse stx
+   [(_ l:list/length)
+    #:with l+ (syntax-property (syntax/loc stx (reverse l.expanded))
+                lst-length-key (syntax-e #'l.evidence))
+    (quasisyntax/loc stx l+)]
+   [_ #f]))))
+
+(define-syntax map: (make-alias #'map
+  (lambda (stx) (syntax-parse stx
+   [(_ f l:list/length l*:list/length ...)
+    #:with l+ (syntax-property
+                (syntax/loc stx (map f l.expanded l*.expanded ...))
+                lst-length-key
+                (syntax-e #'l.evidence))
+    (syntax/loc stx l+)]
+   [_ #f]))))
+

trivial/private/sequence.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+
+(provide
+  small-sequence-size?
+  bounds-error
+)
+
+;; =============================================================================
+
+(define (small-sequence-size? n)
+  (< n 20))
+
+(define (bounds-error sym v-stx i)
+  (raise-syntax-error
+    sym
+    "Index out-of-bounds"
+    (syntax->datum v-stx)
+    i
+    (list v-stx)))
+

trivial/private/vector.rkt

@@ -37,23 +37,13 @@
   racket/vector
   (for-syntax
     trivial/private/common
+    trivial/private/sequence
     typed/racket/base
     syntax/parse))
 
 ;; =============================================================================
 
 (begin-for-syntax
-  (define (small-vector-size? n)
-    (< n 20))
-
-  (define (vector-bounds-error sym v-stx i)
-    (raise-syntax-error
-      sym
-      "Index out-of-bounds"
-      (syntax->datum v-stx)
-      i
-      (list v-stx)))
-
   (define (parse-vector-length stx)
     (syntax-parse stx #:literals (#%plain-app vector make-vector build-vector)
      [(~or '#(e* ...)
@@ -95,7 +85,7 @@
     #:when (syntax-e #'i-stx)
     (let ([i (syntax-e #'i-stx)])
       (unless (< i (syntax-e #'v.evidence))
-        (vector-bounds-error 'vector-ref: #'v i))
+        (bounds-error 'vector-ref: #'v i))
       (syntax/loc stx (unsafe-vector-ref v.expanded 'i-stx)))]
    [_ #f]))))
 
@@ -106,7 +96,7 @@
     #:when (syntax-e #'i-stx)
     (let ([i (syntax-e #'i-stx)])
       (unless (< i (syntax-e #'v.evidence))
-        (vector-bounds-error 'vector-set!: #'v i))
+        (bounds-error 'vector-set!: #'v i))
       (syntax/loc stx (unsafe-vector-set! v.expanded 'i-stx val)))]
    [_ #f]))))
 
@@ -116,7 +106,7 @@
     #:with f+ (gensym 'f)
     #:with v+ (gensym 'v)
     #:with v++ (syntax-property
-                 (if (small-vector-size? (syntax-e #'v.evidence))
+                 (if (small-sequence-size? (syntax-e #'v.evidence))
                    (with-syntax ([(i* ...) (for/list ([i (in-range (syntax-e #'v.evidence))]) i)])
                      (syntax/loc stx
                        (let ([f+ f] [v+ v.expanded])
@@ -154,8 +144,8 @@
     (define l1 (syntax-e #'v1.evidence))
     (define l2 (syntax-e #'v2.evidence))
     (syntax-property
-      (if (and (small-vector-size? l1)
-               (small-vector-size? l2))
+      (if (and (small-sequence-size? l1)
+               (small-sequence-size? l2))
         (with-syntax ([(i1* ...) (for/list ([i (in-range l1)]) i)]
                       [(i2* ...) (for/list ([i (in-range l2)]) i)])
           (syntax/loc stx
@@ -181,7 +171,7 @@
    [(_ v:vector/length)
     #:with v+ (gensym 'v)
     (define len (syntax-e #'v.evidence))
-    (if (small-vector-size? len)
+    (if (small-sequence-size? len)
       (with-syntax ([(i* ...) (for/list ([i (in-range len)]) i)])
         (syntax/loc stx
           (let ([v+ v.expanded])
@@ -233,7 +223,7 @@
       #:with n+ (gensym 'n)
       #:with v+ (gensym 'v)
       (unless (<= (syntax-e #'n-stx) (syntax-e #'v.evidence))
-        (vector-bounds-error (syntax-e #'op-name) #'v
+        (bounds-error (syntax-e #'op-name) #'v
           (if 'take? (if 'left? (syntax-e #'hi) (syntax-e #'lo))
                      (if 'left? (syntax-e #'lo) (syntax-e #'hi)))))
       (syntax-property
@@ -244,7 +234,7 @@
         vector-length-key
         (syntax-e #'v.evidence))]
      [(op-name v n:int/expand)
-      (vector-bounds-error (syntax-e #'op-name) #'v (stx->num #'n.expanded))]
+      (bounds-error (syntax-e #'op-name) #'v (stx->num #'n.expanded))]
      [_ #f]))))
 
 (define-syntax vector-take: