refactoring for first stable release

pull/110/head
Matthew Butterick 9 years ago
parent ee12ea9f15
commit 10e3918fba

@ -1,3 +1,3 @@
Pollen
© 20132015 Matthew Butterick
© 20132016 Matthew Butterick
Licensed under the LGPL (see "LGPL.txt")

@ -1,167 +0,0 @@
#lang racket/base
(require racket/path racket/file compiler/cm file/cache sugar/coerce sugar/list "project.rkt" "rerequire.rkt" "debug.rkt" "file.rkt" racket/place "world.rkt")
;; The cache is a hash with paths as keys.
;; The cache values are also hashes, with key/value pairs for that path.
(provide reset-cache preheat-cache cached-require paths->key key->source-path)
(define (reset-cache [starting-dir (world:current-project-root)])
(when (or (not (path-string? starting-dir)) (not (directory-exists? starting-dir)))
(error 'reset-cache (format "~a is not a directory" starting-dir)))
(for ([path (in-directory starting-dir)]
#:when (and (directory-exists? path)
(equal? (path->string (car (reverse (explode-path path)))) (world:current-cache-dir-name))))
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(define (preheat-cache [starting-dir (world:current-project-root)])
(when (or (not (path-string? starting-dir)) (not (directory-exists? starting-dir)))
(error 'preheat-cache (format "~a is not a directory" starting-dir)))
(define max-places 8) ; number of parallel processes to spawn at a time
(define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)]
#:when (or (preproc-source? path)
(markup-source? path)
(markdown-source? path)
(pagetree-source? path)))
path))
;; if a file is already in the cache, no need to hit it again.
;; this allows partially completed preheat jobs to resume.
(define uncached-paths (filter
(λ(path)
;; #t = not cached; #f = already cached
;; seems like it would be slow to load cache.rktd but it's not.
(define-values (_ private-cache-dir) (make-cache-dirs path))
(define cache-db-file (build-path private-cache-dir "cache.rktd"))
(cond
[(not (file-exists? cache-db-file)) #t]
[else (define cache-db (file->value cache-db-file))
(not (hash-has-key? cache-db (paths->key path)))])) paths-that-should-be-cached))
;; compile a path inside a place (= parallel processing)
(define (path-into-place path)
(message (format "caching: ~a" (find-relative-path starting-dir path)))
(define p (place ch
(define path (place-channel-get ch))
(define-values (path-dir path-name _) (split-path path))
(message (format "compiling: ~a" path-name))
;; use #f to signal compile error. Otherwise allow errors to pass.
(define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)])
(path->hash path)))
(place-channel-put ch result)))
(place-channel-put p path)
p)
;; compile the paths in groups, so they can be incrementally saved.
;; that way, if there's a failure, the progress is preserved.
;; but the slowest file in a group will prevent further progress.
(for ([path-group (in-list (slice-at uncached-paths max-places))])
(define path-places (map path-into-place path-group))
(for ([path (in-list path-group)]
[ppl (in-list path-places)])
(define result (place-channel-get ppl))
(when result ; #f is used to signal compile error
(cache-ref! (paths->key path) (λ _ result))))))
(define (paths->key source-path [template-path #f])
;; key is list of file + mod-time pairs, use #f for missing
(define path-strings (append (list source-path)
(append (list (and template-path (or (get-source template-path) template-path))) ; if template has a source file, track that instead
(->list (get-directory-require-files source-path))))) ; is either list of files or (list #f)
;; can't use relative paths for cache keys because source files include `here-path` which is absolute.
;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates)
;; but would actually be invalid (because the `here-path` names are wrong).
(define poly-flag (and (has-inner-poly-ext? source-path) (world:current-poly-target)))
(define pollen-env (getenv "POLLEN"))
(define path+mod-time-pairs
(map (λ(ps) (and ps (let ([cp (->complete-path ps)])
(cons (path->string cp) (with-handlers ([exn:fail? (λ _ 0)])
(file-or-directory-modify-seconds cp)))))) path-strings))
(list* pollen-env poly-flag path+mod-time-pairs))
(define (key->source-path key)
(car (caddr key)))
(require sugar/test)
(module-test-external
(define ps "/users/nobody/project/source.html.pm")
(check-equal? (key->source-path (paths->key ps)) ps))
(define-namespace-anchor anchor-to-this-namespace)
(define (path->hash path)
;; new namespace forces dynamic-require to re-instantiate 'path'
;; otherwise it gets cached in current namespace.
(define drfs (get-directory-require-files path))
(for-each managed-compile-zo (or drfs null))
(define path-dir (dirname path))
(apply hash
(let ([doc-key (world:current-main-export)]
[meta-key (world:current-meta-export)])
(parameterize ([current-namespace (make-base-namespace)]
[current-directory path-dir])
;; I monkeyed around with using the metas submodule to pull out the metas (for speed)
;; but in practice most files get their doc requested too.
;; so it's just simpler to get both at once and be done with it.
;; the savings of avoiding two cache fetches at the outset outweighs
;; the benefit of not reloading doc when you just need metas.
(namespace-attach-module (namespace-anchor->namespace anchor-to-this-namespace) 'pollen/world) ; brings in params
(list doc-key (dynamic-require path doc-key) meta-key (dynamic-require path meta-key))))))
(define (my-make-directory* dir)
(let-values ([(base name dir?) (split-path dir)])
(when (and (path? base) (not (directory-exists? base)))
(my-make-directory* base))
(unless (directory-exists? dir)
(with-handlers ([exn:fail:filesystem:exists? void])
(make-directory dir)))))
(define (make-cache-dirs path)
(define path-dir (dirname path))
(define cache-dir (build-path path-dir (world:current-cache-dir-name)))
(define private-cache-dir (build-path cache-dir "private"))
(my-make-directory* private-cache-dir) ; will also make cache-dir, if needed
(values cache-dir private-cache-dir))
(define ram-cache (make-hash))
(define (cache-ref! key path-hash-thunk)
(define path (key->source-path key))
(define-values (cache-dir private-cache-dir) (make-cache-dirs path))
(define-values (path-dir path-filename _) (split-path path))
(define dest-file (build-path cache-dir (format "~a.rktd" path-filename)))
(cache-file dest-file
#:exists-ok? #t
key
private-cache-dir
(λ _
(write-to-file (path-hash-thunk) dest-file #:exists 'replace))
#:max-cache-size (world:current-compile-cache-max-size))
(file->value dest-file))
(define (cached-require path-string subkey)
(define path (with-handlers ([exn:fail? (λ _ (raise-argument-error 'cached-require "valid path-string" path-string))])
(->complete-path path-string)))
(when (not (file-exists? path))
(raise-argument-error 'cached-require "path to existing file" path))
(cond
[(world:current-compile-cache-active path)
(define key (paths->key path))
(hash-ref (hash-ref! ram-cache key (λ _
(cache-ref! key (λ _ (path->hash path))))) subkey)]
[else (parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module (namespace-anchor->namespace anchor-to-this-namespace) 'pollen/world) ; brings in params
(dynamic-require path subkey))]))

@ -1,453 +0,0 @@
#lang racket/base
(require xml txexpr racket/string racket/match racket/list (prefix-in html: pollen/html) sugar/list sugar/container sugar/len sugar/define sugar/coerce sugar/test)
(require "debug.rkt" "world.rkt")
(define (symbols? x) (and (list? x) (andmap symbol? x)))
(define+provide (to-string x)
(if (string? x)
x ; fast exit for strings
(with-handlers ([exn:fail? (λ(exn) (error (format "Pollen decoder: can't convert ~v to ~a" x 'string)))])
(cond
[(equal? '() x) ""]
[(symbol? x) (symbol->string x)]
[(number? x) (number->string x)]
[(path? x) (path->string x)]
[(char? x) (format "~a" x)]
[(void? x) ""]
;; todo: guard against weird shit like lists of procedures
[(or (list? x) (hash? x) (vector? x)) (format "~v" x)] ; ok to convert datatypes
[else (error)])))) ; but things like procedures should throw an error
(define decode-proc-output-contract (or/c xexpr/c (listof xexpr/c)))
(define (->list/tx x)
;; same as ->list but catches special case of single txexpr,
;; which is itself a list, but in this case should be wrapped into a list,
;; for use with append-map.
(if (txexpr? x)
(list x)
(->list x)))
;; decoder wireframe
(define+provide/contract (decode tx-in
#:txexpr-tag-proc [txexpr-tag-proc (λ(x)x)]
#:txexpr-attrs-proc [txexpr-attrs-proc (λ(x)x)]
#:txexpr-elements-proc [txexpr-elements-proc (λ(x)x)]
#:block-txexpr-proc [block-txexpr-proc (λ(x)x)]
#:inline-txexpr-proc [inline-txexpr-proc (λ(x)x)]
#:string-proc [string-proc (λ(x)x)]
#:entity-proc [entity-proc (λ(x)x)]
#:cdata-proc [cdata-proc (λ(x)x)]
#:exclude-tags [excluded-tags '()]
#:exclude-attrs [excluded-attrs '()])
((xexpr/c)
(#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?)
#:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?)
#:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?)
#:block-txexpr-proc (block-txexpr? . -> . decode-proc-output-contract)
#:inline-txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:string-proc (string? . -> . decode-proc-output-contract)
#:entity-proc ((or/c symbol? valid-char?) . -> . decode-proc-output-contract)
#:cdata-proc (cdata? . -> . decode-proc-output-contract)
#:exclude-tags (listof txexpr-tag?)
#:exclude-attrs txexpr-attrs?) . ->* . (or/c xexpr/c (listof xexpr/c)))
(let loop ([x tx-in])
(cond
[(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)])
(if (or (member tag excluded-tags) (ormap (λ(attr) (member attr excluded-attrs)) attrs))
x ; because it's excluded
;; we apply processing here rather than do recursive descent on the pieces
;; because if we send them back through loop, certain element types are ambiguous
;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
(let ([decoded-txexpr
(apply make-txexpr (list (txexpr-tag-proc tag)
(txexpr-attrs-proc attrs)
(txexpr-elements-proc (append-map (compose1 ->list/tx loop) elements))))])
((if (block-txexpr? decoded-txexpr)
block-txexpr-proc
inline-txexpr-proc) decoded-txexpr))))]
[(string? x) (string-proc x)]
[(or (symbol? x) (valid-char? x)) (entity-proc x)]
[(cdata? x) (cdata-proc x)]
[else (error "decode: can't decode" x)])))
(module-test-external
(require racket/list txexpr racket/function)
(define (doubler x) (list x x))
(check-equal? (decode #:txexpr-elements-proc identity '(p "foo")) '(p "foo"))
;; can't use doubler on txexpr-elements because it needs a list, not list of lists
(check-equal? (decode #:txexpr-elements-proc (λ(elems) (append elems elems)) '(p "foo")) '(p "foo" "foo"))
(check-equal? (decode #:block-txexpr-proc identity '(p "foo")) '(p "foo"))
(check-equal? (decode #:block-txexpr-proc doubler '(p "foo")) (list '(p "foo") '(p "foo")))
(check-equal? (decode #:inline-txexpr-proc identity '(p (span "foo"))) '(p (span "foo")))
(check-equal? (decode #:inline-txexpr-proc doubler '(p (span "foo"))) '(p (span "foo") (span "foo")))
(check-equal? (decode #:string-proc identity '(p (span "foo"))) '(p (span "foo")))
(check-equal? (decode #:string-proc doubler '(p (span "foo"))) '(p (span "foo" "foo")))
(check-equal? (decode #:entity-proc identity '(p (span "foo" 'amp))) '(p (span "foo" 'amp)))
(check-equal? (decode #:entity-proc identity '(p 42)) '(p 42))
(check-equal? (decode #:entity-proc doubler '(p 42)) '(p 42 42))
(check-equal? (decode #:entity-proc identity '(p amp)) '(p amp))
;; next text doesn't work because list of symbol elements is ambiguous with tagged X-expression
;; is there a general patch for this? maybe, but for now it's better to not patch selectively
;; otherwise ambiguous expressions will have erratic misbehavior (instead of merely consistent misbehavior)
;;(check-equal? (decode #:entity-proc doubler '(p amp)) '(p amp amp))
(check-equal? (decode-elements #:string-proc identity '("foo")) '("foo"))
(check-equal? (decode-elements #:string-proc doubler '("foo")) '("foo" "foo")))
;; it would be nice to not repeat this, but with all the keywords, it's simpler to repeat than do a macro
(define+provide/contract (decode-elements elements
#:txexpr-tag-proc [txexpr-tag-proc (λ(x)x)]
#:txexpr-attrs-proc [txexpr-attrs-proc (λ(x)x)]
#:txexpr-elements-proc [txexpr-elements-proc (λ(x)x)]
#:block-txexpr-proc [block-txexpr-proc (λ(x)x)]
#:inline-txexpr-proc [inline-txexpr-proc (λ(x)x)]
#:string-proc [string-proc (λ(x)x)]
#:entity-proc [entity-proc (λ(x)x)]
#:cdata-proc [cdata-proc (λ(x)x)]
#:exclude-tags [excluded-tags '()]
#:exclude-attrs [excluded-attrs '()])
((txexpr-elements?)
(#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?)
#:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?)
#:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?)
#:block-txexpr-proc (block-txexpr? . -> . decode-proc-output-contract)
#:inline-txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:string-proc (string? . -> . decode-proc-output-contract)
#:entity-proc ((or/c symbol? valid-char?) . -> . decode-proc-output-contract)
#:cdata-proc (cdata? . -> . decode-proc-output-contract)
#:exclude-tags (listof txexpr-tag?)
#:exclude-attrs txexpr-attrs?) . ->* . (or/c xexpr/c (listof xexpr/c)))
(define temp-tag (gensym "temp-tag"))
(define decode-result (decode `(temp-tag ,@elements)
#:txexpr-tag-proc txexpr-tag-proc
#:txexpr-attrs-proc txexpr-attrs-proc
#:txexpr-elements-proc txexpr-elements-proc
#:block-txexpr-proc block-txexpr-proc
#:inline-txexpr-proc inline-txexpr-proc
#:string-proc string-proc
#:entity-proc entity-proc
#:cdata-proc cdata-proc
#:exclude-tags excluded-tags
#:exclude-attrs excluded-attrs))
(get-elements decode-result))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Blocks
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initial set of block tags: from html
(define+provide project-block-tags
(make-parameter html:block-tags))
;; tags are inline unless they're registered as block tags.
(define+provide/contract (block-txexpr? x)
(any/c . -> . boolean?)
(and (txexpr? x) (member (get-tag x) (project-block-tags)) #t))
(define+provide/contract (register-block-tag tag)
(txexpr-tag? . -> . void?)
(project-block-tags (cons tag (project-block-tags))))
(module-test-external
(check-true (begin (register-block-tag 'barfoo) (block-txexpr? '(barfoo "foo")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Typography
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-replacer query+replacement)
(let ([queries (map car query+replacement)]
[replacements (map second query+replacement)])
;; reverse because first in list should be first applied to str (and compose1 works right-to-left)
(apply compose1 (reverse (map (λ(query replacement) (λ(str) (regexp-replace* query str replacement))) queries replacements)))))
(define+provide/contract (smart-dashes str)
(string? . -> . string?)
(define dashes
;; fix em dashes first, else they'll be mistaken for en dashes
;; \\s is whitespace + #\u00A0 is nonbreaking space
'((#px"[\\s#\u00A0]*(---|—)[\\s#\u00A0]*" "") ; em dash
(#px"[\\s#\u00A0]*(--|)[\\s#\u00A0]*" ""))) ; en dash
((make-replacer dashes) str))
(module-test-external
(check-equal? (smart-dashes "I had --- maybe 13 -- 20 --- hob-nobs.") "I had—maybe 1320—hob-nobs.")
(check-equal? (smart-quotes "\"Why,\" she could've asked, \"are we in Oahu watching 'Mame'?\"")
"“Why,” she couldve asked, “are we in Oahu watching Mame?”")
(check-equal? (smart-quotes "\"\'Impossible.\' Yes.\"") "Impossible. Yes.”"))
(define+provide/contract (smart-quotes str)
(string? . -> . string?)
(define quotes
'((#px"(?<=\\w)'(?=\\w)" "") ; apostrophe
(#px"(?<!\\w)'(?=\\S)" "") ; single_at_beginning
(#px"(?<=\\S)'(?!\\w)" "") ; single_at_end
(#px"(?<!\\w)\"(?=\\S)" "") ; double_at_beginning
(#px"(?<=\\S)\"(?!\\w)" ""))) ; double_at_end
((make-replacer quotes) str))
;; insert nbsp between last two words
(define+provide/contract (nonbreaking-last-space x #:nbsp [nbsp (->string #\u00A0)]
#:minimum-word-length [minimum-word-length 6]
#:last-word-proc [last-word-proc (λ(x) x)])
((txexpr?) (#:nbsp string? #:minimum-word-length integer? #:last-word-proc procedure?) . ->* . txexpr?)
;; todo: parameterize this, as it will be different for each project
(define tags-to-pay-attention-to '(p aside)) ; only apply to paragraphs
(define (replace-last-space str)
(if (#\space . in? . str)
(let ([reversed-str-list (reverse (string->list str))]
[reversed-nbsp (reverse (string->list (->string nbsp)))])
(define-values (last-word-chars other-chars)
(splitf-at reversed-str-list (λ(i) (not (eq? i #\space)))))
(define front-chars (if (< (len last-word-chars) minimum-word-length) ; OK for long words to be on their own line
; first char of other-chars will be the space, so use cdr
(string-append (list->string (reverse (cdr other-chars))) (->string nbsp))
(list->string (reverse other-chars))))
(define last-word (list->string (reverse last-word-chars)))
`(,front-chars ,(last-word-proc last-word))) ; don't concatenate last word bc last-word-proc might be a txexpr wrapper
(list str)))
(define (find-last-word-space x) ; recursively traverse xexpr
(cond
[(string? x) (replace-last-space x)] ; todo: this assumes a paragraph only has one string in it.
[(txexpr? x)
(let-values([(tag attr elements) (txexpr->values x)])
(if (> (length elements) 0) ; elements is list of xexprs
(let-values ([(all-but-last last) (split-at elements (sub1 (length elements)))])
(define result (find-last-word-space (car last)))
(define result-items (if (txexpr? result) (list result) result)) ; might be txexpr, or list of new elements
(make-txexpr tag attr `(,@all-but-last ,@result-items)))
x))]
[else x]))
(if ((car x) . in? . tags-to-pay-attention-to)
(find-last-word-space 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
; todo: improve this
; does not handle <p>“<em>thing</em> properly
(define+provide/contract (wrap-hanging-quotes nx
#:single-prepend [single-pp '(squo)]
#:double-prepend [double-pp '(dquo)])
((txexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . txexpr?)
(define two-or-more-char-string? (λ(i) (and (string? i) (>= (len i) 2))))
(define-values (tag attr elements) (txexpr->values nx))
(make-txexpr tag attr
(if (and (list? elements) (not (empty? elements)))
(let ([new-car-elements (match (car elements)
[(? two-or-more-char-string? tcs)
(define str-first (get tcs 0))
(define str-rest (get tcs 1 (len tcs)))
(cond
[(str-first . in? . '("\"" ""))
;; can wrap with any inline tag
;; so that linebreak detection etc still works
`(,@double-pp ,(->string #\“) ,str-rest)]
[(str-first . in? . '("\'" ""))
`(,@single-pp ,(->string #\) ,str-rest)]
[else tcs])]
[(? txexpr? nx) (wrap-hanging-quotes nx)]
[else (car elements)])])
(cons new-car-elements (cdr 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")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Lines, blocks, paragraphs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; turn the right items into <br> tags
(define+provide/contract (detect-linebreaks xc
#:separator [newline (world:current-linebreak-separator)]
#:insert [linebreak '(br)])
((txexpr-elements?) (#:separator string? #:insert xexpr?) . ->* . txexpr-elements?)
;; todo: should this test be not block + not whitespace?
(define not-block? (λ(i) (not (block-txexpr? i))))
(filter-not empty?
(for/list ([i (in-range (len xc))])
(let ([item (get xc i)])
(cond
;; skip first and last
[(or (= i 0) (= i (sub1 (len xc)))) item]
[(equal? item newline)
(match (get xc (- i 1) (+ i 2)) ; a three-element slice with x[i] in the middle
;; only convert if neither adjacent tag is a block
;; (because blocks automatically force a newline before & after)
[(list (? not-block?) newline (? not-block?)) linebreak]
[else empty])] ; otherwise delete
[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])
((any/c)(boolean?) . ->* . coerce/boolean?)
(define pat (pregexp (format "^[\\s~a]+$" (if nbsp? #\u00A0 ""))))
(cond
[(equal? "" x) #t] ; empty string is deemed whitespace
[(or (string? x) (symbol? x)) (regexp-match pat (->string x))]
[(or (list? x) (vector? x)) (and (not (empty? x)) (andmap (λ(i) (whitespace? i nbsp?)) (->list x)))] ; andmap returns #t for empty lists
[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)
(any/c . -> . coerce/boolean?)
(whitespace? x #t))
;; is x a paragraph break?
(define+provide/contract (paragraph-break? x #:separator [sep (world:current-paragraph-separator)])
((any/c) (#:separator pregexp?) . ->* . coerce/boolean?)
(define paragraph-pattern (pregexp (format "^~a+$" sep)))
(and (string? x) (regexp-match paragraph-pattern x)))
;; Find adjacent newline characters in a list and merge them into one item
;; Scribble, by default, makes each newline a separate list item.
(define+provide/contract (merge-newlines x)
(txexpr-elements? . -> . txexpr-elements?)
(define (newlines? x)
(and (string? x)
(let ([newline-pat (regexp (format "^~a+$" (world:current-newline)))])
(regexp-match newline-pat x))))
(define (merge-if-newlines xs)
(if (newlines? (car xs))
(list (string-append* xs))
xs))
(let loop ([x x])
(if (pair? x)
(let ([xs (map loop x)])
(append-map merge-if-newlines (slicef xs newlines?)))
x)))
(module-test-external
(require racket/list)
(check-equal? (merge-newlines empty) empty)
(check-equal? (merge-newlines '(p "\n" "\n" "foo" "\n" "\n\n" "bar" (em "\n" "\n" "\n")))
'(p "\n\n" "foo" "\n\n\n" "bar" (em "\n\n\n"))))
;; detect paragraphs
;; todo: unit tests
(define+provide/contract (detect-paragraphs elements #:tag [tag 'p]
#:separator [sep (world:current-paragraph-separator)]
#:linebreak-proc [linebreak-proc detect-linebreaks]
#:force? [force-paragraph #f])
((txexpr-elements?) (#:tag symbol? #:separator string? #:linebreak-proc (txexpr-elements? . -> . txexpr-elements?) #:force? boolean?)
. ->* . txexpr-elements?)
;; prepare elements for paragraph testing
(define (prep-paragraph-flow elems)
(linebreak-proc (merge-newlines (trimf elems whitespace?))))
(define my-paragraph-break? (λ(x) (and (paragraph-break? x #:separator sep) #t)))
(define (wrap-paragraph elems)
(match elems
[(list (? block-txexpr? bxs) ...) bxs] ; leave a series of block xexprs alone
[else (list (make-txexpr tag empty elems))])) ; otherwise wrap in p tag
(let ([elements (prep-paragraph-flow elements)])
(define explicit-or-implicit-paragraph-break? (λ(x) (or (my-paragraph-break? x) (block-txexpr? x))))
(if (ormap explicit-or-implicit-paragraph-break? elements) ; need this condition to prevent infinite recursion
;; use append-map on wrap-paragraph rather than map to permit return of multiple elements
(append-map wrap-paragraph (append-map (λ(es) (filter-split es my-paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
(if force-paragraph
(append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs
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"))))

@ -1,13 +1,8 @@
#lang info
(define collection "pollen")
(define version "1.0")
(define collection 'multi)
(define deps '("base" "txexpr" "sugar" ("markdown" #:version "0.18") "htdp"
"at-exp-lib" "html-lib" "rackjure" "web-server-lib" "scribble-text-lib" "rackunit-lib"
"gui-lib"))
(define build-deps '("plot-gui-lib" "scribble-lib" "racket-doc" "rackunit-doc" "plot-doc" "scribble-doc" "slideshow-doc" "web-server-doc"))
(define update-implies '("txexpr" "sugar"))
(define scribblings '(("scribblings/pollen.scrbl" (multi-page))))
(define raco-commands '(("pollen" (submod pollen/command raco) "issue Pollen command" #f)))
(define compile-omit-paths '("test" "tools" "server-extras" "scribblings/third-tutorial-files"))
;; it's redundant to test "pollen.scrbl" because it incorporates the other scribble sources by reference
(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl"))
(define module-suffixes '(#"pp" #"pm" #"pmd" #"ptree"))

@ -1,8 +0,0 @@
#lang racket/base
(require pollen/main-base)
(define+provide-module-begin-in-mode world:mode-preproc) ; because default mode in submodule is preproc
(module reader racket/base
(require pollen/reader-base)
;; because default mode in file is auto
(define+provide-reader-in-mode world:mode-auto))

@ -1,8 +0,0 @@
#lang racket/base
(require pollen/main-base)
(define+provide-module-begin-in-mode world:mode-markdown)
(module reader racket/base
(require pollen/reader-base)
(define+provide-reader-in-mode world:mode-markdown))

@ -1,8 +0,0 @@
#lang racket/base
(require pollen/main-base)
(define+provide-module-begin-in-mode world:mode-markup)
(module reader racket/base
(require pollen/reader-base)
(define+provide-reader-in-mode world:mode-markup))

@ -0,0 +1,51 @@
#lang racket/base
(require racket/file
sugar/define
"private/cache-utils.rkt"
"private/debug.rkt"
"world.rkt")
;; The cache is a hash with paths as keys.
;; The cache values are also hashes, with key/value pairs for that path.
(define+provide (reset-cache [starting-dir (world:current-project-root)])
(unless (and (path-string? starting-dir) (directory-exists? starting-dir))
(raise-argument-error 'reset-cache "path-string to existing directory" starting-dir))
(for ([path (in-directory starting-dir)]
#:when (and (directory-exists? path)
(equal? (path->string (car (reverse (explode-path path)))) (world:current-cache-dir-name))))
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(define-namespace-anchor cache-module-ns)
(define cached-require-base
(let ([ram-cache (make-hash)])
(λ(path-or-path-string subkey caller-name)
(define path (with-handlers ([exn:fail? (λ(e) (raise-argument-error caller-name "valid path or path-string" path-or-path-string))])
(path->complete-path (if (path? path-or-path-string)
path-or-path-string
(string->path path-or-path-string)))))
(unless (file-exists? path)
(raise-argument-error caller-name "path to existing file" path-or-path-string))
(cond
[(world:current-compile-cache-active path)
(define key (paths->key path))
(hash-ref (hash-ref! ram-cache key (λ _ (cache-ref! key (λ _ (path->hash path))))) subkey)]
[else (parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'pollen/world) ; brings in params
(dynamic-require path subkey))]))))
(define+provide (cached-require path-string subkey)
(cached-require-base path-string subkey 'cached-require))
(define+provide (cached-doc path-string)
(cached-require-base path-string (world:current-main-export) 'cached-doc))
(define+provide (cached-metas path-string)
(cached-require-base path-string (world:current-meta-export) 'cached-metas))

@ -0,0 +1,248 @@
#lang racket/base
(require xml txexpr racket/list sugar/list sugar/define sugar/test)
(require "world.rkt"
"private/whitespace.rkt")
(define (->list/tx x)
;; same as ->list but catches special case of single txexpr,
;; which is itself a list, but in this case should be wrapped into a list,
;; for use with append-map.
(cond
[(txexpr? x) (list x)]
[(list? x) x]
[else (list x)]))
(define decode-proc-output-contract (or/c txexpr-element? txexpr-elements?))
(define identity (λ(x) x))
;; decoder wireframe
(define+provide/contract (decode tx-in
#:txexpr-tag-proc [txexpr-tag-proc identity]
#:txexpr-attrs-proc [txexpr-attrs-proc identity]
#:txexpr-elements-proc [txexpr-elements-proc identity]
#:txexpr-proc [txexpr-proc identity]
#:block-txexpr-proc [block-txexpr-proc identity]
#:inline-txexpr-proc [inline-txexpr-proc identity]
#:string-proc [string-proc identity]
#:entity-proc [entity-proc identity]
#:cdata-proc [cdata-proc identity]
#:exclude-tags [excluded-tags empty]
#:exclude-attrs [excluded-attrs empty])
((xexpr/c)
(#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?)
#:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?)
#:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?)
#:txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:block-txexpr-proc (block-txexpr? . -> . decode-proc-output-contract)
#:inline-txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:string-proc (string? . -> . decode-proc-output-contract)
#:entity-proc ((or/c symbol? valid-char?) . -> . decode-proc-output-contract)
#:cdata-proc (cdata? . -> . decode-proc-output-contract)
#:exclude-tags txexpr-tags?
#:exclude-attrs txexpr-attrs?) . ->* . decode-proc-output-contract)
(let loop ([x tx-in])
(cond
[(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)])
(if (or (member tag excluded-tags) (ormap (λ(attr) (member attr excluded-attrs)) attrs))
x ; because it's excluded
;; we apply processing here rather than do recursive descent on the pieces
;; because if we send them back through loop, certain element types are ambiguous
;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
(let ([decoded-txexpr
(apply make-txexpr (list (txexpr-tag-proc tag)
(txexpr-attrs-proc attrs)
(txexpr-elements-proc (append-map (compose1 ->list/tx loop) elements))))])
((compose1 txexpr-proc (if (block-txexpr? decoded-txexpr)
block-txexpr-proc
inline-txexpr-proc)) decoded-txexpr))))]
[(string? x) (string-proc x)]
[(or (symbol? x) (valid-char? x)) (entity-proc x)]
[(cdata? x) (cdata-proc x)]
[else (error "decode: can't decode" x)])))
(module-test-external
(require racket/list txexpr racket/function)
(define (doubler x) (list x x))
(define (doubletag x) (txexpr (string->symbol (format "~a~a" (get-tag x) (get-tag x))) (get-attrs x) (get-elements x)))
(check-equal? (decode #:txexpr-elements-proc identity '(p "foo")) '(p "foo"))
;; can't use doubler on txexpr-elements because it needs a list, not list of lists
(check-equal? (decode #:txexpr-elements-proc (λ(elems) (append elems elems)) '(p "foo")) '(p "foo" "foo"))
(check-equal? (decode #:block-txexpr-proc identity '(p "foo")) '(p "foo"))
(check-equal? (decode #:block-txexpr-proc doubler '(p "foo")) (list '(p "foo") '(p "foo")))
(check-equal? (decode #:block-txexpr-proc doubler '(p "foo")) (list '(p "foo") '(p "foo")))
(check-equal? (decode #:txexpr-proc doubletag '(root (p "foo") (b "bar"))) '(rootroot (pp "foo") (bb "bar")))
(check-equal? (decode #:block-txexpr-proc doubletag '(root (p "foo") (b "bar"))) '(rootroot (pp "foo") (b "bar")))
(check-equal? (decode #:inline-txexpr-proc doubletag '(root (p "foo") (b "bar"))) '(root (p "foo") (bb "bar")))
(check-equal? (decode #:inline-txexpr-proc identity '(p (span "foo"))) '(p (span "foo")))
(check-equal? (decode #:inline-txexpr-proc doubler '(p (span "foo"))) '(p (span "foo") (span "foo")))
(check-equal? (decode #:string-proc identity '(p (span "foo"))) '(p (span "foo")))
(check-equal? (decode #:string-proc doubler '(p (span "foo"))) '(p (span "foo" "foo")))
(check-equal? (decode #:entity-proc identity '(p (span "foo" 'amp))) '(p (span "foo" 'amp)))
(check-equal? (decode #:entity-proc identity '(p 42)) '(p 42))
(check-equal? (decode #:entity-proc doubler '(p 42)) '(p 42 42))
(check-equal? (decode #:entity-proc identity '(p amp)) '(p amp))
;; next text doesn't work because list of symbol elements is ambiguous with tagged X-expression
;; is there a general patch for this? maybe, but for now it's better to not patch selectively
;; otherwise ambiguous expressions will have erratic misbehavior (instead of merely consistent misbehavior)
;;(check-equal? (decode #:entity-proc doubler '(p amp)) '(p amp amp))
(check-equal? (decode-elements #:string-proc identity '("foo")) '("foo"))
(check-equal? (decode-elements #:string-proc doubler '("foo")) '("foo" "foo")))
;; it would be nice to not repeat this, but with all the keywords, it's simpler to repeat than do a macro
(define+provide/contract decode-elements
((txexpr-elements?)
(#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?)
#:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?)
#:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?)
#:txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:block-txexpr-proc (block-txexpr? . -> . decode-proc-output-contract)
#:inline-txexpr-proc (txexpr? . -> . decode-proc-output-contract)
#:string-proc (string? . -> . decode-proc-output-contract)
#:entity-proc ((or/c symbol? valid-char?) . -> . decode-proc-output-contract)
#:cdata-proc (cdata? . -> . decode-proc-output-contract)
#:exclude-tags txexpr-tags?
#:exclude-attrs txexpr-attrs?) . ->* . decode-proc-output-contract)
(make-keyword-procedure
(λ (kws kwargs . args)
(define temp-tag (gensym "temp-tag"))
(define elements (car args))
(define decode-result (keyword-apply decode kws kwargs (list (cons temp-tag elements))))
(get-elements decode-result))))
(define+provide/contract (block-txexpr? x)
(any/c . -> . boolean?)
;; Mostly this is used inside `decode`,
;; so rather than test for `txexpr?` at the beginning (which is potentially slow)
;; just look at the tag.
(and (pair? x)
(memq (get-tag x) (world:current-block-tags))
#t))
(define+provide/contract (decode-linebreaks elems [maybe-linebreak-proc '(br)]
#:separator [newline (world:current-linebreak-separator)])
((txexpr-elements?) ((or/c txexpr-element? (txexpr-element? txexpr-element? . -> . txexpr-element?)) #:separator string?) . ->* . txexpr-elements?)
(define linebreak-proc (if (procedure? maybe-linebreak-proc)
maybe-linebreak-proc
(λ (e1 e2) maybe-linebreak-proc)))
(define elems-vec (list->vector elems))
(filter identity
(for/list ([(item i) (in-indexed elems-vec)])
(cond
[(or (= i 0) (= i (sub1 (vector-length elems-vec)))) item] ; pass through first & last items
[(equal? item newline)
(let ([prev (vector-ref elems-vec (sub1 i))]
[next (vector-ref elems-vec (add1 i))])
;; only convert if neither adjacent tag is a block
;; (because blocks automatically force a newline before & after)
(if (or (block-txexpr? prev) (block-txexpr? next))
#f ; flag for filtering
(linebreak-proc prev next)))]
[else item]))))
(module-test-external
(check-equal? (decode-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar"))
(check-equal? (decode-linebreaks '("\n" "foo" "\n" "bar" "\n")) '("\n" "foo" (br) "bar" "\n"))
(check-equal? (decode-linebreaks '((p "foo") "\n" (p "bar"))) '((p "foo") (p "bar")))
(check-equal? (decode-linebreaks '("foo" "\n" (p "bar"))) '("foo" (p "bar")))
(check-equal? (decode-linebreaks '("foo" "moo" "bar")) '("foo" "moo" "bar"))
(check-equal? (decode-linebreaks '("foo" "moo" "bar") "moo") '("foo" "moo" "bar"))
(check-equal? (decode-linebreaks '("foo" "\n\n" "bar")) '("foo" "\n\n" "bar")))
;; Find adjacent newline characters in a list and merge them into one item
;; Scribble, by default, makes each newline a separate list item.
(define+provide/contract (merge-newlines x)
(txexpr-elements? . -> . txexpr-elements?)
(define newline-pat (regexp (format "^~a+$" (world:current-newline))))
(define (newlines? x) (and (string? x) (regexp-match newline-pat x)))
(define (merge-if-newlines xs)
(if (newlines? (car xs))
(list (apply string-append xs))
xs))
(let loop ([x x])
(if (pair? x)
(let ([xs (map loop x)])
(append-map merge-if-newlines (slicef xs newlines?)))
x)))
(module-test-external
(require racket/list)
(check-equal? (merge-newlines empty) empty)
(check-equal? (merge-newlines '(p "\n" "\n" "foo" "\n" "\n\n" "bar" (em "\n" "\n" "\n")))
'(p "\n\n" "foo" "\n\n\n" "bar" (em "\n\n\n"))))
;; detect paragraphs
;; todo: unit tests
(define+provide/contract (decode-paragraphs elements [maybe-wrap-proc 'p]
#:linebreak-proc [linebreak-proc decode-linebreaks]
#:force? [force-paragraph #f])
((txexpr-elements?) ((or/c txexpr-tag? ((listof xexpr?) . -> . txexpr?))
#:linebreak-proc (txexpr-elements? . -> . txexpr-elements?)
#:force? boolean?)
. ->* . txexpr-elements?)
(define (prep-paragraph-flow elems)
(linebreak-proc (merge-newlines (trimf elems whitespace?))))
(define (paragraph-break? x)
(define paragraph-separator (world:current-paragraph-separator))
(define paragraph-pattern (pregexp (format "^~a+$" paragraph-separator)))
(and (string? x) (regexp-match paragraph-pattern x)))
(define (explicit-or-implicit-paragraph-break? x)
(or (paragraph-break? x) (block-txexpr? x)))
(define wrap-proc (if (procedure? maybe-wrap-proc)
maybe-wrap-proc
(λ(elems) (list* maybe-wrap-proc elems))))
(define (wrap-paragraph elems)
(if (andmap block-txexpr? elems)
elems ; leave a series of block xexprs alone
(list (wrap-proc elems)))) ; otherwise wrap in p tag
(let ([elements (prep-paragraph-flow elements)])
(if (ormap explicit-or-implicit-paragraph-break? elements) ; need this condition to prevent infinite recursion
;; use append-map on wrap-paragraph rather than map to permit return of multiple elements
(append-map wrap-paragraph (append-map (λ(es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
(if force-paragraph
(append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs
elements))))
(module-test-external
(check-equal? (decode-paragraphs '("First para" "\n\n" "Second para"))
'((p "First para") (p "Second para")))
(check-equal? (decode-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line"))
'((p "First para") (p "Second para" (br) "Second line")))
(check-equal? (decode-paragraphs '("First para" "\n\n" (div "Second block")))
'((p "First para") (div "Second block")))
(check-equal? (decode-paragraphs '((div "First block") "\n\n" (div "Second block")))
'((div "First block") (div "Second block")))
(check-equal? (decode-paragraphs '("First para" "\n\n" "Second para") 'ns:p)
'((ns:p "First para") (ns:p "Second para")))
(check-equal? (decode-paragraphs '("First para" "\n\n" "Second para" "\n" "Second line")
#:linebreak-proc (λ(x) (decode-linebreaks x '(newline))))
'((p "First para") (p "Second para" (newline) "Second line")))
(check-equal? (decode-paragraphs '("foo" "\n\n" (div "bar") (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (decode-paragraphs '("foo" "\n\n" (div "bar") "\n\n" (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (decode-paragraphs '("foo")) '("foo"))
(check-equal? (decode-paragraphs '("foo") #:force? #t) '((p "foo")))
(check-equal? (decode-paragraphs '((div "foo"))) '((div "foo")))
(check-equal? (decode-paragraphs '((div "foo")) #:force? #t) '((div "foo")))
(check-equal? (decode-paragraphs '("foo" "\n\n" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (decode-paragraphs '("foo" (div "bar"))) '((p "foo") (div "bar")))
(check-equal? (decode-paragraphs '("foo" (div "bar")) #:force? #t) '((p "foo") (div "bar")))
(check-equal? (decode-paragraphs '("foo" (div "bar") "zam")) '((p "foo") (div "bar") (p "zam")))
(check-equal? (decode-paragraphs '("foo" (span "zing") (div "bar") "zam")) '((p "foo" (span "zing")) (div "bar") (p "zam")))
(check-equal? (decode-paragraphs '("foo" (span "zing") (div "bar") "zam") #:force? #t) '((p "foo" (span "zing")) (div "bar") (p "zam"))))
(define+provide detect-paragraphs decode-paragraphs) ; bw compat
(define+provide detect-linebreaks decode-linebreaks) ; bw compat

@ -0,0 +1,52 @@
#lang racket/base
(require sugar/test racket/require (matching-identifiers-in #rx"-source\\?$" "private/file-utils.rkt")
(matching-identifiers-in #rx"-source-path$" "private/file-utils.rkt")
(matching-identifiers-in #rx"^get.*-source$" "private/file-utils.rkt")
(only-in "private/file-utils.rkt" ->output-path))
(provide (all-from-out "private/file-utils.rkt"))
;; do the tests here to verify that the right functions are available through file.rkt
(module-test-external
(require sugar/coerce pollen/world)
(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"))
(check-true (pagetree-source? (format "foo.~a" (world:current-pagetree-source-ext))))
(check-false (pagetree-source? (format "~a.foo" (world:current-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-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"))
(check-true (markdown-source? "foo.html.pmd"))
(check-false (markdown-source? "foo.html"))
(check-false (markdown-source? #f))
(check-equal? (->markdown-source-path (->path "foo.pmd")) (->path "foo.pmd"))
(check-equal? (->markdown-source-path (->path "foo.html")) (->path "foo.html.pmd"))
(check-equal? (->markdown-source-path "foo") (->path "foo.pmd"))
(check-equal? (->markdown-source-path 'foo) (->path "foo.pmd"))
(check-false (get-source 42))
(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? (->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? (->output-path "foo.poly.pm") (->path "foo.html"))
(check-equal? (->output-path "foo_poly.pp") (->path "foo.html")))

@ -0,0 +1,7 @@
#lang info
(define scribblings '(("scribblings/pollen.scrbl" (multi-page))))
(define raco-commands '(("pollen" (submod pollen/private/command raco) "issue Pollen command" #f)))
(define compile-omit-paths '("test" "tools" "server-extras" "scribblings/third-tutorial-files"))
;; it's redundant to test "pollen.scrbl" because it incorporates the other scribble sources by reference
(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl"))
(define module-suffixes '(#"pp" #"pm" #"pmd" #"ptree"))

@ -0,0 +1,8 @@
#lang racket/base
(require "private/main-base.rkt")
(define+provide-module-begin-in-mode world:mode-preproc) ; because default mode in submodule is preproc
(module reader racket/base
(require pollen/private/reader-base)
(define+provide-reader-in-mode world:mode-auto)) ; because default mode in file is auto

@ -0,0 +1,8 @@
#lang racket/base
(require "private/main-base.rkt")
(define+provide-module-begin-in-mode world:mode-markdown)
(module reader racket/base
(require pollen/private/reader-base)
(define+provide-reader-in-mode world:mode-markdown))

@ -0,0 +1,8 @@
#lang racket/base
(require "private/main-base.rkt")
(define+provide-module-begin-in-mode world:mode-markup)
(module reader racket/base
(require pollen/private/reader-base)
(define+provide-reader-in-mode world:mode-markup))

@ -0,0 +1,3 @@
#lang racket/base
(require pollen/unstable/mb)
(provide smart-quotes smart-dashes)

@ -7,6 +7,11 @@ So this file
a) adapts the at-exp metalang from 6.2
b) incorporates the scribble/reader from 6.2
so that everything will work correctly in 6.0.
Note that pollen/mode uses world:command-char, NOT (world:current-command-char),
because doing so would create a loading loop if pollen/mode were used in "pollen.rkt"
(which is a likely place to use it)
Intractable problem, unavoiable limitation.
|#

@ -1,14 +1,15 @@
#lang racket/base
(require racket/path racket/list)
(require "file.rkt" "world.rkt" "decode.rkt" sugar txexpr "cache.rkt")
(require racket/path racket/list sugar txexpr)
(require "world.rkt"
"private/whitespace.rkt"
"private/file-utils.rkt"
"decode.rkt"
"cache.rkt")
(define+provide current-pagetree (make-parameter #f))
(define+provide (pagenode? x)
(->boolean (and (symbol? x) (with-handlers ([exn:fail? (λ(e) #f)])
(not (whitespace/nbsp? (->string x)))))))
(and (symbol? x) (not (whitespace/nbsp? (symbol->string x))) #t))
(module-test-external
(check-false (pagenode? "foo-bar"))
@ -21,18 +22,19 @@
(check-false (pagenode? " ")))
(define+provide (pagenodes? x)
;; for contracts: faster than (listof pagenode?)
(define (pagenodes? x)
(and (list? x) (andmap pagenode? x)))
(define+provide (pagenodeish? x)
(with-handlers ([exn:fail? (λ(e) #f)])
(pagenode? (->symbol x))))
(and (->pagenode x) #t)))
(define/contract+provide (->pagenode x)
(pagenodeish? . -> . pagenode?)
(->symbol x))
(define+provide (->pagenode x)
(with-handlers ([exn:fail? (λ(e) (raise-argument-error '->pagenode "can't convert input to pagenode" x))])
(->symbol x)))
(define+provide/contract (decode-pagetree xs)
@ -52,17 +54,17 @@
(define+provide (validate-pagetree x)
(and (txexpr? x)
(let ([pagenodes (pagetree->list x)])
(and
(andmap (λ(p) (or (pagenode? p) (error (format "validate-pagetree: \"~a\" is not a valid pagenode" p)))) pagenodes)
(with-handlers ([exn:fail? (λ(e) (error (format "validate-pagetree: ~a" (exn-message e))))])
(members-unique?/error pagenodes))
x))))
(for ([p (in-list pagenodes)]
#:when (not (pagenode? p)))
(error 'validate-pagetree (format "\"~a\" is not a valid pagenode" p)))
(with-handlers ([exn:fail? (λ(e) (error 'validate-pagetree (format "~a" (exn-message e))))])
(members-unique?/error pagenodes))
x)))
(define+provide (pagetree? x)
(with-handlers ([exn:fail? (λ(e) #f)])
(->boolean (validate-pagetree x))))
(and (validate-pagetree x) #t)))
(module-test-external
(check-true (pagetree? '(foo)))
@ -78,7 +80,7 @@
(define (unique-sorted-output-paths xs)
(define output-paths (map ->output-path xs))
(define all-paths (filter visible? (remove-duplicates output-paths)))
(define all-paths (filter path-visible? (remove-duplicates output-paths)))
(define path-is-directory? (λ(f) (directory-exists? (build-path dir f))))
(define-values (subdirectories files) (partition path-is-directory? all-paths))
(define-values (pagetree-sources other-files) (partition pagetree-source? files))
@ -93,14 +95,17 @@
(define (not-pollen-cache? path)
(not (member (->string path) world:cache-names)))
(if (directory-exists? dir )
(decode-pagetree (map ->symbol (unique-sorted-output-paths (filter not-pollen-cache? (directory-list dir)))))
(error (format "directory->pagetree: directory ~a doesn't exist" dir))))
(unless (directory-exists? dir)
(error 'directory->pagetree (format "directory ~v doesn't exist" dir)))
(decode-pagetree (map ->pagenode (unique-sorted-output-paths (filter not-pollen-cache? (directory-list dir))))))
(define+provide/contract (load-pagetree source-path)
(define+provide/contract (get-pagetree source-path)
(pathish? . -> . pagetree?)
(cached-require source-path (world:current-main-export)))
(cached-doc source-path))
(define+provide load-pagetree get-pagetree) ; bw compat
;; Try loading from pagetree file, or failing that, synthesize pagetree.
@ -120,14 +125,13 @@
(let loop ([pagenode (->pagenode pnish)][subtree pt])
(define current-parent (car subtree))
(define current-children (cdr subtree))
(if (member pagenode (map topmost-node current-children))
(if (memq pagenode (map topmost-node current-children))
current-parent
(ormap (λ(st) (loop pagenode st)) (filter subtree? current-children))))))
(if (eq? result (car pt))
(and allow-root? result)
result))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
(check-equal? (parent 'three test-pagetree) 'two)
@ -141,7 +145,7 @@
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenodes?))
(and pt p
(let ([pagenode (->pagenode p)])
(if (equal? pagenode (car pt))
(if (eq? pagenode (car pt))
(map (λ(x) (if (list? x) (car x) x)) (cdr pt))
(ormap (λ(x) (children pagenode x)) (filter list? pt))))))
@ -171,7 +175,7 @@
(define+provide/contract (pagetree->list pt)
(pagetree? . -> . pagenodes?)
; use cdr to get rid of root tag at front
(cdr (flatten pt)))
(flatten (cdr pt)))
(module-test-external
(define test-pagetree `(pagetree-main foo bar (one (two three))))
@ -182,10 +186,11 @@
#;(symbol? pagenodeish? pagetree? . -> . pagenodes?)
(and pt pnish
(let* ([pagenode (->pagenode pnish)]
[proc (if (equal? side 'left) takef takef-right)]
[proc (if (eq? side 'left) takef takef-right)]
[pagetree-nodes (pagetree->list pt)]
[in-tree? (member pagenode pagetree-nodes)]
[result (and in-tree? (proc pagetree-nodes (λ(x) (not (equal? pagenode x)))))])
;; using `in-pagetree?` would require another flattening
[in-tree? (memq pagenode pagetree-nodes)]
[result (and in-tree? (proc pagetree-nodes (λ(x) (not (eq? pagenode x)))))])
(and (not (empty? result)) result))))
(module-test-internal
@ -247,4 +252,4 @@
(define+provide/contract (in-pagetree? pnish [pt (current-pagetree)])
(((or/c #f pagenodeish?)) (pagetree?) . ->* . boolean?)
(->boolean (and pnish (member pnish (pagetree->list pt)))))
(and pnish (memq pnish (pagetree->list pt)) #t))

@ -0,0 +1,8 @@
#lang racket/base
(require "private/main-base.rkt")
(define+provide-module-begin-in-mode world:mode-preproc)
(module reader racket/base
(require pollen/private/reader-base)
(define+provide-reader-in-mode world:mode-preproc))