mbutterick
/
sugar
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cleanup

Browse Source
pull/2/head
Matthew Butterick 11 years ago
parent 05c5b37316
commit a36a6c7f0d
19 changed files with 274 additions and 336 deletions
Show Stats Download Patch File Download Diff File

155
coerce.rkt
Unescape Escape View File

@ -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?)))

4
coercion.rkt
Unescape Escape View File

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

46
coercion/contracts.rkt
Unescape Escape View File

@ -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?)))

79
coercion/values.rkt
Unescape Escape View File

@ -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))

56
container.rkt
Unescape Escape View File

@ -1,27 +1,20 @@
#lang racket/base #lang racket/base
(require racket/contract racket/vector racket/list) (require "define/contract.rkt")
(require "coerce.rkt" "len.rkt") (require "coercion.rkt" "len.rkt" racket/list)
(provide get in?) (define (sliceable-container? x)
(define/contract (sliceable-container? x)
(any/c . -> . boolean?)
(ormap (λ(proc) (proc x)) (list list? string? symbol? vector?))) (ormap (λ(proc) (proc x)) (list list? string? symbol? vector?)))
(define/contract (gettable-container? x) (define (gettable-container? x)
(any/c . -> . boolean?)
(ormap (λ(proc) (proc x)) (list sliceable-container? hash?))) (ormap (λ(proc) (proc x)) (list sliceable-container? hash?)))
(define+provide/contract (get container start [end #f])
((gettable-container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) . ->* . any/c)
;; general way of fetching an item from a container (define result
(define/contract (get container start [end #f]) (with-handlers ([exn:fail? (λ(exn) (error (format "Couldn't get item from ~a" container)))])
((gettable-container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) (let ([end (if (sliceable-container? container)
. ->* . any/c)
(set! end
(if (sliceable-container? container)
(cond (cond
;; treat negative lengths as offset from end (Python style) ;; treat negative lengths as offset from end (Python style)
[(and (integer? end) (< end 0)) (+ (len container) end)] [(and (integer? end) (< end 0)) (+ (len container) end)]
@ -30,19 +23,14 @@
;; default to slice length of 1 (i.e, single-item retrieval) ;; default to slice length of 1 (i.e, single-item retrieval)
[(equal? end #f) (add1 start)] [(equal? end #f) (add1 start)]
[else end]) [else end])
end)) end)])
(cond
(define result (cond [(list? container) (for/list ([i (range start end)]) (list-ref container i))]
;; for sliceable containers, make a slice [(vector? container) (for/vector ([i (range start end)]) (vector-ref container i))]
[(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)] [(string? container) (substring container start end)]
[(symbol? container) (->symbol (get (->string container) start end))] [(symbol? container) (->symbol (get (->string container) start end))]
;; for hash, just get item
[(hash? container) (hash-ref container start)] [(hash? container) (hash-ref container start)]
[else #f])) [else (error)]))))
;; don't return single-item results inside a list ;; don't return single-item results inside a list
(if (and (sliceable-container? container) (= (len result) 1)) (if (and (sliceable-container? container) (= (len result) 1))
@ -50,18 +38,12 @@
result)) result))
(define+provide/contract (in? item container)
;; 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)
(any/c any/c . -> . coerce/boolean?) (any/c any/c . -> . coerce/boolean?)
(cond (cond
[(list? container) (member item container)] ; returns #f or sublist beginning with item [(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 [(vector? container) (member item (vector->list container))] ; returns #f or sublist beginning with item
[(hash? container) [(hash? container) (and (hash-has-key? container item) (get container item))] ; returns #f or hash value
(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
[(string? container) (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
[(symbol? container) ((->string item) . in? . (->string container))] ; returns #f or subsymbol (?!) beginning with item
[else #f])) [else #f]))

4
debug.rkt
Unescape Escape View File

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

39
define.rkt
Unescape Escape View File

@ -1,40 +1,5 @@
#lang racket/base #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 (provide (all-from-out "define/provide.rkt" "define/contract.rkt"))
;; 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 ...))]))

41
define/contract.rkt
Unescape Escape View File

@ -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 ...))]))

14
define/provide.rkt
Unescape Escape View File

@ -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 ...))]))

3
exception.rkt
Unescape Escape View File

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

1
info.rkt
Unescape Escape View File

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

14
len.rkt
Unescape Escape View File

@ -1,21 +1,15 @@
#lang racket/base #lang racket/base
(require racket/contract racket/set) (require racket/set)
(provide len) (provide len)
(define/contract (has-length? x) (define (len 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))
(cond (cond
[(list? x) (length x)] [(list? x) (length x)]
[(string? x) (string-length x)] [(string? x) (string-length x)]
[(symbol? x) (len (symbol->string x))] [(symbol? x) (len (symbol->string x))]
[(vector? x) (len (vector->list x))] [(vector? x) (vector-length x)]
[(hash? x) (len (hash-keys x))] [(hash? x) (len (hash-keys x))]
[(set? x) (len (set->list x))]
[(integer? x) (len (number->string x))] [(integer? x) (len (number->string x))]
[(set? x) (len (set->list x))]
[else (error "len: can’t calculate length of" x)])) [else (error "len: can’t calculate length of" x)]))

29
list.rkt
Unescape Escape View File

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

6
main.rkt
Unescape Escape View File

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

11
misc.rkt
Unescape Escape View File

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

8
scribble.rkt
Unescape Escape View File

@ -1,7 +1,6 @@
#lang racket #lang racket
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require "coerce.rkt") (require "coercion/values.rkt")
(provide when/block) (provide when/block)
@ -13,4 +12,7 @@
(define-syntax (when/block stx) (define-syntax (when/block stx)
(syntax-case stx () (syntax-case stx ()
[(_ condition body ...) [(_ 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 ...))))
"")]))

27
string.rkt
Unescape Escape View File

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

17
tests.rkt
Unescape Escape View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require rackunit net/url racket/set) (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 "foo") "foo")
(check-equal? (->string '()) "") (check-equal? (->string '()) "")
(check-equal? (->string 'foo) "foo") (check-equal? (->string 'foo) "foo")
(check-equal? (->string 123) "123") (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") (define file-name-as-text "foo.txt")
(check-equal? (->string (string->path file-name-as-text)) file-name-as-text) (check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
(check-equal? (->string #\¶) "") (check-equal? (->string #\¶) "")
@ -92,3 +92,16 @@
(check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8)) (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* '("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* '(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)))

26
tree.rkt
Unescape Escape View File

@ -1,51 +1,31 @@
#lang racket/base #lang racket/base
(require racket/list racket/contract) (require "define/contract.rkt")
(require "define.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
;; apply filter proc recursively
(define+provide/contract (filter-tree proc tree) (define+provide/contract (filter-tree proc tree)
(procedure? list? . -> . list?) (procedure? list? . -> . list?)
(define (remove-empty x) (define (remove-empty x)
(cond (cond
[(list? x) (filter-not empty? (map remove-empty x))] [(list? x) (filter (compose1 not null?) (map remove-empty x))]
[else x])) [else x]))
(define (filter-tree-inner proc x) (define (filter-tree-inner proc x)
(cond (cond
[(list? x) (map (λ(i) (filter-tree-inner proc i)) x)] [(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))) (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) (define+provide/contract (filter-not-tree proc tree)
(procedure? list? . -> . list?) (procedure? list? . -> . list?)
(filter-tree (λ(i) (not (proc i))) tree)) (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) (define+provide/contract (map-tree proc tree)
(procedure? list? . -> . list?) (procedure? list? . -> . list?)
(cond (cond
[(list? tree) (map (λ(i) (map-tree proc i)) tree)] [(list? tree) (map (λ(i) (map-tree proc i)) tree)]
[else (proc 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))))
Write Preview
Loading…
Cancel
Save