From 316ab9cf329d35201e6835616d305d692a6b698a Mon Sep 17 00:00:00 2001 From: Ben Greenman Date: Sun, 1 May 2016 21:01:20 -0400 Subject: [PATCH] [list] implemented some functions, need tests --- trivial/define.rkt | 5 + trivial/list.rkt | 43 ++++++++ trivial/list/no-colon.rkt | 19 ++++ trivial/private/list.rkt | 198 +++++++++++++++++++++++++++++++++++ trivial/private/sequence.rkt | 20 ++++ trivial/private/vector.rkt | 28 ++--- 6 files changed, 294 insertions(+), 19 deletions(-) create mode 100644 trivial/list.rkt create mode 100644 trivial/list/no-colon.rkt create mode 100644 trivial/private/list.rkt create mode 100644 trivial/private/sequence.rkt diff --git a/trivial/define.rkt b/trivial/define.rkt index a03f68f..6b8726e 100644 --- a/trivial/define.rkt +++ b/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))))) diff --git a/trivial/list.rkt b/trivial/list.rkt new file mode 100644 index 0000000..13a3151 --- /dev/null +++ b/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: +)) diff --git a/trivial/list/no-colon.rkt b/trivial/list/no-colon.rkt new file mode 100644 index 0000000..bdc8a15 --- /dev/null +++ b/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) + diff --git a/trivial/private/list.rkt b/trivial/private/list.rkt new file mode 100644 index 0000000..19d4b57 --- /dev/null +++ b/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])))) + diff --git a/trivial/private/sequence.rkt b/trivial/private/sequence.rkt new file mode 100644 index 0000000..d1f0f55 --- /dev/null +++ b/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))) + diff --git a/trivial/private/vector.rkt b/trivial/private/vector.rkt index f7ca794..ba8a8b5 100644 --- a/trivial/private/vector.rkt +++ b/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: