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

refactor & relocate unit tests

Browse Source
pull/58/head
Matthew Butterick 9 years ago
parent d07db3750c
commit f048dabc37
20 changed files with 268 additions and 281 deletions
Show Stats Download Patch File Download Diff File

83
decode.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require xml txexpr sugar racket/match racket/list (prefix-in html: pollen/html)) (require xml txexpr sugar racket/match racket/list (prefix-in html: pollen/html) sugar/test)
(require "debug.rkt" "world.rkt") (require "debug.rkt" "world.rkt")
@ -132,6 +132,9 @@
(txexpr-tag? . -> . void?) (txexpr-tag? . -> . void?)
(project-block-tags (cons tag (project-block-tags)))) (project-block-tags (cons tag (project-block-tags))))
(module-test-external
(check-true (begin (register-block-tag 'barfoo) (block-txexpr? '(barfoo "foo")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -149,16 +152,19 @@
(define+provide/contract (smart-dashes str) (define+provide/contract (smart-dashes str)
(string? . -> . string?) (string? . -> . string?)
(define dashes (define dashes
;; fix em dashes first, else they'll be mistaken for en dashes ;; fix em dashes first, else they'll be mistaken for en dashes
;; \\s is whitespace + #\u00A0 is nonbreaking space ;; \\s is whitespace + #\u00A0 is nonbreaking space
'((#px"[\\s#\u00A0]*(---|—)[\\s#\u00A0]*" "—") ; em dash '((#px"[\\s#\u00A0]*(---|—)[\\s#\u00A0]*" "—") ; em dash
(#px"[\\s#\u00A0]*(--|–)[\\s#\u00A0]*" "–"))) ; en dash (#px"[\\s#\u00A0]*(--|–)[\\s#\u00A0]*" "–"))) ; en dash
((make-replacer dashes) str)) ((make-replacer dashes) str))
(module-test-external
(check-equal? (smart-dashes "I had --- maybe 13 -- 20 --- hob-nobs.") "I had—maybe 13–20—hob-nobs.")
(check-equal? (smart-quotes "\"Why,\" she could've asked, \"are we in O‘ahu watching 'Mame'?\"")
"“Why,” she could’ve asked, “are we in O‘ahu watching ‘Mame’?”")
(check-equal? (smart-quotes "\"\'Impossible.\' Yes.\"") "“‘Impossible.’ Yes.”"))
(define+provide/contract (smart-quotes str) (define+provide/contract (smart-quotes str)
(string? . -> . string?) (string? . -> . string?)
@ -215,6 +221,14 @@
(find-last-word-space x) (find-last-word-space x)
x)) x))
(module-test-external
;; todo: make some tougher tests, it gets flaky with edge cases
(check-equal? (nonbreaking-last-space '(p "Hi there")) '(p "Hi " "there")) ; nbsp in between last two words
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "Ø") '(p "HiØ" "there")) ; but let's make it visible
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "_up_") '(p "Hi_up_" "there"))
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "_up_" #:minimum-word-length 3)
'(p "Hi " "there"))
(check-equal? (nonbreaking-last-space '(p "Hi here" (em "ho there")) #:nbsp "Ø") '(p "Hi here" (em "hoØ" "there"))))
; wrap initial quotes for hanging punctuation ; wrap initial quotes for hanging punctuation
; todo: improve this ; todo: improve this
@ -245,7 +259,14 @@
(cons new-car-elements (cdr elements))) (cons new-car-elements (cdr elements)))
elements))) elements)))
(module-test-external
(check-equal? (wrap-hanging-quotes '(p "\"Hi\" there")) '(p (dquo "“" "Hi\" there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "‘" "Hi' there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino"))))
'(p (foo ((bar "ino")) "‘" "Hi' there")))
;; make sure txexpr without elements passes through unscathed
(check-equal? (wrap-hanging-quotes '(div ((style "height:2em")))) '(div ((style "height:2em")))))
@ -278,6 +299,14 @@
[else empty])] ; otherwise delete [else empty])] ; otherwise delete
[else item]))))) [else item])))))
(module-test-external
(check-equal? (detect-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar"))
(check-equal? (detect-linebreaks '("\n" "foo" "\n" "bar" "\n")) '("\n" "foo" (br) "bar" "\n"))
(check-equal? (detect-linebreaks '((p "foo") "\n" (p "bar"))) '((p "foo") (p "bar")))
(check-equal? (detect-linebreaks '("foo" "\n" (p "bar"))) '("foo" (p "bar")))
(check-equal? (detect-linebreaks '("foo" "moo" "bar")) '("foo" "moo" "bar"))
(check-equal? (detect-linebreaks '("foo" "moo" "bar") #:insert "moo") '("foo" "moo" "bar"))
(check-equal? (detect-linebreaks '("foo" "\n\n" "bar")) '("foo" "\n\n" "bar")))
(define+provide/contract (whitespace? x [nbsp? #f]) (define+provide/contract (whitespace? x [nbsp? #f])
@ -289,6 +318,16 @@
[(or (list? x) (vector? x)) (and (not (empty? x)) (andmap (λ(i) (whitespace? i nbsp?)) (->list x)))] ; andmap returns #t for empty lists [(or (list? x) (vector? x)) (and (not (empty? x)) (andmap (λ(i) (whitespace? i nbsp?)) (->list x)))] ; andmap returns #t for empty lists
[else #f])) [else #f]))
(module-test-external
(require racket/format)
(check-true (whitespace? " "))
(check-false (whitespace? (~a #\u00A0)))
(check-true (whitespace/nbsp? (~a #\u00A0)))
(check-true (whitespace/nbsp? (vector (~a #\u00A0))))
(check-false (whitespace? (format " ~a " #\u00A0)))
(check-true (whitespace/nbsp? (format " ~a " #\u00A0))))
(define+provide/contract (whitespace/nbsp? x) (define+provide/contract (whitespace/nbsp? x)
(any/c . -> . coerce/boolean?) (any/c . -> . coerce/boolean?)
(whitespace? x #t)) (whitespace? x #t))
@ -331,7 +370,9 @@
[(list? x) (do-merge (map merge-newlines x))] [(list? x) (do-merge (map merge-newlines x))]
[else x])) [else x]))
(module-test-external
(check-equal? (merge-newlines '(p "\n" "foo" "\n" "\n" "bar" (em "\n" "\n" "\n")))
'(p "\n" "foo" "\n\n" "bar" (em "\n\n\n"))))
@ -363,3 +404,33 @@
(if force-paragraph (if force-paragraph
(append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs (append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs
elements)))) elements))))
(module-test-external
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para"))
'((p "First para") (p "Second para")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line"))
'((p "First para") (p "Second para" (br) "Second line")))
(check-equal? (detect-paragraphs '("First para" "\n\n" (div "Second block")))
'((p "First para") (div "Second block")))
(check-equal? (detect-paragraphs '((div "First block") "\n\n" (div "Second block")))
'((div "First block") (div "Second block")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para") #:tag 'ns:p)
'((ns:p "First para") (ns:p "Second para")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line")
#:linebreak-proc (λ(x) (detect-linebreaks x #:insert '(newline))))
'((p "First para") (p "Second para" (newline) "Second line")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar") (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar") "\n\n" (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (detect-paragraphs '("foo")) '("foo"))
(check-equal? (detect-paragraphs '("foo") #:force? #t) '((p "foo")))
(check-equal? (detect-paragraphs '((div "foo"))) '((div "foo")))
(check-equal? (detect-paragraphs '((div "foo")) #:force? #t) '((div "foo")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar")) #:force? #t) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar") "zam")) '((p "foo") (div "bar") (p "zam")))
(check-equal? (detect-paragraphs '("foo" (span "zing") (div "bar") "zam")) '((p "foo" (span "zing")) (div "bar") (p "zam")))
(check-equal? (detect-paragraphs '("foo" (span "zing") (div "bar") "zam") #:force? #t) '((p "foo" (span "zing")) (div "bar") (p "zam"))))

53
file.rkt
Unescape Escape View File

@ -2,7 +2,7 @@
(require (for-syntax racket/base racket/syntax)) (require (for-syntax racket/base racket/syntax))
(require racket/contract racket/path) (require racket/contract racket/path)
(require (only-in racket/path filename-extension)) (require (only-in racket/path filename-extension))
(require "world.rkt" sugar) (require "world.rkt" sugar/define sugar/file sugar/string sugar/coerce sugar/test)
;; for files like svg that are not source in pollen terms, ;; for files like svg that are not source in pollen terms,
;; but have a textual representation separate from their display. ;; but have a textual representation separate from their display.
@ -10,7 +10,11 @@
(any/c . -> . coerce/boolean?) (any/c . -> . coerce/boolean?)
(define sourceish-extensions (list "svg")) (define sourceish-extensions (list "svg"))
(with-handlers ([exn:fail? (λ(e) #f)]) (with-handlers ([exn:fail? (λ(e) #f)])
((get-ext x) . in? . sourceish-extensions))) (member (get-ext x) sourceish-extensions)))
(module-test-external
(check-true (sourceish? "foo.svg"))
(check-false (sourceish? "foo.gif")))
;; compare directories by their exploded path elements, ;; compare directories by their exploded path elements,
@ -19,6 +23,9 @@
(coerce/path? coerce/path? . -> . coerce/boolean?) (coerce/path? coerce/path? . -> . coerce/boolean?)
(equal? (explode-path dirx) (explode-path diry))) (equal? (explode-path dirx) (explode-path diry)))
(module-test-external
(check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/"))
(check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo")))
;; helper function for pagetree ;; helper function for pagetree
@ -88,11 +95,45 @@
(make-source-utility-functions preproc) (make-source-utility-functions preproc)
(module-test-external
(require sugar/coerce)
(check-true (preproc-source? "foo.pp"))
(check-false (preproc-source? "foo.bar"))
(check-false (preproc-source? #f))
(check-equal? (->preproc-source-path (->path "foo.pp")) (->path "foo.pp"))
(check-equal? (->preproc-source-path (->path "foo.html")) (->path "foo.html.pp"))
(check-equal? (->preproc-source-path "foo") (->path "foo.pp"))
(check-equal? (->preproc-source-path 'foo) (->path "foo.pp")))
(make-source-utility-functions null) (make-source-utility-functions null)
(make-source-utility-functions pagetree) (make-source-utility-functions pagetree)
(module-test-external
(require pollen/world)
(check-true (pagetree-source? (format "foo.~a" world:pagetree-source-ext)))
(check-false (pagetree-source? (format "~a.foo" world:pagetree-source-ext)))
(check-false (pagetree-source? #f)))
(make-source-utility-functions markup) (make-source-utility-functions markup)
(module-test-external
(require sugar/coerce)
(check-true (markup-source? "foo.pm"))
(check-false (markup-source? "foo.p"))
(check-false (markup-source? #f))
(check-equal? (->markup-source-path (->path "foo.pm")) (->path "foo.pm"))
(check-equal? (->markup-source-path (->path "foo.html")) (->path "foo.html.pm"))
(check-equal? (->markup-source-path "foo") (->path "foo.pm"))
(check-equal? (->markup-source-path 'foo) (->path "foo.pm")))
(make-source-utility-functions markdown) (make-source-utility-functions markdown)
(make-source-utility-functions template) (make-source-utility-functions template)
(module-test-external
(check-true (template-source? "foo.html.pt"))
(check-false (template-source? "foo.html"))
(check-false (template-source? #f)))
(make-source-utility-functions scribble) (make-source-utility-functions scribble)
@ -108,6 +149,14 @@
[(scribble-source? x) (add-ext (remove-ext x) 'html)] [(scribble-source? x) (add-ext (remove-ext x) 'html)]
[else x])) [else x]))
(module-test-external
(require sugar/coerce)
(check-equal? (->output-path (->path "foo.pmap")) (->path "foo.pmap"))
(check-equal? (->output-path "foo.html") (->path "foo.html"))
(check-equal? (->output-path 'foo.html.p) (->path "foo.html"))
(check-equal? (->output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html"))
(check-equal? (->output-path "foo.xml.p") (->path "foo.xml"))
(check-equal? (->output-path 'foo.barml.p) (->path "foo.barml")))
(define+provide/contract (project-files-with-ext ext) (define+provide/contract (project-files-with-ext ext)
(coerce/symbol? . -> . complete-paths?) (coerce/symbol? . -> . complete-paths?)

1
info.rkt
Unescape Escape View File

@ -7,3 +7,4 @@
(define scribblings '(("scribblings/pollen.scrbl" (multi-page)))) (define scribblings '(("scribblings/pollen.scrbl" (multi-page))))
(define raco-commands '(("pollen" (submod pollen/raco main) "issue Pollen command" #f))) (define raco-commands '(("pollen" (submod pollen/raco main) "issue Pollen command" #f)))
(define compile-omit-paths '("tests" "raco.rkt")) (define compile-omit-paths '("tests" "raco.rkt"))
(define test-omit-paths '("scribblings" "test-support"))

66
pagetree.rkt
Unescape Escape View File

@ -10,6 +10,17 @@
(->boolean (and (symbol? x) (with-handlers ([exn:fail? (λ(e) #f)]) (->boolean (and (symbol? x) (with-handlers ([exn:fail? (λ(e) #f)])
(not (whitespace/nbsp? (->string x))))))) (not (whitespace/nbsp? (->string x)))))))
(module-test-external
(check-false (pagenode? "foo-bar"))
(check-false (pagenode? "Foo_Bar_0123"))
(check-true (pagenode? 'foo-bar))
(check-false (pagenode? "foo-bar.p"))
(check-false (pagenode? "/Users/MB/foo-bar"))
(check-false (pagenode? #f))
(check-false (pagenode? ""))
(check-false (pagenode? " ")))
(define+provide (pagenodes? x) (define+provide (pagenodes? x)
(and (list? x) (andmap pagenode? x))) (and (list? x) (andmap pagenode? x)))
@ -46,6 +57,12 @@
(with-handlers ([exn:fail? (λ(e) #f)]) (with-handlers ([exn:fail? (λ(e) #f)])
(->boolean (validate-pagetree x)))) (->boolean (validate-pagetree x))))
(module-test-external
(check-true (pagetree? '(foo)))
(check-true (pagetree? '(foo (hee))))
(check-true (pagetree? '(foo (hee (uncle foo)))))
(check-false (pagetree? '(foo (hee hee (uncle foo))))))
(define+provide/contract (directory->pagetree dir) (define+provide/contract (directory->pagetree dir)
(coerce/path? . -> . pagetree?) (coerce/path? . -> . pagetree?)
@ -80,6 +97,14 @@
(ormap (λ(x) (parent pagenode x)) (filter list? pt)))))) (ormap (λ(x) (parent pagenode x)) (filter list? pt))))))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (parent 'three test-pagetree) 'two)
(check-equal? (parent "three" test-pagetree) 'two)
(check-false (parent #f test-pagetree))
(check-false (parent 'nonexistent-name test-pagetree)))
(define+provide/contract (children p [pt (current-pagetree)]) (define+provide/contract (children p [pt (current-pagetree)])
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?)) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?))
(and pt p (and pt p
@ -88,11 +113,27 @@
(map (λ(x) (if (list? x) (car x) x)) (cdr pt)) (map (λ(x) (if (list? x) (car x) x)) (cdr pt))
(ormap (λ(x) (children pagenode x)) (filter list? pt)))))) (ormap (λ(x) (children pagenode x)) (filter list? pt))))))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (children 'one test-pagetree) '(two))
(check-equal? (children 'two test-pagetree) '(three))
(check-false (children 'three test-pagetree))
(check-false (children #f test-pagetree))
(check-false (children 'fooburger test-pagetree)))
(define+provide/contract (siblings pnish [pt (current-pagetree)]) (define+provide/contract (siblings pnish [pt (current-pagetree)])
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?)) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?))
(children (parent pnish pt) pt)) (children (parent pnish pt) pt))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (siblings 'one test-pagetree) '(foo bar one))
(check-equal? (siblings 'foo test-pagetree) '(foo bar one))
(check-equal? (siblings 'two test-pagetree) '(two))
(check-false (siblings #f test-pagetree))
(check-false (siblings 'invalid-key test-pagetree)))
;; flatten tree to sequence ;; flatten tree to sequence
(define+provide/contract (pagetree->list pt) (define+provide/contract (pagetree->list pt)
@ -100,6 +141,10 @@
; use cdr to get rid of root tag at front ; use cdr to get rid of root tag at front
(cdr (flatten pt))) (cdr (flatten pt)))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (pagetree->list test-pagetree) '(foo bar one two three)))
(define (adjacents side pnish [pt (current-pagetree)]) (define (adjacents side pnish [pt (current-pagetree)])
(and pt pnish (and pt pnish
@ -113,6 +158,12 @@
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?)) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?))
(adjacents 'left pnish pt)) (adjacents 'left pnish pt))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (previous* 'one test-pagetree) '(foo bar))
(check-equal? (previous* 'three test-pagetree) '(foo bar one two))
(check-false (previous* 'foo test-pagetree)))
(define+provide/contract (next* pnish [pt (current-pagetree)]) (define+provide/contract (next* pnish [pt (current-pagetree)])
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?)) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?))
@ -124,12 +175,27 @@
(let ([result (previous* pnish pt)]) (let ([result (previous* pnish pt)])
(and result (last result)))) (and result (last result))))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (previous 'one test-pagetree) 'bar)
(check-equal? (previous 'three test-pagetree) 'two)
(check-false (previous 'foo test-pagetree)))
(define+provide/contract (next pnish [pt (current-pagetree)]) (define+provide/contract (next pnish [pt (current-pagetree)])
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?)) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?))
(let ([result (next* pnish pt)]) (let ([result (next* pnish pt)])
(and result (first result)))) (and result (first result))))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (next 'foo test-pagetree) 'bar)
(check-equal? (next 'one test-pagetree) 'two)
(check-false (next 'three test-pagetree)))
(define/contract+provide (path->pagenode path) (define/contract+provide (path->pagenode path)
(coerce/path? . -> . coerce/symbol?) (coerce/path? . -> . coerce/symbol?)

26
render.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/file racket/rerequire racket/path racket/match) (require racket/file racket/rerequire racket/path racket/match)
(require sugar "file.rkt" "cache.rkt" "world.rkt" "debug.rkt" "pagetree.rkt" "project.rkt" "template.rkt") (require sugar/coerce sugar/test sugar/define sugar/container sugar/file sugar/len)
(require "file.rkt" "cache.rkt" "world.rkt" "debug.rkt" "pagetree.rkt" "project.rkt" "template.rkt")
;; when you want to generate everything fresh, ;; when you want to generate everything fresh,
@ -13,6 +14,8 @@
;; and lists of modification times as values. ;; and lists of modification times as values.
(define modification-date-hash #f) (define modification-date-hash #f)
(reset-modification-dates) (reset-modification-dates)
(module-test-internal
(check-pred hash? modification-date-hash))
;; using internal contracts to provide some extra safety (negligible performance hit) ;; using internal contracts to provide some extra safety (negligible performance hit)
@ -29,17 +32,33 @@
(valid-path-args? . -> . valid-path-args?) (valid-path-args? . -> . valid-path-args?)
paths) ; for now, this does nothing; maybe later, it will do more paths) ; for now, this does nothing; maybe later, it will do more
(module-test-internal
(require racket/runtime-path)
(define-runtime-path sample-dir "test-support/samples")
(define samples (parameterize ([current-directory sample-dir])
(map path->complete-path (directory-list "."))))
(define-values (sample-01 sample-02 sample-03) (apply values samples))
(check-equal? (make-mod-dates-key samples) samples))
(define/contract (path->mod-date-value path) (define/contract (path->mod-date-value path)
((or/c #f complete-path?) . -> . (or/c #f integer?)) ((or/c #f complete-path?) . -> . (or/c #f integer?))
(and path (file-exists? path) (file-or-directory-modify-seconds path))) (and path (file-exists? path) (file-or-directory-modify-seconds path)))
(module-test-internal
(check-false (path->mod-date-value (path->complete-path "garbage-path.zzz")))
(check-equal? (path->mod-date-value sample-01) (file-or-directory-modify-seconds sample-01)))
(define/contract (store-render-in-modification-dates . rest-paths) (define/contract (store-render-in-modification-dates . rest-paths)
(() #:rest valid-path-args? . ->* . void?) (() #:rest valid-path-args? . ->* . void?)
(define key (make-mod-dates-key rest-paths)) (define key (make-mod-dates-key rest-paths))
(hash-set! modification-date-hash key (map path->mod-date-value key))) (hash-set! modification-date-hash key (map path->mod-date-value key)))
(module-test-internal
(check-equal? (store-render-in-modification-dates sample-01 sample-02 sample-03) (void))
(check-true (hash-has-key? modification-date-hash (list sample-01 sample-02 sample-03))))
(define/contract (modification-date-expired? . rest-paths) (define/contract (modification-date-expired? . rest-paths)
(() #:rest valid-path-args? . ->* . boolean?) (() #:rest valid-path-args? . ->* . boolean?)
@ -47,6 +66,11 @@
(or (not (key . in? . modification-date-hash)) ; no stored mod date (or (not (key . in? . modification-date-hash)) ; no stored mod date
(not (equal? (map path->mod-date-value key) (get modification-date-hash key))))) ; data has changed (not (equal? (map path->mod-date-value key) (get modification-date-hash key))))) ; data has changed
(module-test-internal
(check-true (modification-date-expired? sample-01)) ; because key hasn't been stored
(check-false (apply modification-date-expired? samples))) ; because files weren't changed
(define (list-of-pathish? x) (and (list? x) (andmap pathish? x))) (define (list-of-pathish? x) (and (list? x) (andmap pathish? x)))
(define/contract+provide (render-batch . xs) (define/contract+provide (render-batch . xs)

46
template.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require racket/string xml xml/path sugar/define sugar/container sugar/coerce) (require racket/string xml xml/path sugar/define sugar/container sugar/coerce sugar/test)
(require "file.rkt" txexpr "world.rkt" "cache.rkt" "pagetree.rkt" "debug.rkt") (require "file.rkt" txexpr "world.rkt" "cache.rkt" "pagetree.rkt" "debug.rkt")
(provide (all-from-out sugar/coerce)) (provide (all-from-out sugar/coerce))
@ -22,7 +22,7 @@
;; otherwise look in metas, then in doc for key ;; otherwise look in metas, then in doc for key
(define (do-doc-result) (define (do-doc-result)
(define doc-result (select-from-doc key value-source)) (define doc-result (select-from-doc key value-source))
(and doc-result (car doc-result))) (and doc-result (car doc-result)))
(cond (cond
[(or (hash? value-source) (equal? value-source world:meta-pollen-export)) (select-from-metas key value-source)] [(or (hash? value-source) (equal? value-source world:meta-pollen-export)) (select-from-metas key value-source)]
[(equal? value-source world:main-pollen-export) (do-doc-result)] [(equal? value-source world:main-pollen-export) (do-doc-result)]
@ -30,6 +30,18 @@
(define metas-result (and (not (txexpr? value-source)) (select-from-metas key value-source))) (define metas-result (and (not (txexpr? value-source)) (select-from-metas key value-source)))
(or metas-result (do-doc-result))])) (or metas-result (do-doc-result))]))
(module-test-external
(check-equal? (select 'key '#hash((key . "value"))) "value")
(check-false (select 'absent-key '#hash((key . "value"))))
(check-equal? (select 'key '(root (key "value"))) "value")
(check-false (select 'absent-key '(root (key "value"))))
(let ([metas '#hash((key . "value"))])
(check-equal? (select 'key metas) "value")
(check-false (select 'absent-key metas)))
(let ([doc '(root (key "value"))])
(check-equal? (select 'key doc) "value")
(check-false (select 'absent-key doc))))
(define+provide/contract (select* key value-source) (define+provide/contract (select* key value-source)
(coerce/symbol? (or/c hash? txexpr? pagenode? pathish?) . -> . (or/c #f txexpr-elements?)) (coerce/symbol? (or/c hash? txexpr? pagenode? pathish?) . -> . (or/c #f txexpr-elements?))
@ -46,6 +58,11 @@
[else (get-metas metas-source)])) [else (get-metas metas-source)]))
(and (hash-has-key? metas key) (hash-ref metas key))) (and (hash-has-key? metas key) (hash-ref metas key)))
(module-test-external
(let ([metas '#hash((key . "value"))])
(check-equal? (select-from-metas 'key metas) "value")
(check-false (select-from-metas 'absent-key metas))))
(define+provide/contract (select-from-doc key doc-source) (define+provide/contract (select-from-doc key doc-source)
(coerce/symbol? (or/c txexpr? pagenode? pathish?) . -> . (or/c #f txexpr-elements?)) (coerce/symbol? (or/c txexpr? pagenode? pathish?) . -> . (or/c #f txexpr-elements?))
@ -55,6 +72,13 @@
(define result (se-path*/list (list key) doc)) (define result (se-path*/list (list key) doc))
(and (not (null? result)) result)) (and (not (null? result)) result))
(module-test-external
(check-equal? (select-from-doc 'key '(root (key "value"))) '("value"))
(check-false (select-from-doc 'absent-key '(root (key "value"))))
(let ([doc '(root (key "value"))])
(check-equal? (select-from-doc 'key doc) '("value"))
(check-false (select-from-doc 'absent-key doc))))
(define (get-metas pagenode-or-path) (define (get-metas pagenode-or-path)
; ((or/c pagenode? pathish?) . -> . hash?) ; ((or/c pagenode? pathish?) . -> . hash?)
@ -96,7 +120,23 @@
(if splice? (if splice?
(trim-outer-tag html) (trim-outer-tag html)
html)) html))
(xexpr->html x))) (xexpr->html x)))
(module-test-external
(define tx '(root (p "hello")))
(check-equal? (->html tx) "<root><p>hello</p></root>")
(check-equal? (->html #:tag 'brennan tx) "<brennan><p>hello</p></brennan>")
(check-equal? (->html #:attrs '((id "dale")) tx) "<root id=\"dale\"><p>hello</p></root>")
(check-equal? (->html #:splice #t tx) "<p>hello</p>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) tx) "<brennan id=\"dale\"><p>hello</p></brennan>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) #:splice #t tx) "<p>hello</p>")
(define x "hello")
(check-equal? (->html x) "hello")
(check-equal? (->html #:tag 'brennan x) "<brennan>hello</brennan>")
(check-exn exn:fail? (λ() (->html #:attrs '((id "dale")) x) "hello")) ;; won't work without tag
(check-equal? (->html #:splice #t x) "hello")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) x) "<brennan id=\"dale\">hello</brennan>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) #:splice #t x) "hello"))
(provide when/block) (provide when/block)
(define-syntax (when/block stx) (define-syntax (when/block stx)

0
tests/samples/sample-01.html.pm → test-support/samples/sample-01.html.pm
Unescape Escape View File

0
tests/samples/sample-02.txt.pp → test-support/samples/sample-02.txt.pp
Unescape Escape View File

0
tests/samples/sample-03.txt.p → test-support/samples/sample-03.txt.p
Unescape Escape View File

0
tests/test.html.pm → test-support/test.html.pm
Unescape Escape View File

0
tests/test.html.pmd → test-support/test.html.pmd
Unescape Escape View File

0
tests/test.html.pp → test-support/test.html.pp
Unescape Escape View File

0
tests/test.no-ext → test-support/test.no-ext
Unescape Escape View File

0
tests/test.ptree → test-support/test.ptree
Unescape Escape View File

59
tests/test-file-tools.rkt
Unescape Escape View File

@ -1,59 +0,0 @@
#lang racket/base
(require rackunit "../file.rkt" "../world.rkt" sugar)
(check-true (sourceish? "foo.svg"))
(check-false (sourceish? "foo.gif"))
(check-true (urlish? (->path "/Users/MB/home.html")))
(check-true (urlish? "/Users/MB/home.html?foo=bar"))
(check-true (urlish? (->symbol "/Users/MB/home")))
(check-true (pathish? (->path "/Users/MB/home")))
(check-true (pathish? "/Users/MB/home"))
(check-true (pathish? (->symbol "/Users/MB/home")))
(check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/"))
(check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo"))
(check-equal? (get-enclosing-dir "/Users/MB/foo.txt") (->path "/Users/MB/"))
(check-equal? (get-enclosing-dir "/Users/MB/foo/") (->path "/Users/MB/"))
(check-true (has-binary-ext? "foo.MP3"))
(check-false (has-binary-ext? "foo.py"))
(check-true (preproc-source? "foo.pp"))
(check-false (preproc-source? "foo.bar"))
(check-false (preproc-source? #f))
(check-true (pagetree-source? (format "foo.~a" world:pagetree-source-ext)))
(check-false (pagetree-source? (format "~a.foo" world:pagetree-source-ext)))
(check-false (pagetree-source? #f))
(check-true (markup-source? "foo.pm"))
(check-false (markup-source? "foo.p"))
(check-false (markup-source? #f))
(check-true (template-source? "foo.html.pt"))
(check-false (template-source? "foo.html"))
(check-false (template-source? #f))
(check-equal? (->preproc-source-path (->path "foo.pp")) (->path "foo.pp"))
(check-equal? (->preproc-source-path (->path "foo.html")) (->path "foo.html.pp"))
(check-equal? (->preproc-source-path "foo") (->path "foo.pp"))
(check-equal? (->preproc-source-path 'foo) (->path "foo.pp"))
(check-equal? (->output-path (->path "foo.pmap")) (->path "foo.pmap"))
(check-equal? (->output-path "foo.html") (->path "foo.html"))
(check-equal? (->output-path 'foo.html.p) (->path "foo.html"))
(check-equal? (->output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html"))
(check-equal? (->output-path "foo.xml.p") (->path "foo.xml"))
(check-equal? (->output-path 'foo.barml.p) (->path "foo.barml"))
(check-equal? (->markup-source-path (->path "foo.pm")) (->path "foo.pm"))
(check-equal? (->markup-source-path (->path "foo.html")) (->path "foo.html.pm"))
(check-equal? (->markup-source-path "foo") (->path "foo.pm"))
(check-equal? (->markup-source-path 'foo) (->path "foo.pm"))

10
tests/test-langs.rkt
Unescape Escape View File

@ -32,11 +32,11 @@
;; define-runtime-path only allowed at top level ;; define-runtime-path only allowed at top level
(define-runtime-path test.ptree "test.ptree") (define-runtime-path test.ptree "../test-support/test.ptree")
(define-runtime-path test.html.pm "test.html.pm") (define-runtime-path test.html.pm "../test-support/test.html.pm")
(define-runtime-path test.html.pmd "test.html.pmd") (define-runtime-path test.html.pmd "../test-support/test.html.pmd")
(define-runtime-path test.html.pp "test.html.pp") (define-runtime-path test.html.pp "../test-support/test.html.pp")
(define-runtime-path test.no-ext "test.no-ext") (define-runtime-path test.no-ext "../test-support/test.no-ext")
;; `find-exe` avoids reliance on $PATH of the host system ;; `find-exe` avoids reliance on $PATH of the host system

61
tests/test-ptree.rkt
Unescape Escape View File

@ -1,61 +0,0 @@
#lang racket/base
(require rackunit)
(require "../pagetree.rkt" "../world.rkt")
(check-false (pagenode? "foo-bar"))
(check-false (pagenode? "Foo_Bar_0123"))
(check-true (pagenode? 'foo-bar))
(check-false (pagenode? "foo-bar.p"))
(check-false (pagenode? "/Users/MB/foo-bar"))
(check-false (pagenode? #f))
(check-false (pagenode? ""))
(check-false (pagenode? " "))
(check-true (pagetree? '(foo)))
(check-true (pagetree? '(foo (hee))))
(check-true (pagetree? '(foo (hee (uncle foo)))))
(check-false (pagetree? '(foo (hee hee (uncle foo)))))
(define test-pagetree `(pagetree-main foo bar (one (two three))))
;(define test-pagetree (pagetree-root->pagetree test-pagetree-main))
(check-equal? (parent 'three test-pagetree) 'two)
(check-equal? (parent "three" test-pagetree) 'two)
(check-false (parent #f test-pagetree))
(check-false (parent 'nonexistent-name test-pagetree))
(check-equal? (children 'one test-pagetree) '(two))
(check-equal? (children 'two test-pagetree) '(three))
(check-false (children 'three test-pagetree))
(check-false (children #f test-pagetree))
(check-false (children 'fooburger test-pagetree))
(check-equal? (siblings 'one test-pagetree) '(foo bar one))
(check-equal? (siblings 'foo test-pagetree) '(foo bar one))
(check-equal? (siblings 'two test-pagetree) '(two))
(check-false (siblings #f test-pagetree))
(check-false (siblings 'invalid-key test-pagetree))
(check-equal? (previous* 'one test-pagetree) '(foo bar))
(check-equal? (previous* 'three test-pagetree) '(foo bar one two))
(check-false (previous* 'foo test-pagetree))
(check-equal? (previous 'one test-pagetree) 'bar)
(check-equal? (previous 'three test-pagetree) 'two)
(check-false (previous 'foo test-pagetree))
(check-equal? (next 'foo test-pagetree) 'bar)
(check-equal? (next 'one test-pagetree) 'two)
(check-false (next 'three test-pagetree))
(check-equal? (pagetree->list test-pagetree) '(foo bar one two three))
(let ([sample-main `(world:pollen-tree-root-name foo bar (one (two three)))])
(check-equal? sample-main
`(world:pollen-tree-root-name foo bar (one (two three)))))

25
tests/test-render.rkt
Unescape Escape View File

@ -1,25 +0,0 @@
#lang racket/base
(require rackunit racket/runtime-path)
(require "../render.rkt")
(require/expose "../render.rkt" (modification-date-hash make-mod-dates-key path->mod-date-value store-render-in-modification-dates modification-date-expired?))
(check-pred hash? modification-date-hash)
(define-runtime-path sample-dir "samples")
(define samples (parameterize ([current-directory sample-dir])
(map path->complete-path (directory-list "."))))
(define-values (sample-01 sample-02 sample-03) (apply values samples))
(check-equal? (make-mod-dates-key samples) samples)
(check-false (path->mod-date-value (path->complete-path "garbage-path.zzz")))
(check-equal? (path->mod-date-value sample-01) (file-or-directory-modify-seconds sample-01))
(check-equal? (store-render-in-modification-dates sample-01 sample-02 sample-03) (void))
(check-true (hash-has-key? modification-date-hash (list sample-01 sample-02 sample-03)))
(check-true (modification-date-expired? sample-01)) ; because key hasn't been stored
(check-false (apply modification-date-expired? samples)) ; because files weren't changed

42
tests/test-template.rkt
Unescape Escape View File

@ -1,42 +0,0 @@
#lang racket/base
(require rackunit)
(require "../template.rkt")
(define tx '(root (p "hello")))
(check-equal? (->html tx) "<root><p>hello</p></root>")
(check-equal? (->html #:tag 'brennan tx) "<brennan><p>hello</p></brennan>")
(check-equal? (->html #:attrs '((id "dale")) tx) "<root id=\"dale\"><p>hello</p></root>")
(check-equal? (->html #:splice #t tx) "<p>hello</p>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) tx) "<brennan id=\"dale\"><p>hello</p></brennan>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) #:splice #t tx) "<p>hello</p>")
(define x "hello")
(check-equal? (->html x) "hello")
(check-equal? (->html #:tag 'brennan x) "<brennan>hello</brennan>")
(check-exn exn:fail? (λ() (->html #:attrs '((id "dale")) x) "hello")) ;; won't work without tag
(check-equal? (->html #:splice #t x) "hello")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) x) "<brennan id=\"dale\">hello</brennan>")
(check-equal? (->html #:tag 'brennan #:attrs '((id "dale")) #:splice #t x) "hello")
(check-equal? (select 'key '#hash((key . "value"))) "value")
(check-false (select 'absent-key '#hash((key . "value"))))
(let ([metas '#hash((key . "value"))])
(check-equal? (select 'key metas) "value")
(check-false (select 'absent-key metas))
(check-equal? (select-from-metas 'key metas) "value")
(check-false (select-from-metas 'absent-key metas)))
(check-equal? (select 'key '(root (key "value"))) "value")
(check-false (select 'absent-key '(root (key "value"))))
(check-equal? (select-from-doc 'key '(root (key "value"))) '("value"))
(check-false (select-from-doc 'absent-key '(root (key "value"))))
(let ([doc '(root (key "value"))])
(check-equal? (select 'key doc) "value")
(check-false (select 'absent-key doc))
(check-equal? (select-from-doc 'key doc) '("value"))
(check-false (select-from-doc 'absent-key doc)))

77
tests/tests-decode.rkt
Unescape Escape View File

@ -1,77 +0,0 @@
#lang racket/base
(require pollen/decode racket/format rackunit txexpr)
(check-true (begin (register-block-tag 'barfoo) (block-txexpr? '(barfoo "foo"))))
(check-equal? (smart-dashes "I had --- maybe 13 -- 20 --- hob-nobs.") "I had—maybe 13–20—hob-nobs.")
(check-equal? (smart-quotes "\"Why,\" she could've asked, \"are we in O‘ahu watching 'Mame'?\"")
"“Why,” she could’ve asked, “are we in O‘ahu watching ‘Mame’?”")
(check-equal? (smart-quotes "\"\'Impossible.\' Yes.\"") "“‘Impossible.’ Yes.”")
;; todo: make some tougher tests, it gets flaky with edge cases
(check-equal? (nonbreaking-last-space '(p "Hi there")) '(p "Hi " "there")) ; nbsp in between last two words
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "Ø") '(p "HiØ" "there")) ; but let's make it visible
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "_up_") '(p "Hi_up_" "there"))
(check-equal? (nonbreaking-last-space '(p "Hi there") #:nbsp "_up_" #:minimum-word-length 3)
'(p "Hi " "there"))
(check-equal? (nonbreaking-last-space '(p "Hi here" (em "ho there")) #:nbsp "Ø") '(p "Hi here" (em "hoØ" "there")))
(check-equal? (wrap-hanging-quotes '(p "\"Hi\" there")) '(p (dquo "“" "Hi\" there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "‘" "Hi' there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino"))))
'(p (foo ((bar "ino")) "‘" "Hi' there")))
;; make sure txexpr without elements passes through unscathed
(check-equal? (wrap-hanging-quotes '(div ((style "height:2em")))) '(div ((style "height:2em"))))
(check-equal? (detect-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar"))
(check-equal? (detect-linebreaks '("\n" "foo" "\n" "bar" "\n")) '("\n" "foo" (br) "bar" "\n"))
(check-equal? (detect-linebreaks '((p "foo") "\n" (p "bar"))) '((p "foo") (p "bar")))
(check-equal? (detect-linebreaks '("foo" "\n" (p "bar"))) '("foo" (p "bar")))
(check-equal? (detect-linebreaks '("foo" "moo" "bar")) '("foo" "moo" "bar"))
(check-equal? (detect-linebreaks '("foo" "moo" "bar") #:insert "moo") '("foo" "moo" "bar"))
(check-equal? (detect-linebreaks '("foo" "\n\n" "bar")) '("foo" "\n\n" "bar"))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para"))
'((p "First para") (p "Second para")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line"))
'((p "First para") (p "Second para" (br) "Second line")))
(check-equal? (detect-paragraphs '("First para" "\n\n" (div "Second block")))
'((p "First para") (div "Second block")))
(check-equal? (detect-paragraphs '((div "First block") "\n\n" (div "Second block")))
'((div "First block") (div "Second block")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para") #:tag 'ns:p)
'((ns:p "First para") (ns:p "Second para")))
(check-equal? (detect-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line")
#:linebreak-proc (λ(x) (detect-linebreaks x #:insert '(newline))))
'((p "First para") (p "Second para" (newline) "Second line")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar") (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar") "\n\n" (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (detect-paragraphs '("foo")) '("foo"))
(check-equal? (detect-paragraphs '("foo") #:force? #t) '((p "foo")))
(check-equal? (detect-paragraphs '((div "foo"))) '((div "foo")))
(check-equal? (detect-paragraphs '((div "foo")) #:force? #t) '((div "foo")))
(check-equal? (detect-paragraphs '("foo" "\n\n" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar")) #:force? #t) '((p "foo") (div "bar")))
(check-equal? (detect-paragraphs '("foo" (div "bar") "zam")) '((p "foo") (div "bar") (p "zam")))
(check-equal? (detect-paragraphs '("foo" (span "zing") (div "bar") "zam")) '((p "foo" (span "zing")) (div "bar") (p "zam")))
(check-equal? (detect-paragraphs '("foo" (span "zing") (div "bar") "zam") #:force? #t) '((p "foo" (span "zing")) (div "bar") (p "zam")))
(check-equal? (merge-newlines '(p "\n" "foo" "\n" "\n" "bar" (em "\n" "\n" "\n")))
'(p "\n" "foo" "\n\n" "bar" (em "\n\n\n")))
(check-true (whitespace? " "))
(check-false (whitespace? (~a #\u00A0)))
(check-true (whitespace/nbsp? (~a #\u00A0)))
(check-true (whitespace/nbsp? (vector (~a #\u00A0))))
(check-false (whitespace? (format " ~a " #\u00A0)))
(check-true (whitespace/nbsp? (format " ~a " #\u00A0)))
Write Preview
Loading…
Cancel
Save