diff --git a/main-helper.rkt b/main-helper.rkt index c72c9be..a0a658b 100644 --- a/main-helper.rkt +++ b/main-helper.rkt @@ -4,6 +4,8 @@ (require (planet mb/pollen/tools) (planet mb/pollen/world)) +(module+ test (require rackunit)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Look for a EXTRAS_DIR directory local to the source file. @@ -65,6 +67,9 @@ (match-let-values ([(_ here-name _) (split-path ccr)]) (path->string (remove-all-ext here-name))))))) +(module+ test + (check-equal? (get-here) "test-main-helper")) + ; then, apply a separate syntax transform to the identifier itself ; can't do this in one step, because if the macro goes from identifier to function definition, ; macro processor will evaluate the body at compile-time, not runtime. @@ -82,14 +87,11 @@ (set! meta-list (cons x meta-list)) empty)] [(named-xexpr? x) ; handle named-xexpr - (let-values([(name attr body) (xexplode x)]) - (make-xexpr name attr (&split-metas body)))] + (let-values([(name attr body) (break-named-xexpr x)]) + (make-named-xexpr name attr (&split-metas body)))] [(list? x) (map &split-metas x)] [else x])) (values (remove-empty (&split-metas body)) (reverse meta-list))) (provide (all-defined-out)) -(module+ test - (require rackunit) - (check-equal? (get-here) "test-main-helper")) \ No newline at end of file diff --git a/readability.rkt b/readability.rkt index 3ca8a47..d4db42f 100644 --- a/readability.rkt +++ b/readability.rkt @@ -2,6 +2,7 @@ (require racket/contract) (require (only-in racket/list empty?)) (require (only-in racket/format ~a)) +(module+ test (require rackunit)) (provide (all-defined-out)) @@ -16,13 +17,49 @@ [(char? x) (~a x)] [else (error (format "Can't make ~a into string" x))])) - (module+ test - (require rackunit) (check-equal? (as-string '()) "") (check-equal? (as-string 'foo) "foo") (check-equal? (as-string 123) "123") (define file-name-as-text "foo.txt") (check-equal? (as-string (string->path file-name-as-text)) file-name-as-text) - (check-equal? (as-string #\¶) "¶") + (check-equal? (as-string #\¶) "¶")) + + +;; general way of coercing to a list +(define (as-list x) + (any/c . -> . list?) + (cond + [(list? x) x] + [(vector? x) (vector->list x)] + [else (list x)])) + +(module+ test + (check-equal? (as-list '(1 2 3)) '(1 2 3)) + (check-equal? (as-list (list->vector '(1 2 3))) '(1 2 3)) + (check-equal? (as-list "foo") (list "foo"))) + +;; general way of asking for length +(define (len x) + (any/c . -> . integer?) + (cond + [(list? x) (length x)] + [(string? x) (string-length x)] + [(symbol? x) (len (as-string x))] + [(vector? x) (vector-length x)] + [(hash? x) (len (hash-keys x))] + [else #f])) + +(module+ test + (check-equal? (len '(1 2 3)) 3) + (check-not-equal? (len '(1 2)) 3) ; len 2 + (check-equal? (len "foo") 3) + (check-not-equal? (len "fo") 3) ; len 2 + (check-equal? (len 'foo) 3) + (check-not-equal? (len 'fo) 3) ; len 2 + (check-equal? (len (list->vector '(1 2 3))) 3) + (check-not-equal? (len (list->vector '(1 2))) 3) ; len 2 + (check-equal? (len (make-hash '((a 1) (b 2) (c 3)))) 3) + (check-not-equal? (len (make-hash '((a 1) (b 2) (b 3)))) 3) ; len 2 + ) \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index 4e1e1e1..0bb883e 100644 --- a/tools.rkt +++ b/tools.rkt @@ -3,6 +3,7 @@ (require racket/contract racket/match) (require (only-in racket/path filename-extension)) (require (only-in racket/format ~a)) +(require (only-in racket/list empty empty? second filter-not)) (require (only-in xml xexpr?)) (provide (all-defined-out)) @@ -109,3 +110,74 @@ (check-false (named-xexpr? '(p "foo" "bar" ((key "value"))))) ; malformed (check-false (named-xexpr? '("p" "foo" "bar"))) ; no name (check-false (named-xexpr? '(p 123)))) ; content is a number + +;; helper for comparison of values +;; normal function won't work for this. Has to be syntax-rule +(define-syntax-rule (values->list vs) + (call-with-values (λ() vs) list)) + + +;; create named-xexpr from parts (opposite of break-named-xexpr) +(define/contract (make-named-xexpr name [attr empty] [content empty]) + ((symbol?) (xexpr-attr? xexpr-content?) . ->* . named-xexpr?) + (filter-not empty? `(,name ,attr ,@content))) + +(module+ test + (check-equal? (make-named-xexpr 'p) '(p)) + (check-equal? (make-named-xexpr 'p '((key "value"))) '(p ((key "value")))) + (check-equal? (make-named-xexpr 'p empty '("foo" "bar")) '(p "foo" "bar")) + (check-equal? (make-named-xexpr 'p '((key "value")) (list "foo" "bar")) + '(p ((key "value")) "foo" "bar"))) + + +;; decompose named-xexpr into parts (opposite of make-named-xexpr) +(define/contract (break-named-xexpr nx) + (named-xexpr? . -> . (values symbol? xexpr-attr? xexpr-content?)) + (match + ; named-xexpr may or may not have attr + ; if not, add empty attr so that decomposition only handles one case + (match nx + [(list _ (? xexpr-attr?) _ ...) nx] + [else `(,(car nx) ,empty ,@(cdr nx))]) + [(list name attr content ...) (values name attr content)])) + +(module+ test + (check-equal? (values->list (break-named-xexpr '(p))) + (values->list (values 'p empty empty))) + (check-equal? (values->list (break-named-xexpr '(p "foo"))) + (values->list (values 'p empty '("foo")))) + (check-equal? (values->list (break-named-xexpr '(p ((key "value"))))) + (values->list (values 'p '((key "value")) empty))) + (check-equal? (values->list (break-named-xexpr '(p ((key "value")) "foo"))) + (values->list (values 'p '((key "value")) '("foo"))))) + + +;; apply filter proc recursively +(define/contract (filter-tree proc tree) + (procedure? list? . -> . list?) + (define (remove-empty x) + (cond + [(list? x) (map remove-empty (filter-not empty? x))] + [else x])) + + (define (filter-tree-inner proc tree) + (cond + [(list? tree) (map (λ(item) (filter-tree-inner proc item)) tree)] + [else (if (proc tree) tree 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")))) + +;; apply filter-not proc recursively +(define/contract (filter-not-tree proc tree) + (procedure? list? . -> . list?) + (filter-tree (λ(item) (not (proc item))) 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))))