diff --git a/coerce.rkt b/coerce.rkt index 2983561..f6df0cd 100644 --- a/coerce.rkt +++ b/coerce.rkt @@ -37,6 +37,13 @@ (except [exn:fail? (make-coercion-error-handler 'string x)]))) +;; general way of coercing to html +(define+provide/contract (->html x) + (any/c . -> . string?) + (try (xexpr->string x) + (except [exn:fail? (make-coercion-error-handler 'html x)]))) + + ;; general way of coercing to symbol (define+provide/contract (->symbol x) (any/c . -> . symbol?) @@ -109,27 +116,27 @@ expected-sym x))]))))) -(define/provide coerce/integer? +(define+provide coerce/integer? (make-contract #:name 'coerce/integer? #:projection (make-blame-handler ->int 'can-be-integer?))) -(define/provide coerce/string? +(define+provide coerce/string? (make-contract #:name 'coerce/string? #:projection (make-blame-handler ->string 'can-be-string?))) -(define/provide coerce/symbol? +(define+provide coerce/symbol? (make-contract #:name 'coerce/symbol? #:projection (make-blame-handler ->symbol 'can-be-symbol?))) -(define/provide coerce/path? +(define+provide coerce/path? (make-contract #:name 'coerce/path? #:projection (make-blame-handler ->path 'can-be-path?))) -(define/provide coerce/boolean? +(define+provide coerce/boolean? (make-contract #:name 'coerce/boolean? #:projection (make-blame-handler ->boolean 'can-be-boolean?))) diff --git a/define.rkt b/define.rkt index 4d0bb89..981526a 100644 --- a/define.rkt +++ b/define.rkt @@ -2,12 +2,12 @@ (require (for-syntax racket/base)) (require racket/contract) -(provide define/provide define+provide/contract define/contract+provide) +(provide define+provide define+provide/contract define/contract+provide) -(define-syntax (define/provide stx) +(define-syntax (define+provide stx) (syntax-case stx () [(_ (proc arg ... . rest-arg) body ...) - #'(define/provide proc + #'(define+provide proc (λ(arg ... . rest-arg) body ...))] [(_ name body ...) #'(begin diff --git a/list.rkt b/list.rkt index e08e45e..436b71c 100644 --- a/list.rkt +++ b/list.rkt @@ -1,16 +1,15 @@ #lang racket/base -(require racket/contract racket/list) - -(provide trim splitf-at*) +(require racket/contract racket/list racket/set) +(require "define.rkt" "len.rkt" "coerce.rkt") ;; trim from beginning & end of list -(define (trim items test-proc) +(define+provide/contract (trim items test-proc) (list? procedure? . -> . list?) (dropf-right (dropf items test-proc) test-proc)) ;; split list into list of sublists using test-proc -(define/contract (splitf-at* xs split-test) +(define+provide/contract (splitf-at* xs split-test) ;; todo: better error message when split-test is not a predicate (list? predicate/c . -> . (listof list?)) @@ -28,4 +27,36 @@ (&splitf-at* rest (cons item acc))))) ;; trim off elements matching split-test - (&splitf-at* (trim xs split-test))) \ No newline at end of file + (&splitf-at* (trim xs split-test))) + + +;; 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)) + (for ([item (flatten x)]) + (hash-set! counter item (add1 (hash-ref counter item 0)))) + counter) + + +(define+provide/contract (members-unique? x) + (any/c . -> . boolean?) + (cond + [(list? x) (= (len (apply set x)) (len x))] + [(vector? x) (members-unique? (->list x))] + [(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)) + (if (not result) + (let* ([duplicate-keys (filter-not empty? (hash-map (count-incidence x) + (λ(k v) (if (> v 1) k '()))))]) + (error (string-append (if (= (len duplicate-keys) 1) + "Item isn’t" + "Items aren’t") " unique:") duplicate-keys)) + result)) \ No newline at end of file diff --git a/tree.rkt b/tree.rkt new file mode 100644 index 0000000..cfe2c1b --- /dev/null +++ b/tree.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require racket/list racket/contract) +(require "define.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))] + [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)])) + + (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