From 179425c600631300406734be09758253cc88951f Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 15 Aug 2013 16:15:14 -0700 Subject: [PATCH] hmm --- decode.rkt | 4 +- main.rkt | 9 ++-- map.rkt | 31 +++++++------ readability.rkt | 86 +++++++++++++++++++---------------- tests/requires/include-me.rkt | 13 +++--- tests/test-foo.p | 7 +++ tests/test-pmap.p | 26 +++++++++++ tools.rkt | 32 ++++++++++--- 8 files changed, 134 insertions(+), 74 deletions(-) create mode 100644 tests/test-foo.p create mode 100644 tests/test-pmap.p diff --git a/decode.rkt b/decode.rkt index ec51594..337801d 100644 --- a/decode.rkt +++ b/decode.rkt @@ -71,7 +71,7 @@ ;; tags are inline unless they're registered as block tags. (define/contract (block-xexpr? x) (any/c . -> . boolean?) - ((tagged-xexpr? x) . and . (->boolean ((tagged-xexpr-tag x) . in . block-tags)))) + ((tagged-xexpr? x) . and . (->boolean ((tagged-xexpr-tag x) . in? . block-tags)))) (module+ test (check-true (block-xexpr? '(p "foo"))) @@ -180,7 +180,7 @@ (define (&decode x) (cond [(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)]) - (if (tag . in . (->list excluded-xexpr-tags)) + (if (tag . in? . (->list excluded-xexpr-tags)) x (let ([decoded-xexpr (apply make-tagged-xexpr (map &decode (list tag attr elements)))]) diff --git a/main.rkt b/main.rkt index 7913140..de298f0 100644 --- a/main.rkt +++ b/main.rkt @@ -1,8 +1,6 @@ #lang racket/base (require racket/match) -(require (planet mb/pollen/tools) - (planet mb/pollen/main-helper)) - +(require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [module-begin #%module-begin])) @@ -25,8 +23,7 @@ (module pollen-inner (planet mb/pollen/doclang2_raw) ; use same requires as top of main.rkt ; (can't import them from surrounding module due to submodule rules) - (require (planet mb/pollen/tools) - (planet mb/pollen/main-helper)) + (require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (require-extras #:provide #t) ; brings in the project require files ; #%top binding catches ids that aren't defined @@ -65,6 +62,6 @@ (rename-out (inner-here here))) ; change identifier back (now safe from macrofication) (module+ main - (print main) + main (displayln "") (displayln (format "tagged-xexpr? ~a" (tagged-xexpr? main)))))) diff --git a/map.rkt b/map.rkt index 25942ee..359a426 100644 --- a/map.rkt +++ b/map.rkt @@ -1,18 +1,22 @@ #lang racket/base -(require xml xml/path racket/list racket/string racket/contract racket/match) -;; todo: why is this require here? -(require (except-in web-server/templates in)) -(require "tools.rkt" "world.rkt") +(require xml xml/path racket/list racket/string racket/contract racket/match racket/set) +(require "tools.rkt" "world.rkt" "decode.rkt") + +(require "tests/test.pmap") +;(require "tests/pollen-lang-test.p") (module+ test (require rackunit)) (module+ test - (define tt (main->tree (dynamic-require "tests/test.pmap" POLLEN_ROOT)))) + main +; (define tt (main->tree (dynamic-require "tests/test.pmap" POLLEN_ROOT)))) + ) ; get the values out of the file, or make them up (define map-file (build-path START_DIR DEFAULT_MAP)) (define map-main empty) + ;; todo: this ain't a function (if (file-exists? map-file) ; load it, or ... @@ -26,7 +30,9 @@ ;; all names must be unique (define/contract (map-tree? x) (any/c . -> . boolean?) - (tagged-xexpr? x)) + (and (tagged-xexpr? x) + (let ([locations (map ->string (flatten (filter-not-tree whitespace? (remove-attrs x))))]) + (= (len (apply set locations)) (len locations))))) ;; recursively processes tree, converting map locations & their parents into xexprs of this shape: ;; '(location ((parent "parent"))) @@ -51,13 +57,9 @@ ;; remove parents from tree (i.e., just remove attrs) ;; is not the inverse of add-parents, i.e., you do not get back your original input. -(define/contract (remove-parents x) - (map-tree? . -> . tagged-xexpr?) - (match x - [(? tagged-xexpr?) (let-values ([(tag attr elements) (break-tagged-xexpr x)]) - (make-tagged-xexpr tag empty (remove-parents elements)))] - [(? list?) (map remove-parents x)] - [else x])) +(define/contract (remove-parents mt) + (map-tree? . -> . map-tree?) + (remove-attrs mt)) (module+ test (check-equal? (remove-parents @@ -243,5 +245,4 @@ (check-equal? (next-page 'one test-tree) "two") (check-false (next-page 'three test-tree))) -;; todo: why is this re-exporting web-server/templates? -(provide (all-defined-out) (all-from-out web-server/templates)) \ No newline at end of file +(provide (all-defined-out)) \ No newline at end of file diff --git a/readability.rkt b/readability.rkt index c53d6d8..050a4d0 100644 --- a/readability.rkt +++ b/readability.rkt @@ -4,6 +4,7 @@ (require (only-in racket/format ~a)) (require (only-in racket/string string-join)) (require (only-in racket/vector vector-member)) +(require (only-in racket/set set set->list set?)) (module+ test (require rackunit)) (require "debug.rkt") @@ -38,21 +39,23 @@ ;; general way of coercing to a list -(define (->list x) +(define/contract (->list x) (any/c . -> . list?) (cond [(list? x) x] [(vector? x) (vector->list x)] + [(set? x) (set->list x)] [else (list x)])) (module+ test (check-equal? (->list '(1 2 3)) '(1 2 3)) (check-equal? (->list (list->vector '(1 2 3))) '(1 2 3)) + (check-equal? (->list (set 1 2 3)) '(1 2 3)) (check-equal? (->list "foo") (list "foo"))) ;; general way of coercing to boolean -(define (->boolean x) +(define/contract (->boolean x) (any/c . -> . boolean?) ;; in Racket, everything but #f is true (if x #t #f)) @@ -66,16 +69,20 @@ (check-true (->boolean '(1 2 3)))) +(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 (len x) - (any/c . -> . integer?) +(define/contract (len x) + (has-length? . -> . integer?) (cond [(list? x) (length x)] [(string? x) (string-length x)] [(symbol? x) (len (->string x))] - [(vector? x) (vector-length x)] + [(vector? x) (len (->list x))] [(hash? x) (len (hash-keys x))] + [(set? x) (len (->list x))] [else #f])) (module+ test @@ -87,18 +94,26 @@ (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 (set 1 2 3)) 3) + (check-not-equal? (len (set 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)))) 3)) ; len 2 +(define/contract (sliceable-container? x) + (any/c . -> . boolean?) + (ormap (λ(proc) (proc x)) (list list? string? symbol? vector?))) + +(define/contract (container? x) + (any/c . -> . boolean?) + (ormap (λ(proc) (proc x)) (list sliceable-container? hash?))) + + ;; general way of fetching an item from a container (define/contract (get container start [end #f]) - ((any/c any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) - . ->* . any/c) - - (define (sliceable-container? container) - (ormap (λ(proc) (proc container)) (list list? string? vector?))) + ((container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) + . ->* . any/c) (set! end (if (sliceable-container? container) @@ -121,8 +136,7 @@ [(string? container) (substring container start end)] [(symbol? container) (->symbol (get (->string container) start end))] ;; for hash, just get item - [(hash? container) (let ([hash-key start]) - (hash-ref container hash-key))] + [(hash? container) (hash-ref container start)] [else #f])) ;; don't return single-item results inside a list @@ -152,32 +166,26 @@ ;; 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 . -> . any/c) - (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) (let ([result ((->string item) . in . (map ->string (string->list container)))]) - (if result - (string-join result "") - #f))] ; returns #f or substring beginning with item - [(symbol? container) (let ([result ((->string item) . in . (->string container))]) - (if result - (->symbol result) - result))] ; returns #f or subsymbol (?!) beginning with item - [else #f])) +(define/contract (in? item container) + (any/c any/c . -> . boolean?) + (->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) ((->string item) . in? . (map ->string (string->list container)))] ; returns #f or substring beginning with item + [(symbol? container) ((->string item) . in? . (->string container))] ; returns #f or subsymbol (?!) beginning with item + [else #f]))) (module+ test - (check-equal? (2 . in . '(1 2 3)) '(2 3)) - (check-false (4 . in . '(1 2 3))) - (check-equal? (2 . in . (list->vector '(1 2 3))) 1) - (check-false (4 . in . (list->vector '(1 2 3)))) - (check-equal? ('a . in . (make-hash '((a . 1) (b . 2) (c . 3)))) 1) - (check-false ('x . in . (make-hash '((a . 1) (b . 2) (c . 3))))) - (check-equal? ("o" . in . "foobar") "oobar") - (check-false ("z" . in . "foobar")) - (check-equal? ('o . in . 'foobar) 'oobar) - (check-false ('z . in . 'foobar)) - (check-false ("F" . in . #\F))) \ No newline at end of file + (check-true (2 . in? . '(1 2 3))) + (check-false (4 . in? . '(1 2 3))) + (check-true (2 . in? . (list->vector '(1 2 3)))) + (check-false (4 . in? . (list->vector '(1 2 3)))) + (check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) + (check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) + (check-true ("o" . in? . "foobar")) + (check-false ("z" . in? . "foobar")) + (check-true ('o . in? . 'foobar)) + (check-false ('z . in? . 'foobar)) + (check-false ("F" . in? . #\F))) \ No newline at end of file diff --git a/tests/requires/include-me.rkt b/tests/requires/include-me.rkt index 3944c27..df9c9bb 100644 --- a/tests/requires/include-me.rkt +++ b/tests/requires/include-me.rkt @@ -12,6 +12,7 @@ (register-block-tag 'fooble) + ;; handle meta tags (define/contract (meta-proc meta) (meta-xexpr? . -> . tagged-xexpr?) @@ -104,7 +105,7 @@ (define tags-to-pay-attention-to '(p aside)) ; only apply to paragraphs (define (replace-last-space str) - (if (#\space . in . str) + (if (#\space . in? . str) (let ([reversed-str-list (reverse (string->list str))] [reversed-nbsp (reverse (string->list nbsp))]) (define-values (last-word-chars other-chars) @@ -128,7 +129,7 @@ x))] [else x])) - (if ((car x) . in . tags-to-pay-attention-to) + (if ((car x) . in? . tags-to-pay-attention-to) (find-last-word-space x) x)) @@ -157,11 +158,11 @@ (define str-first (get tcs 0)) (define str-rest (get tcs 1 'end)) (cond - [(str-first . in . '("\"" "“")) + [(str-first . in? . '("\"" "“")) ;; can wrap with any inline tag ;; so that linebreak detection etc still works `(,@double-pp ,(->string #\“) ,str-rest)] - [(str-first . in . '("\'" "‘")) + [(str-first . in? . '("\'" "‘")) `(,@single-pp ,(->string #\‘) ,str-rest)] [else tcs])] [(? tagged-xexpr? nx) (wrap-hanging-quotes nx)] @@ -224,8 +225,8 @@ (typogrify str)) -(define (root . items) - (tagged-xexpr? . -> . tagged-xexpr?) +(define/contract (root . items) + (() #:rest (listof xexpr-element?) . ->* . tagged-xexpr?) (decode (cons 'root items) ; #:exclude-xexpr-tags 'em ; #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)] diff --git a/tests/test-foo.p b/tests/test-foo.p new file mode 100644 index 0000000..9c93f1a --- /dev/null +++ b/tests/test-foo.p @@ -0,0 +1,7 @@ +#lang racket/base + +;(require "test.pmap") +(require "test-pmap.p") +;(require "pollen-lang-test.p") + +main \ No newline at end of file diff --git a/tests/test-pmap.p b/tests/test-pmap.p new file mode 100644 index 0000000..25aad1e --- /dev/null +++ b/tests/test-pmap.p @@ -0,0 +1,26 @@ +#lang planet mb/pollen + +◊map-topic{index + typography-in-ten-minutes + summary-of-key-rules + foreword + introduction + how-to-use + how-to-pay-for-this-book + ◊map-topic{why-typography-matters + what-is-typography + where-do-the-rules-come-from} + ◊map-topic{type-composition + straight-and-curly-quotes + one-space-between-sentences + trademark-and-copyright-symbols + ligatures} + ◊map-topic{appendix + printers-and-paper + how-to-make-a-pdf + typewriter-habits + common-accented-characters + identifying-fonts + bibliography + charter + mb-lectures-and-articles}} \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index 8a4b9a6..8c0ca59 100644 --- a/tools.rkt +++ b/tools.rkt @@ -30,7 +30,7 @@ ; make these independent of local includes (define (map-topic topic . subtopics) - `(,(string->symbol topic) ,@(filter-not whitespace? subtopics))) + (make-tagged-xexpr (->symbol topic) empty (filter-not whitespace? subtopics))) ;; does path have a certain extension @@ -95,12 +95,17 @@ ;; is it xexpr content? +(define/contract (xexpr-element? x) + (any/c . -> . boolean?) + (or (string? x) (tagged-xexpr? x))) + + (define/contract (xexpr-elements? x) (any/c . -> . boolean?) (match x ;; this is more strict than xexpr definition in xml module ;; don't allow symbols or numbers to be part of content - [(list elem ...) (andmap (λ(i) (or (string? i) (tagged-xexpr? i))) elem)] + [(list elem ...) (andmap xexpr-element? elem)] [else #f])) (module+ test @@ -158,16 +163,17 @@ ;; use flatten to splice xexpr-attrs into list ;; use hash to ensure keys are unique (later values will overwrite earlier) (define attr-hash (apply hash (make-attr-list (flatten items)))) - `(,@(map (λ(k v) (list k v)) (hash-keys attr-hash) (hash-values attr-hash)))) + `(,@(map (λ(k) (list k (get attr-hash k))) + ;; sort needed for predictable results for unit tests + (sort (hash-keys attr-hash) (λ(a b) (stringstring a) (->string b))))))) (module+ test (check-equal? (make-xexpr-attr 'foo "bar") '((foo "bar"))) (check-equal? (make-xexpr-attr "foo" 'bar) '((foo "bar"))) (check-equal? (make-xexpr-attr "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar"))) - (check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "hee" "haw") + (check-equal? (make-xexpr-attr (make-xexpr-attr "foo" "bar" "goo" "gar") "hee" "haw") '((foo "bar")(goo "gar")(hee "haw"))) - (check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar"))) -) + (check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar")))) ;; create tagged-xexpr from parts (opposite of break-tagged-xexpr) @@ -228,6 +234,20 @@ '("foo" "bar" (em "square")))) +;; remove all attr blocks (helper function) +(define/contract (remove-attrs x) + (tagged-xexpr? . -> . tagged-xexpr?) + (match x + [(? tagged-xexpr?) (let-values ([(tag attr elements) (break-tagged-xexpr x)]) + (make-tagged-xexpr tag empty (remove-attrs elements)))] + [(? list?) (map remove-attrs x)] + [else x])) + +(module+ test + (check-equal? (remove-attrs '(p ((foo "bar")) "hi")) '(p "hi")) + (check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "hi" (p "hi")))) + + ;; apply filter proc recursively (define/contract (filter-tree proc tree) (procedure? list? . -> . list?)