pull/2/head
Matthew Butterick 10 years ago
parent 05c5b37316
commit a36a6c7f0d

@ -1,155 +0,0 @@
#lang racket/base
(require racket/contract net/url xml racket/set)
(module+ test (require rackunit))
(require "len.rkt" "exception.rkt" "define.rkt" "debug.rkt")
(define (make-coercion-error-handler target-format x)
(λ(e) (error (format "Cant convert ~a to ~a" x target-format))))
;; general way of coercing to integer
(define+provide/contract (->int x)
(any/c . -> . integer?)
(try
(cond
[(or (integer? x) (real? x)) (inexact->exact (floor x))]
[(and (string? x) (> (len x) 0)) (->int (string->number x))]
[(symbol? x) (->int (->string x))]
[(char? x) (char->integer x)]
[else (len x)])
(except [exn:fail? (make-coercion-error-handler 'integer x)])))
;; general way of coercing to string
(define+provide/contract (->string x)
(any/c . -> . string?)
(if (string? x)
x ; fast exit for strings
(try
(cond
[(equal? '() x) ""]
[(symbol? x) (symbol->string x)]
[(number? x) (number->string x)]
[(url? x) (->string (->path x))] ; todo: a url is more than just a path-string ... it has character encoding issues
[(path? x) (path->string x)]
[(char? x) (format "~a" x)]
[else (error)]) ; put this last so other xexprish things don't get caught
(except [exn:fail? (make-coercion-error-handler 'string x)]))))
;; general way of coercing to html
(define+provide/contract (->html x)
(any/c . -> . string?)
;; todo: omit 'script and 'style tags (and ... ?)
(try (xexpr->string x)
(except [exn:fail? (make-coercion-error-handler 'html x)])))
; todo: must get this right — no escaped chars
;(->html '(script ((type "text/javascript")) "3 > 2"))
;; general way of coercing to symbol
(define+provide/contract (->symbol x)
(any/c . -> . symbol?)
(if (symbol? x)
x
(try (string->symbol (->string x))
(except [exn:fail? (make-coercion-error-handler 'symbol x)]))))
;; general way of coercing to path
(define+provide/contract (->path x)
(any/c . -> . path?)
(if (path? x)
x
(try
(cond
[(url? x) (apply build-path (map path/param-path (url-path x)))]
[else (string->path (->string x))])
(except [exn:fail? (make-coercion-error-handler 'path x)]))))
;; general way of coercing to url
(define+provide/contract (->url x)
(any/c . -> . url?)
(try (string->url (->string x))
(except [exn:fail? (make-coercion-error-handler 'url x)])))
(define+provide/contract (->complete-path x)
(any/c . -> . complete-path?)
(try (path->complete-path (->path x))
(except [exn:fail? (make-coercion-error-handler 'complete-path x)])))
;; general way of coercing to a list
(define+provide/contract (->list x)
(any/c . -> . list?)
(if (list? x)
x
(try
(cond
[(vector? x) (vector->list x)]
[(set? x) (set->list x)]
[else (list x)])
(except [exn:fail? (make-coercion-error-handler 'list x)]))))
;; general way of coercing to vector
(define+provide/contract (->vector x)
(any/c . -> . vector?)
(if (vector? x)
x
(try
(list->vector (->list x))
(except [exn:fail? (make-coercion-error-handler 'vector x)]))))
;; general way of coercing to boolean
(define+provide/contract (->boolean x)
(any/c . -> . boolean?)
(if x #t #f))
;;
;; Coercion contracts
;;
(define-syntax-rule (make-blame-handler try-proc expected-sym)
(λ (b)
(λ (x)
(try (try-proc x)
(except [exn:fail? (λ(e)
(raise-blame-error
b x
'(expected: "~a" given: "~e")
expected-sym x))])))))
(define+provide coerce/integer?
(make-contract
#:name 'coerce/integer?
#:projection (make-blame-handler ->int 'can-be-integer?)))
(define+provide coerce/string?
(make-contract
#:name 'coerce/string?
#:projection (make-blame-handler ->string 'can-be-string?)))
(define+provide coerce/symbol?
(make-contract
#:name 'coerce/symbol?
#:projection (make-blame-handler ->symbol 'can-be-symbol?)))
(define+provide coerce/path?
(make-contract
#:name 'coerce/path?
#:projection (make-blame-handler ->path 'can-be-path?)))
(define+provide coerce/boolean?
(make-contract
#:name 'coerce/boolean?
#:projection (make-blame-handler ->boolean 'can-be-boolean?)))

@ -0,0 +1,4 @@
#lang racket/base
(require "coercion/values.rkt" "coercion/contracts.rkt")
(provide (all-from-out "coercion/values.rkt" "coercion/contracts.rkt"))

@ -0,0 +1,46 @@
#lang racket/base
(require racket/contract "../define/provide.rkt" "values.rkt")
(define-syntax-rule (make-blame-handler try-proc expected-sym)
(λ(b)
(λ(x)
(with-handlers ([exn:fail? (λ(e)
(raise-blame-error
b x
'(expected: "~a" given: "~e")
expected-sym x))])
(try-proc x)))))
(define+provide coerce/integer?
(make-contract
#:name 'coerce/integer?
#:projection (make-blame-handler ->int 'can-be-integer?)))
(define+provide coerce/string?
(make-contract
#:name 'coerce/string?
#:projection (make-blame-handler ->string 'can-be-string?)))
(define+provide coerce/symbol?
(make-contract
#:name 'coerce/symbol?
#:projection (make-blame-handler ->symbol 'can-be-symbol?)))
(define+provide coerce/path?
(make-contract
#:name 'coerce/path?
#:projection (make-blame-handler ->path 'can-be-path?)))
(define+provide coerce/boolean?
(make-contract
#:name 'coerce/boolean?
#:projection (make-blame-handler ->boolean 'can-be-boolean?)))

@ -0,0 +1,79 @@
#lang racket/base
(require net/url xml racket/set)
(require "../len.rkt" "../define/provide.rkt")
(define (make-coercion-error-handler target-format x)
(λ(e) (error (format "Cant convert ~a to ~a" x target-format))))
(define+provide (->int x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'integer x)])
(cond
[(or (integer? x) (real? x)) (inexact->exact (floor x))]
[(and (string? x) (> (len x) 0)) (->int (string->number x))]
[(symbol? x) (->int (->string x))]
[(char? x) (char->integer x)]
[else (len x)])))
(define+provide (->string x)
(if (string? x)
x ; fast exit for strings
(with-handlers ([exn:fail? (make-coercion-error-handler 'string x)])
(cond
[(equal? '() x) ""]
[(symbol? x) (symbol->string x)]
[(number? x) (number->string x)]
[(path? x) (path->string x)]
[(char? x) (format "~a" x)]
[else (error)]))))
(define+provide (->symbol x)
(if (symbol? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)])
(string->symbol (->string x)))))
(define+provide (->path x)
(if (path? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'path x)])
(cond
[(url? x) (apply build-path (map path/param-path (url-path x)))]
[else (string->path (->string x))]))))
(define+provide (->url x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'url x)])
(string->url (->string x))))
(define+provide (->complete-path x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)])
(path->complete-path (->path x))))
(define+provide (->list x)
(if (list? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'list x)])
(cond
[(vector? x) (vector->list x)]
[(set? x) (set->list x)]
[else (list x)]))))
(define+provide (->vector x)
(if (vector? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)])
(list->vector (->list x)))))
(define+provide (->boolean x)
(if x #t #f))

@ -1,48 +1,36 @@
#lang racket/base
(require racket/contract racket/vector racket/list)
(require "coerce.rkt" "len.rkt")
(require "define/contract.rkt")
(require "coercion.rkt" "len.rkt" racket/list)
(provide get in?)
(define/contract (sliceable-container? x)
(any/c . -> . boolean?)
(define (sliceable-container? x)
(ormap (λ(proc) (proc x)) (list list? string? symbol? vector?)))
(define/contract (gettable-container? x)
(any/c . -> . boolean?)
(define (gettable-container? x)
(ormap (λ(proc) (proc x)) (list sliceable-container? hash?)))
;; general way of fetching an item from a container
(define/contract (get container start [end #f])
((gettable-container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end)))))
. ->* . any/c)
(define+provide/contract (get container start [end #f])
((gettable-container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) . ->* . any/c)
(set! end
(if (sliceable-container? container)
(cond
;; treat negative lengths as offset from end (Python style)
[(and (integer? end) (< end 0)) (+ (len container) end)]
;; 'end slices to the end
[(equal? end 'end) (len container)]
;; default to slice length of 1 (i.e, single-item retrieval)
[(equal? end #f) (add1 start)]
[else end])
end))
(define result (cond
;; for sliceable containers, make a slice
[(list? container) (for/list ([i (range start end)])
(list-ref container i))]
[(vector? container) (for/vector ([i (range start end)])
(vector-ref container i))]
[(string? container) (substring container start end)]
[(symbol? container) (->symbol (get (->string container) start end))]
;; for hash, just get item
[(hash? container) (hash-ref container start)]
[else #f]))
(define result
(with-handlers ([exn:fail? (λ(exn) (error (format "Couldn't get item from ~a" container)))])
(let ([end (if (sliceable-container? container)
(cond
;; treat negative lengths as offset from end (Python style)
[(and (integer? end) (< end 0)) (+ (len container) end)]
;; 'end slices to the end
[(equal? end 'end) (len container)]
;; default to slice length of 1 (i.e, single-item retrieval)
[(equal? end #f) (add1 start)]
[else end])
end)])
(cond
[(list? container) (for/list ([i (range start end)]) (list-ref container i))]
[(vector? container) (for/vector ([i (range start end)]) (vector-ref container i))]
[(string? container) (substring container start end)]
[(symbol? container) (->symbol (get (->string container) start end))]
[(hash? container) (hash-ref container start)]
[else (error)]))))
;; don't return single-item results inside a list
(if (and (sliceable-container? container) (= (len result) 1))
@ -50,18 +38,12 @@
result))
;; general way of testing for membership (à la Python 'in')
;; put item as first arg so function can use infix notation
;; (item . in . container)
(define/contract (in? item container)
(define+provide/contract (in? item container)
(any/c any/c . -> . coerce/boolean?)
(cond
[(list? container) (member item container)] ; returns #f or sublist beginning with item
[(vector? container) (vector-member item container)] ; returns #f or zero-based item index
[(hash? container)
(and (hash-has-key? container item) (get container item))] ; returns #f or hash value
[(string? container) (regexp-match (->string item) (->string container))] ; returns #f or substring beginning with item
[(symbol? container) ((->string item) . in? . (->string container))] ; returns #f or subsymbol (?!) beginning with item
[(vector? container) (member item (vector->list container))] ; returns #f or sublist beginning with item
[(hash? container) (and (hash-has-key? container item) (get container item))] ; returns #f or hash value
[(string? container) (and (string? item) (regexp-match (->string item) (->string container)))] ; returns #f or substring beginning with item
[(symbol? container) (and (symbol? item) ((->string item) . in? . (->string container)))] ; returns #f or subsymbol (?!) beginning with item
[else #f]))

@ -2,14 +2,12 @@
(provide report describe)
; report the current value of the variable, then return it
(define-syntax-rule (report var)
(begin
(displayln (format "~a = ~a" 'var var) (current-error-port))
var))
(require (prefix-in williams: (planet williams/describe/describe)))
(require (prefix-in williams: describe))
(define (describe x)
(parameterize ([current-output-port (current-error-port)])

@ -1,40 +1,5 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/contract)
(provide define+provide define+provide/contract define/contract+provide)
(require "define/provide.rkt" "define/contract.rkt")
;; each define macro recursively converts any form of define
;; into its lambda form (define name body ...) and then operates on that.
(define-syntax (define+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) body ...)
#'(define+provide proc
(λ(arg ... . rest-arg) body ...))]
[(_ name body ...)
#'(begin
(provide name)
(define name body ...))]))
(define-syntax (define+provide/contract stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide/contract proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide (contract-out [name contract]))
(define name body ...))]))
(define-syntax (define/contract+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define/contract+provide proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide name)
(define/contract name contract body ...))]))
(provide (all-from-out "define/provide.rkt" "define/contract.rkt"))

@ -0,0 +1,41 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/contract)
(provide (all-defined-out) (all-from-out racket/contract))
;; each define macro recursively converts any form of define
;; into its lambda form (define name body ...) and then operates on that.
(define-syntax (define+provide+safe stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide+safe proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(define name body ...)
(provide name)
(module+ safe
(provide (contract-out [name contract]))))]))
(define-syntax (define+provide/contract stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide/contract proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide (contract-out [name contract]))
(define name body ...))]))
(define-syntax (define/contract+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define/contract+provide proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide name)
(define/contract name contract body ...))]))

@ -0,0 +1,14 @@
#lang racket/base
(require (for-syntax racket/base))
(provide (all-defined-out))
(define-syntax (define+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) body ...)
#'(define+provide proc
(λ(arg ... . rest-arg) body ...))]
[(_ name body ...)
#'(begin
(provide name)
(define name body ...))]))

@ -1,9 +1,8 @@
#lang racket/base
(require (for-syntax racket/base))
(provide try)
(provide (all-defined-out))
;; Pythonlike try/except
(define-syntax (try stx)
(syntax-case stx ()
[(_ body ... (except tests ...))

@ -1,3 +1,4 @@
#lang info
(define collection "sugar")
(define scribblings '(("scribblings/sugar.scrbl" ())))
(define scribblings '(("scribblings/sugar.scrbl" ())))
(define deps '("describe"))

@ -1,21 +1,15 @@
#lang racket/base
(require racket/contract racket/set)
(require racket/set)
(provide len)
(define/contract (has-length? x)
(any/c . -> . boolean?)
(ormap (λ(proc) (proc x)) (list list? string? symbol? vector? hash? set?)))
;; general way of asking for length
(define/contract (len x)
(any/c . -> . (or/c integer? #f))
(define (len x)
(cond
[(list? x) (length x)]
[(string? x) (string-length x)]
[(symbol? x) (len (symbol->string x))]
[(vector? x) (len (vector->list x))]
[(vector? x) (vector-length x)]
[(hash? x) (len (hash-keys x))]
[(set? x) (len (set->list x))]
[(integer? x) (len (number->string x))]
[(set? x) (len (set->list x))]
[else (error "len: cant calculate length of" x)]))

@ -1,13 +1,12 @@
#lang racket/base
(require racket/contract racket/list racket/set)
(require "define.rkt" "len.rkt" "coerce.rkt")
(require racket/list racket/set)
(require "define/contract.rkt" "len.rkt" "coercion/values.rkt")
;; trim from beginning & end of list
(define+provide/contract (trim items test-proc)
(list? procedure? . -> . list?)
(dropf-right (dropf items test-proc) test-proc))
;; convert a list into a list of slices that are len long (last one might be shorter)
(define+provide/contract (list->slices xs len)
(list? integer? . -> . (listof list?))
(cond
@ -16,34 +15,19 @@
[else (cons (take xs len) (list->slices (drop xs len) len))]))
;; split list into list of sublists using test-proc
(define+provide/contract (splitf-at* xs split-test)
;; todo: better error message when split-test is not a predicate
(list? predicate/c . -> . (listof list?))
(define (&splitf-at* xs [acc '()]) ; use acc for tail recursion
(let loop ([xs (trim xs split-test)] [acc '()])
(if (empty? xs)
;; reverse because accumulation is happening backward
;; (because I'm using cons to push latest match onto front of list)
(reverse acc)
(reverse acc) ; because accumulation is happening backward
(let-values ([(item rest)
;; drop matching elements from front
;; then split on nonmatching
;; = nonmatching item + other elements (which will start with matching)
(splitf-at (dropf xs split-test) (compose1 not split-test))])
;; recurse, and store new item in accumulator
(&splitf-at* rest (cons item acc)))))
;; trim off elements matching split-test
(&splitf-at* (trim xs split-test)))
(loop rest (cons item acc))))))
;; count incidence of elements in a list
;; returns hash where key is element, value is incidence
;; todo: move this? Ideally it would be in tools,
;; but that would create a circular dependency.
(define+provide/contract (count-incidence x)
(list? . -> . hash?)
(define counter (make-hash))
@ -60,6 +44,7 @@
[(string? x) (members-unique? (string->list x))]
[else (error (format "members-unique cannot be determined for ~a" x))]))
(define+provide/contract (members-unique?/error x)
(any/c . -> . boolean?)
(define result (members-unique? x))

@ -1,7 +1,7 @@
#lang racket/base
(require
"coerce.rkt"
"coercion.rkt"
"container.rkt"
"debug.rkt"
"define.rkt"
@ -11,11 +11,12 @@
"len.rkt"
"exception.rkt"
"scribble.rkt"
"tree.rkt"
"values.rkt")
(provide
(all-from-out
"coerce.rkt"
"coercion.rkt"
"container.rkt"
"debug.rkt"
"define.rkt"
@ -25,4 +26,5 @@
"len.rkt"
"exception.rkt"
"scribble.rkt"
"tree.rkt"
"values.rkt"))

@ -1,13 +1,9 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/contract)
(require "define/contract.rkt")
(provide (contract-out
[bytecount->string (integer? . -> . string?)])
when/splice)
;; convert a bytecount into a string
(define (bytecount->string bytecount)
(define+provide/contract (bytecount->string bytecount)
(integer? . -> . string?)
(define (format-with-threshold threshold suffix)
;; upconvert by factor of 100 to get two digits after decimal
(format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix))
@ -28,6 +24,7 @@
;; for use inside quasiquote
;; instead of ,(when ...) use ,@(when/splice ...)
;; to avoid voids
(provide when/splice)
(define-syntax (when/splice stx)
(syntax-case stx ()
[(_ test body)

@ -1,7 +1,6 @@
#lang racket
(require (for-syntax racket/base))
(require "coerce.rkt")
(require "coercion/values.rkt")
(provide when/block)
@ -13,4 +12,7 @@
(define-syntax (when/block stx)
(syntax-case stx ()
[(_ condition body ...)
#'(if condition (string-append* (map ->string (list body ...))) "")]))
#'(if condition (string-append*
(with-handlers ([exn:fail? (λ(exn) (error (format "when/block: ~a" (exn-message exn))))])
(map ->string (list body ...))))
"")]))

@ -1,23 +1,14 @@
#lang racket/base
(require racket/contract)
(require "coerce.rkt" "container.rkt" "len.rkt" "exception.rkt")
(require "define/contract.rkt" "coercion.rkt")
(provide starts-with? ends-with? stringish?)
;; stringish: data type that can be trivially converted to string
;; todo: merge this with pathish
(define/contract (stringish? x)
(any/c . -> . boolean?)
(try (->boolean (->string x)) (except [exn:fail? (λ(e) #f)])))
(define+provide/contract (starts-with? str starter)
(string? string? . -> . coerce/boolean?)
(define starter-pattern (regexp (format "^~a" starter)))
(regexp-match starter-pattern str))
;; python-style string testers
(define/contract (starts-with? str starter)
(stringish? stringish? . -> . boolean?)
(let ([str (->string str)]
[starter (->string starter)])
(and (<= (len starter) (len str)) (equal? (get str 0 (len starter)) starter))))
(define/contract (ends-with? str ender)
(string? string? . -> . boolean?)
(and (<= (len ender) (len str)) (equal? (get str (- (len str) (len ender)) 'end) ender)))
(define+provide/contract (ends-with? str ender)
(string? string? . -> . coerce/boolean?)
(define ender-pattern (regexp (format "~a$" ender)))
(regexp-match ender-pattern str))

@ -1,13 +1,13 @@
#lang racket/base
(require rackunit net/url racket/set)
(require "coerce.rkt" "container.rkt" "string.rkt" "list.rkt" "len.rkt")
(require "main.rkt")
(check-equal? (->string "foo") "foo")
(check-equal? (->string '()) "")
(check-equal? (->string 'foo) "foo")
(check-equal? (->string 123) "123")
(check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html")
;(check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html")
(define file-name-as-text "foo.txt")
(check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
(check-equal? (->string #\¶) "")
@ -90,5 +90,18 @@
; (check-equal? (trim (list "\n" " " 1 2 3 "\n") whitespace?) '(1 2 3))
(check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))
; (check-equal? (splitf-at* '("foo" " " "bar" "\n" "\n" "ino") whitespace?) '(("foo")("bar")("ino")))
(check-equal? (splitf-at* '(1 2 3 4 5 6) even?) '((1)(3)(5)))
;(check-equal? (splitf-at* '("foo" " " "bar" "\n" "\n" "ino") whitespace?) '(("foo")("bar")("ino")))
(check-equal? (splitf-at* '(1 2 3 4 5 6) even?) '((1)(3)(5)))
(check-equal? (filter-tree string? '(p)) null)
(check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar"))
(check-equal? (filter-tree string? '(p "foo" (p "bar"))) '("foo" ("bar")))
(check-equal? (filter-tree (λ(i) (and (string? i) (equal? i "\n"))) '("\n" (foo "bar") "\n")) '("\n" "\n"))
(check-equal? (filter-not-tree string? '(p)) '(p))
(check-equal? (filter-not-tree string? '(p "foo" "bar")) '(p))
(check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p)))
;(check-equal? (filter-tree (λ(i) (and (tagged-xexpr? i) (equal? 'em (car i)))) '(p "foo" (em "bar"))) '(p "foo"))
(check-equal? (map-tree (λ(i) (if (number? i) (* 2 i) i)) '(p 1 2 3 (em 4 5))) '(p 2 4 6 (em 8 10)))
(check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5)))

@ -1,51 +1,31 @@
#lang racket/base
(require racket/list racket/contract)
(require "define.rkt")
(require "define/contract.rkt")
(module+ test (require rackunit))
;; apply filter proc recursively
(define+provide/contract (filter-tree proc tree)
(procedure? list? . -> . list?)
(define (remove-empty x)
(cond
[(list? x) (filter-not empty? (map remove-empty x))]
[(list? x) (filter (compose1 not null?) (map remove-empty x))]
[else x]))
(define (filter-tree-inner proc x)
(cond
[(list? x) (map (λ(i) (filter-tree-inner proc i)) x)]
[else (if (proc x) x empty)]))
[else (if (proc x) x null)]))
(remove-empty (filter-tree-inner proc tree)))
(module+ test
(check-equal? (filter-tree string? '(p)) empty)
(check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar"))
(check-equal? (filter-tree string? '(p "foo" (p "bar"))) '("foo" ("bar")))
(check-equal? (filter-tree (λ(i) (and (string? i) (equal? i "\n"))) '("\n" (foo "bar") "\n")) '("\n" "\n")))
;; apply filter-not proc recursively
(define+provide/contract (filter-not-tree proc tree)
(procedure? list? . -> . list?)
(filter-tree (λ(i) (not (proc i))) tree))
(module+ test
(check-equal? (filter-not-tree string? '(p)) '(p))
(check-equal? (filter-not-tree string? '(p "foo" "bar")) '(p))
(check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p)))
;(check-equal? (filter-tree (λ(i) (and (tagged-xexpr? i) (equal? 'em (car i)))) '(p "foo" (em "bar"))) '(p "foo"))
)
;; todo: doc this function
(define+provide/contract (map-tree proc tree)
(procedure? list? . -> . list?)
(cond
[(list? tree) (map (λ(i) (map-tree proc i)) tree)]
[else (proc tree)]))
(module+ test
(check-equal? (map-tree (λ(i) (if (number? i) (* 2 i) i)) '(p 1 2 3 (em 4 5))) '(p 2 4 6 (em 8 10)))
(check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5))))
Loading…
Cancel
Save