diff --git a/coerce.rkt b/coerce.rkt deleted file mode 100644 index 3fc063d..0000000 --- a/coerce.rkt +++ /dev/null @@ -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 "Can’t 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?))) - - diff --git a/coercion.rkt b/coercion.rkt new file mode 100644 index 0000000..ed283d5 --- /dev/null +++ b/coercion.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require "coercion/values.rkt" "coercion/contracts.rkt") +(provide (all-from-out "coercion/values.rkt" "coercion/contracts.rkt")) \ No newline at end of file diff --git a/coercion/contracts.rkt b/coercion/contracts.rkt new file mode 100644 index 0000000..dd5dd27 --- /dev/null +++ b/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?))) + + + + diff --git a/coercion/values.rkt b/coercion/values.rkt new file mode 100644 index 0000000..74801cb --- /dev/null +++ b/coercion/values.rkt @@ -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 "Can’t 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)) + + diff --git a/container.rkt b/container.rkt index ff99d2f..80b8ee4 100644 --- a/container.rkt +++ b/container.rkt @@ -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])) \ No newline at end of file diff --git a/debug.rkt b/debug.rkt index 648504d..4458c88 100644 --- a/debug.rkt +++ b/debug.rkt @@ -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)]) diff --git a/define.rkt b/define.rkt index 8c424ee..68f0e7a 100644 --- a/define.rkt +++ b/define.rkt @@ -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")) \ No newline at end of file diff --git a/define/contract.rkt b/define/contract.rkt new file mode 100644 index 0000000..bd0c873 --- /dev/null +++ b/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 ...))])) diff --git a/define/provide.rkt b/define/provide.rkt new file mode 100644 index 0000000..d3fb289 --- /dev/null +++ b/define/provide.rkt @@ -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 ...))])) diff --git a/exception.rkt b/exception.rkt index 5e52a45..f25dc89 100644 --- a/exception.rkt +++ b/exception.rkt @@ -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 ...)) diff --git a/info.rkt b/info.rkt index e503bab..8305531 100644 --- a/info.rkt +++ b/info.rkt @@ -1,3 +1,4 @@ #lang info (define collection "sugar") -(define scribblings '(("scribblings/sugar.scrbl" ()))) \ No newline at end of file +(define scribblings '(("scribblings/sugar.scrbl" ()))) +(define deps '("describe")) \ No newline at end of file diff --git a/len.rkt b/len.rkt index ea8864b..13687ec 100644 --- a/len.rkt +++ b/len.rkt @@ -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: can’t calculate length of" x)])) \ No newline at end of file diff --git a/list.rkt b/list.rkt index 89b1558..66cc4e9 100644 --- a/list.rkt +++ b/list.rkt @@ -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)) diff --git a/main.rkt b/main.rkt index 6bb9849..dcc41e5 100644 --- a/main.rkt +++ b/main.rkt @@ -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")) \ No newline at end of file diff --git a/misc.rkt b/misc.rkt index 7bae232..4f0036d 100644 --- a/misc.rkt +++ b/misc.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) diff --git a/scribble.rkt b/scribble.rkt index b8806f2..dfd92e3 100644 --- a/scribble.rkt +++ b/scribble.rkt @@ -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 ...)))) + "")])) \ No newline at end of file diff --git a/string.rkt b/string.rkt index 6c36193..34f1f00 100644 --- a/string.rkt +++ b/string.rkt @@ -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))) \ No newline at end of file +(define+provide/contract (ends-with? str ender) + (string? string? . -> . coerce/boolean?) + (define ender-pattern (regexp (format "~a$" ender))) + (regexp-match ender-pattern str)) \ No newline at end of file diff --git a/tests.rkt b/tests.rkt index d349762..66402a9 100644 --- a/tests.rkt +++ b/tests.rkt @@ -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))) \ No newline at end of file +;(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))) \ No newline at end of file diff --git a/tree.rkt b/tree.rkt index cfe2c1b..5e42dda 100644 --- a/tree.rkt +++ b/tree.rkt @@ -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)))) \ No newline at end of file