various tidying. all files compile now.

pull/9/head
Matthew Butterick 12 years ago
parent b5a5e731a1
commit e217077aee

@ -1,38 +1,35 @@
#lang racket #lang racket
(require (for-syntax "readability.rkt"))
(define-syntax (handle-pollen-command stx) (define-syntax (handle-pollen-command stx)
(datum->syntax stx (datum->syntax stx
(let ([arg (if (= (vector-length (current-command-line-arguments)) 0) (let* ([args (current-command-line-arguments)]
"" [arg (if (> (len args) 0) (get args 0) "")])
(vector-ref (current-command-line-arguments) 0))])
(case arg (case arg
[("serve") [("serve") `(require "server.rkt")]
`(require "server.rkt")] [("regenerate") `(begin
[("regenerate")
`(begin
(displayln "Regenerate all...") (displayln "Regenerate all...")
(require "regenerate.rkt") (require "regenerate.rkt")
(regenerate-all-files))] (regenerate-all-files))]
[("clone") [("clone") (let ([target-path
(let ([target-path (if (> (vector-length (current-command-line-arguments)) 1) (if (> (len args) 1)
(string->path (vector-ref (current-command-line-arguments) 1)) (->path (get args 1))
(build-path (find-system-path 'desk-dir) (string->path "clone")))]) (build-path (find-system-path 'desk-dir) (->path "clone")))])
`(begin `(begin
(displayln "Clone & bone...") (displayln "Clone & prune ...")
(require racket/file) (require racket/file)
(require "tools.rkt") (require "tools.rkt")
(define (pollen-related-file? file) (define (pollen-related-file? file)
(any (list (ormap (λ(proc) (proc file)) (list
pollen-source? pollen-source?
preproc-source? preproc-source?
template-source? template-source?
pmap-source? pmap-source?
pollen-script? pollen-script?
magic-directory? magic-directory?
racket-file?) racket-file?)))
file))
(define (delete-it path) (define (delete-it path)
(when (directory-exists? path) (when (directory-exists? path)
@ -48,10 +45,9 @@
(map delete-it (find-files pollen-related-file? target-dir)) (map delete-it (find-files pollen-related-file? target-dir))
(displayln (format "Completed to ~a" ,target-path)) (displayln (format "Completed to ~a" ,target-path))
)))] )))]
[("") [("") `(displayln "No command given")]
`(displayln "No command given")] ;; treat other input as a possible file name for regeneration
[else [else (let ([possible-file (->path arg)])
(let ([possible-file (string->path arg)])
(if (file-exists? possible-file) (if (file-exists? possible-file)
`(begin `(begin
(require (planet mb/pollen/regenerate)) (require (planet mb/pollen/regenerate))

@ -6,20 +6,27 @@
(module+ test (require rackunit)) (module+ test (require rackunit))
(require "tools.rkt") (require "tools.rkt")
(require (prefix-in html: "library/html.rkt"))
(provide (all-defined-out)) (provide (all-defined-out))
;; split list into list of sublists using test-proc ;; split list into list of sublists using test-proc
(define/contract (splitf-at* xs test-proc) (define/contract (splitf-at* xs split-test)
(list? procedure? . -> . (λ(i) (match i [(list (? list?) ...) #t][else #f]))) ;; todo: better error message when split-test is not a predicate
(define (&splitf-at* pieces [acc '()]) ; use acc for tail recursion (list? predicate/c . -> . (listof list?))
(if (empty? pieces) (define (&splitf-at* xs [acc '()]) ; use acc for tail recursion
acc (if (empty? xs)
;; reverse because accumulation is happening backward
;; (because I'm using cons to push latest match onto front of list)
(reverse acc)
(let-values ([(item rest) (let-values ([(item rest)
(splitf-at (dropf pieces test-proc) (compose1 not test-proc))]) ;; drop matching elements from front
(&splitf-at* rest `(,@acc ,item))))) ;; then split on nonmatching
(&splitf-at* (trim xs test-proc))) ;; = nonmatching item + other elements (which will start with matching)
(splitf-at (dropf xs split-test) (compose1 not split-test))])
;; recurse, and store new item in accumulator
(&splitf-at* rest (cons item acc)))))
;; trim off elements matching split-test
(&splitf-at* (trim xs split-test)))
(module+ test (module+ test
(check-equal? (splitf-at* '(1 2 3 4 5 6) even?) '((1)(3)(5))) (check-equal? (splitf-at* '(1 2 3 4 5 6) even?) '((1)(3)(5)))
@ -60,26 +67,10 @@
'(p "\n" "foo" "\n\n" "bar" (em "\n\n\n")))) '(p "\n" "foo" "\n\n" "bar" (em "\n\n\n"))))
(define block-tags html:block-tags)
(define (register-block-tag tag)
(set! block-tags (cons tag block-tags)))
;; todo: add native support for list-xexpr ;; todo: add native support for list-xexpr
;; decode triple newlines to list items ;; decode triple newlines to list items
;; is the tagged-xexpr a block element (as opposed to inline)
;; tags are inline unless they're registered as block tags.
(define/contract (block-xexpr? x)
(any/c . -> . boolean?)
((tagged-xexpr? x) . and . (->boolean ((tagged-xexpr-tag x) . in? . block-tags))))
(module+ test
(check-true (block-xexpr? '(p "foo")))
(check-true (block-xexpr? '(div "foo")))
(check-false (block-xexpr? '(em "foo")))
(check-false (block-xexpr? '(barfoo "foo")))
(check-true (begin (register-block-tag 'barfoo) (block-xexpr? '(barfoo "foo")))))
;; convert numbers to strings ;; convert numbers to strings
;; maybe this isn't necessary ;; maybe this isn't necessary
@ -90,19 +81,6 @@
(check-equal? (stringify '(p 1 2 "foo" (em 4 "bar"))) '(p "1" "2" "foo" (em "4" "bar")))) (check-equal? (stringify '(p 1 2 "foo" (em 4 "bar"))) '(p "1" "2" "foo" (em "4" "bar"))))
(module+ test
(check-true (whitespace? " "))
(check-false (whitespace? "foo"))
(check-false (whitespace? " ")) ; a nonbreaking space
(check-true (whitespace? "\n \n"))
(check-true (whitespace? (list "\n" " " "\n")))
(check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n")))))
;; trim from beginning & end of list ;; trim from beginning & end of list
(define (trim items test-proc) (define (trim items test-proc)
(list? procedure? . -> . list?) (list? procedure? . -> . list?)
@ -113,9 +91,6 @@
(check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))) (check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8)))
;; decoder wireframe ;; decoder wireframe
(define/contract (decode nx (define/contract (decode nx
#:exclude-xexpr-tags [excluded-xexpr-tags '()] #:exclude-xexpr-tags [excluded-xexpr-tags '()]
@ -126,7 +101,7 @@
#:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)] #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
#:string-proc [string-proc (λ(x)x)]) #:string-proc [string-proc (λ(x)x)])
;; use xexpr/c for contract because it gives better error messages ;; use xexpr/c for contract because it gives better error messages
((xexpr/c) (#:exclude-xexpr-tags (λ(i) (or (symbol? i) (list? i))) ((xexpr/c) (#:exclude-xexpr-tags list?
#:xexpr-tag-proc procedure? #:xexpr-tag-proc procedure?
#:xexpr-attr-proc procedure? #:xexpr-attr-proc procedure?
#:xexpr-elements-proc procedure? #:xexpr-elements-proc procedure?
@ -141,18 +116,20 @@
(define (&decode x) (define (&decode x)
(cond (cond
[(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)]) [(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)])
(if (tag . in? . (->list excluded-xexpr-tags)) (if (tag . in? . excluded-xexpr-tags)
x x ; let x pass through untouched
(let ([decoded-xexpr (let ([decoded-xexpr (apply make-tagged-xexpr
(apply make-tagged-xexpr (map &decode (list tag attr elements)))]) (map &decode (list tag attr elements)))])
((if (block-xexpr? decoded-xexpr) ((if (block-xexpr? decoded-xexpr)
block-xexpr-proc block-xexpr-proc
inline-xexpr-proc) decoded-xexpr))))] inline-xexpr-proc) decoded-xexpr))))]
[(xexpr-tag? x) (xexpr-tag-proc x)] [(xexpr-tag? x) (xexpr-tag-proc x)]
[(xexpr-attr? x) (xexpr-attr-proc x)] [(xexpr-attr? x) (xexpr-attr-proc x)]
;; need this for operations that may depend on context in list
[(xexpr-elements? x) (map &decode (xexpr-elements-proc x))] [(xexpr-elements? x) (map &decode (xexpr-elements-proc x))]
[(string? x) (string-proc x)] [(string? x) (string-proc x)]
[else x])) ;; if something has made it through undecoded, that's a problem
[else (error "Can't decode" x)]))
(&decode nx)) (&decode nx))

@ -20,7 +20,7 @@
; doclang2_raw is a clone of scribble/doclang2 with decode disabled ; doclang2_raw is a clone of scribble/doclang2 with decode disabled
; helpful because it collects & exports content via 'doc ; helpful because it collects & exports content via 'doc
(module pollen-inner (planet mb/pollen/doclang2_raw) (module pollen-inner (planet mb/pollen/lang/doclang2_raw)
; use same requires as top of main.rkt ; use same requires as top of main.rkt
; (can't import them from surrounding module due to submodule rules) ; (can't import them from surrounding module due to submodule rules)
(require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (require (planet mb/pollen/tools) (planet mb/pollen/main-helper))

@ -0,0 +1,121 @@
#lang racket/base
(require racket/contract)
(require (only-in racket/path filename-extension))
(require "world.rkt" "readability.rkt")
(provide (all-defined-out))
(module+ test (require rackunit))
;; does path have a certain extension
(define/contract (has-ext? path ext)
(path? symbol? . -> . boolean?)
(define ext-of-path (filename-extension path))
(and ext-of-path (equal? (bytes->string/utf-8 ext-of-path) (->string ext))))
(module+ test
(define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
(define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path)
(apply values (map string->path foo-path-strings)))
;; test the sample paths before using them for other tests
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
(for-each check-equal? (map path->string foo-paths) foo-path-strings))
(module+ test
(check-false (has-ext? foo-path 'txt))
(check-true (has-ext? foo.txt-path 'txt))
(check-true (has-ext? foo.bar.txt-path 'txt))
(check-false (has-ext? foo.bar.txt-path 'doc))) ; wrong extension
;; get file extension as a string
(define/contract (get-ext path)
(path? . -> . string?)
(bytes->string/utf-8 (filename-extension path)))
(module+ test
(check-equal? (get-ext (->path "foo.txt")) "txt")
;; todo: how should get-ext handle input that has no extension?
;(check-equal? (get-ext (->path "foo")) "")
)
;; put extension on path
(define/contract (add-ext path ext)
(path? (or/c symbol? string?) . -> . path?)
(string->path (string-append (->string path) "." (->string ext))))
(module+ test
(check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")))
;; take one extension off path
(define/contract (remove-ext path)
(path? . -> . path?)
(path-replace-suffix path ""))
(module+ test
(check-equal? (remove-ext foo-path) foo-path)
(check-equal? (remove-ext foo.txt-path) foo-path)
(check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
(check-not-equal? (remove-ext foo.bar.txt-path) foo-path)) ; does not remove all extensions
;; take all extensions off path
(define/contract (remove-all-ext path)
(path? . -> . path?)
(define path-with-removed-ext (remove-ext path))
(if (equal? path path-with-removed-ext)
path
(remove-all-ext path-with-removed-ext)))
(module+ test
(check-equal? (remove-all-ext foo-path) foo-path)
(check-equal? (remove-all-ext foo.txt-path) foo-path)
(check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext
(check-equal? (remove-all-ext foo.bar.txt-path) foo-path))
(define/contract (preproc-source? x)
(any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_PREPROC_EXT))
(define/contract (has-preproc-source? x)
(any/c . -> . boolean?)
(file-exists? (make-preproc-in-path (->path x))))
(define/contract (has-pollen-source? x)
(any/c . -> . boolean?)
(file-exists? (make-pollen-source-path (->path x))))
(define/contract (needs-preproc? x)
(any/c . -> . boolean?)
; it's a preproc source file, or a file that's the result of a preproc source
(ormap (λ(proc) (proc (->path x))) (list preproc-source? has-preproc-source?)))
(define/contract (needs-template? x)
(any/c . -> . boolean?)
; it's a pollen source file
; or a file (e.g., html) that has a pollen source file
(ormap (λ(proc) (proc (->path x))) (list pollen-source? has-pollen-source?)))
(define/contract (pmap-source? x)
(any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_MAP_EXT))
(define/contract (pollen-source? x)
(any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_SOURCE_EXT))
(define/contract (make-preproc-in-path path)
(path? . -> . path?)
(add-ext path POLLEN_PREPROC_EXT))
(define/contract (make-preproc-out-path path)
(path? . -> . path?)
(remove-ext path))
(define/contract (make-pollen-source-path thing)
(path? . -> . path?)
(add-ext (remove-ext (->path thing)) POLLEN_SOURCE_EXT))

@ -0,0 +1,131 @@
#lang racket/base
(require racket/contract racket/match racket/list xml)
(require (prefix-in scribble: (only-in scribble/decode whitespace?)))
(require (prefix-in html: "library/html.rkt"))
(require "world.rkt" "readability.rkt" "pollen-file-tools.rkt")
(module+ test (require rackunit))
(provide (all-defined-out)
(all-from-out "pollen-file-tools.rkt"))
;; add a block tag to the list
;; this function is among the predicates because it alters a predicate globally.
(define/contract (register-block-tag tag)
(symbol? . -> . void?)
(set! block-tags (cons tag block-tags)))
;; initial set of block tags: from html
(define block-tags html:block-tags)
;; is the tagged-xexpr a block element (as opposed to inline)
;; tags are inline unless they're registered as block tags.
(define/contract (block-xexpr? x)
(any/c . -> . boolean?)
((tagged-xexpr? x) . and . (->boolean ((car x) . in? . block-tags))))
(module+ test
(check-true (block-xexpr? '(p "foo")))
(check-true (block-xexpr? '(div "foo")))
(check-false (block-xexpr? '(em "foo")))
(check-false (block-xexpr? '(barfoo "foo")))
(check-true (begin (register-block-tag 'barfoo) (block-xexpr? '(barfoo "foo")))))
;; is it an xexpr tag?
(define/contract (xexpr-tag? x)
(any/c . -> . boolean?)
(symbol? x))
;; is it an xexpr attributes?
(define/contract (xexpr-attr? x)
(any/c . -> . boolean?)
(match x
; list of symbol + string pairs
[(list (list (? symbol? key) (? string? value)) ...) #t]
[else #f]))
(module+ test
(check-true (xexpr-attr? empty))
(check-true (xexpr-attr? '((key "value"))))
(check-true (xexpr-attr? '((key "value") (foo "bar"))))
(check-false (xexpr-attr? '((key "value") "foo" "bar"))) ; content, not attr
(check-false (xexpr-attr? '(key "value"))) ; not a nested list
(check-false (xexpr-attr? '(("key" "value")))) ; two strings
(check-false (xexpr-attr? '((key value))))) ; two symbols
;; is it xexpr content?
(define/contract (xexpr-element? x)
(any/c . -> . boolean?)
(or (string? x) (tagged-xexpr? x)))
(define/contract (xexpr-elements? x)
(any/c . -> . boolean?)
(match x
;; this is more strict than xexpr definition in xml module
;; don't allow symbols or numbers to be part of content
[(list elem ...) (andmap xexpr-element? elem)]
[else #f]))
(module+ test
(check-true (xexpr-elements? '("p" "foo" "123")))
(check-false (xexpr-elements? "foo")) ; not a list
(check-false (xexpr-elements? '("p" "foo" 123))) ; includes number
(check-false (xexpr-elements? '(p "foo" "123"))) ; includes symbol
(check-false (xexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr
(check-false (xexpr-elements? '("foo" "bar" ((key "value")))))) ; malformed
;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define/contract (tagged-xexpr? x)
(any/c . -> . boolean?)
(and (xexpr? x) ; meets basic xexpr contract
(match x
[(list (? symbol? name) rest ...) ; is a list starting with a symbol
(or (xexpr-elements? rest) ; the rest is content or ...
(and (xexpr-attr? (car rest)) (xexpr-elements? (cdr rest))))] ; attr + content
[else #f])))
(module+ test
(check-true (tagged-xexpr? '(p "foo" "bar")))
(check-true (tagged-xexpr? '(p ((key "value")) "foo" "bar")))
(check-false (tagged-xexpr? "foo")) ; not a list with symbol
(check-false (tagged-xexpr? '(p "foo" "bar" ((key "value"))))) ; malformed
(check-false (tagged-xexpr? '("p" "foo" "bar"))) ; no name
(check-false (tagged-xexpr? '(p 123)))) ; content is a number
;; test for well-formed meta
(define/contract (meta-xexpr? x)
(any/c . -> . boolean?)
(match x
[`(meta ,(? string? key) ,(? string? value)) #t]
[else #f]))
(module+ test
(check-true (meta-xexpr? '(meta "key" "value")))
(check-false (meta-xexpr? '(meta "key" "value" "foo")))
(check-false (meta-xexpr? '(meta))))
;; recursive whitespace test
;; Scribble's version misses whitespace in a list
(define (whitespace? x)
(cond
[(list? x) (andmap whitespace? x)]
[else (scribble:whitespace? x)]))
(module+ test
(check-true (whitespace? " "))
(check-false (whitespace? "foo"))
(check-false (whitespace? " ")) ; a nonbreaking space
(check-true (whitespace? "\n \n"))
(check-true (whitespace? (list "\n" " " "\n")))
(check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n")))))

@ -197,3 +197,4 @@
(check-true ('o . in? . 'foobar)) (check-true ('o . in? . 'foobar))
(check-false ('z . in? . 'foobar)) (check-false ('z . in? . 'foobar))
(check-false ("F" . in? . #\F))) (check-false ("F" . in? . #\F)))

@ -69,39 +69,6 @@
(define (preproc-source? path)
(has-ext? path POLLEN_PREPROC_EXT))
(define (make-preproc-in-path path)
(add-ext path POLLEN_PREPROC_EXT))
(define (make-preproc-out-path path)
(remove-ext path))
(define (has-preproc-source? path)
(file-exists? (make-preproc-in-path path)))
(define (pollen-source? path)
(has-ext? path POLLEN_SOURCE_EXT))
(define (make-pollen-source-path thing)
(add-ext (remove-ext (->path thing)) POLLEN_SOURCE_EXT))
(define (has-pollen-source? path)
(file-exists? (make-pollen-source-path path)))
(define (needs-preproc? path)
; it's a preproc source file, or a file that's the result of a preproc source
(ormap (λ(proc) (proc path)) (list preproc-source? has-preproc-source?)))
(define (needs-template? path)
; it's a pollen source file
; or a file (e.g., html) that has a pollen source file
(ormap (λ(proc) (proc path)) (list pollen-source? has-pollen-source?)))
(define (pmap-source? path)
(has-ext? path POLLEN_MAP_EXT))
(define (regenerate path #:force [force #f]) (define (regenerate path #:force [force #f])
; dispatches path-in to the right place ; dispatches path-in to the right place
@ -176,8 +143,10 @@
;; todo: next ;; todo: next
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
(define meta-hash (make-meta-hash (put source-path))) (define metas (dynamic-require source-path 'metas))
(set! template-name (hash-ref-or meta-hash TEMPLATE_META_KEY DEFAULT_TEMPLATE))) (set! template-name (if (TEMPLATE_META_KEY . in? . metas)
(get metas TEMPLATE_META_KEY)
DEFAULT_TEMPLATE)))
(define template-path (build-path source-dir template-name)) (define template-path (build-path source-dir template-name))
; refresh template (it might have its own p file) ; refresh template (it might have its own p file)
(regenerate template-path #:force force) (regenerate template-path #:force force)

@ -51,8 +51,8 @@
(define path (build-path pollen-file-root filename)) (define path (build-path pollen-file-root filename))
(regenerate path) (regenerate path)
(dynamic-rerequire path) (dynamic-rerequire path)
(define-from path body) (define main (dynamic-require path 'main))
body) main)
(define (format-as-code data) (define (format-as-code data)
@ -73,19 +73,19 @@
(define (route-index req) (define (route-index req)
; set up filter functions by mapping a function-maker for each file type ; set up filter functions by mapping a function-maker for each file type
(define-values (pollen-file? preproc-file? pmap-file?) (define-values (pollen-file? preproc-file? pmap-file?)
(apply values (map (ƒ(ext)(ƒ(f)(has-ext? f ext))) (list POLLEN_SOURCE_EXT POLLEN_PREPROC_EXT POLLEN_MAP_EXT)))) (apply values (map (λ(ext)(λ(f)(has-ext? f ext))) (list POLLEN_SOURCE_EXT POLLEN_PREPROC_EXT POLLEN_MAP_EXT))))
(define (template-file? x) (define (template-file? x)
(define-values (dir name ignore) (split-path x)) (define-values (dir name ignore) (split-path x))
(=str (get (as-string name) 0) TEMPLATE_FILE_PREFIX)) (equal? (get (->string name) 0) TEMPLATE_FILE_PREFIX))
; get lists of files by mapping a filter function for each file type ; get lists of files by mapping a filter function for each file type
(define-values (pollen-files preproc-files pmap-files template-files) (define-values (pollen-files preproc-files pmap-files template-files)
(apply values (map (ƒ(test) (filter test (directory-list pollen-file-root))) (list pollen-file? preproc-file? pmap-file? template-file?)))) (apply values (map (λ(test) (filter test (directory-list pollen-file-root))) (list pollen-file? preproc-file? pmap-file? template-file?))))
; the actual post-p files may not have been generated yet ; the actual post-p files may not have been generated yet
(define post-preproc-files (map (ƒ(path) (remove-ext path)) preproc-files)) (define post-preproc-files (map (λ(path) (remove-ext path)) preproc-files))
; make a combined list of p-files and post-p files ; make a combined list of p-files and post-p files
(define all-preproc-files (sort (append preproc-files post-preproc-files) #:key path->string string<?)) (define all-preproc-files (sort (append preproc-files post-preproc-files) #:key path->string string<?))
(define post-pollen-files (map (ƒ(path) (add-ext (remove-ext path) 'html)) pollen-files)) (define post-pollen-files (map (λ(path) (add-ext (remove-ext path) 'html)) pollen-files))
(define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?)) (define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?))
@ -95,9 +95,9 @@
[preproc-source (add-ext file POLLEN_PREPROC_EXT)] [preproc-source (add-ext file POLLEN_PREPROC_EXT)]
[file-string (path->string file)] [file-string (path->string file)]
[name (case type [name (case type
['direct (str file-string)] ['direct (->string file-string)]
['preproc-source "source"] ['preproc-source "source"]
[else (str type)])] [else (->string type)])]
[target (case type [target (case type
['direct name] ['direct name]
[(source xexpr) (format "/~a/~a" type source)] [(source xexpr) (format "/~a/~a" type source)]
@ -107,7 +107,7 @@
`(td (a ((href ,target)) ,name)))) `(td (a ((href ,target)) ,name))))
`(tr ,(make-link-cell 'direct) ,@(map make-link-cell routes))) `(tr ,(make-link-cell 'direct) ,@(map make-link-cell routes)))
(if (all empty? (list pmap-files all-pollen-files all-preproc-files template-files)) (if (andmap empty? (list pmap-files all-pollen-files all-preproc-files template-files))
(response/xexpr '(body "No files yet. Get to work!")) (response/xexpr '(body "No files yet. Get to work!"))
(response/xexpr (response/xexpr
`(body `(body
@ -115,12 +115,12 @@
"td:hover {background: #eee}") "td:hover {background: #eee}")
(table ((style "font-family:Concourse T3;font-size:115%")) (table ((style "font-family:Concourse T3;font-size:115%"))
; options for pmap files and template files ; options for pmap files and template files
,@(map (ƒ(file) (make-file-row file '(raw))) (append pmap-files template-files)) ,@(map (λ(file) (make-file-row file '(raw))) (append pmap-files template-files))
; options for pollen files ; options for pollen files
,@(map (ƒ(file) (make-file-row file '(raw source xexpr force))) post-pollen-files) ,@(map (λ(file) (make-file-row file '(raw source xexpr force))) post-pollen-files)
; options for preproc files ; options for preproc files
; branching in ƒ is needed so these files can be interleaved on the list ; branching in λ is needed so these files can be interleaved on the list
,@(map (ƒ(file) (make-file-row file '(raw preproc-source))) post-preproc-files)))))) ,@(map (λ(file) (make-file-row file '(raw preproc-source))) post-preproc-files))))))
(displayln "Ready to rock") (displayln "Ready to rock")

@ -1,152 +1,22 @@
#lang racket/base #lang racket/base
(require racket/contract racket/match) (require racket/contract racket/match)
(require (only-in racket/path filename-extension))
(require (only-in racket/format ~a)) (require (only-in racket/format ~a))
(require racket/list) (require racket/list)
(require (only-in racket/string string-join)) (require (only-in racket/string string-join))
(require (only-in xml xexpr? xexpr/c)) (require (only-in xml xexpr? xexpr/c))
(require (prefix-in scribble: (only-in scribble/decode whitespace?)))
(require "readability.rkt" "debug.rkt") (require "readability.rkt" "debug.rkt" "predicates.rkt")
(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt")) (provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt"))
;; setup for test cases ;; setup for test cases
(module+ test (module+ test (require rackunit))
(require rackunit)
(define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
(define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (apply values (map string->path foo-path-strings)))
;; test the sample paths before using them for other tests
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
(for-each check-equal? (map path->string foo-paths) foo-path-strings))
;; recursive whitespace test
;; Scribble's version misses whitespace in a list
(define (whitespace? x)
(cond
[(list? x) (andmap whitespace? x)]
[else (scribble:whitespace? x)]))
; make these independent of local includes ; make these independent of local includes
(define (map-topic topic . subtopics) (define (map-topic topic . subtopics)
(make-tagged-xexpr (->symbol topic) empty (filter-not whitespace? subtopics))) (make-tagged-xexpr (->symbol topic) empty (filter-not whitespace? subtopics)))
;; does path have a certain extension
(define/contract (has-ext? path ext)
(path? symbol? . -> . boolean?)
(define ext-of-path (filename-extension path))
(and ext-of-path (equal? (bytes->string/utf-8 ext-of-path) (->string ext))))
(module+ test
(check-false (has-ext? foo-path 'txt))
(check-true (has-ext? foo.txt-path 'txt))
(check-true (has-ext? foo.bar.txt-path 'txt))
(check-false (has-ext? foo.bar.txt-path 'doc))) ; wrong extension
;; put extension on path
(define/contract (add-ext path ext)
(path? (or/c symbol? string?) . -> . path?)
(string->path (string-append (->string path) "." (->string ext))))
(module+ test
(check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")))
;; take one extension off path
(define/contract (remove-ext path)
(path? . -> . path?)
(path-replace-suffix path ""))
(module+ test
(check-equal? (remove-ext foo-path) foo-path)
(check-equal? (remove-ext foo.txt-path) foo-path)
(check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
(check-not-equal? (remove-ext foo.bar.txt-path) foo-path)) ; does not remove all extensions
;; take all extensions off path
(define/contract (remove-all-ext path)
(path? . -> . path?)
(define path-with-removed-ext (remove-ext path))
(if (equal? path path-with-removed-ext)
path
(remove-all-ext path-with-removed-ext)))
(module+ test
(check-equal? (remove-all-ext foo-path) foo-path)
(check-equal? (remove-all-ext foo.txt-path) foo-path)
(check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext
(check-equal? (remove-all-ext foo.bar.txt-path) foo-path))
;; is it an xexpr tag?
(define/contract (xexpr-tag? x)
(any/c . -> . boolean?)
(symbol? x))
;; is it an xexpr attributes?
(define/contract (xexpr-attr? x)
(any/c . -> . boolean?)
(match x
; list of symbol + string pairs
[(list (list (? symbol? key) (? string? value)) ...) #t]
[else #f]))
(module+ test
(check-true (xexpr-attr? empty))
(check-true (xexpr-attr? '((key "value"))))
(check-true (xexpr-attr? '((key "value") (foo "bar"))))
(check-false (xexpr-attr? '((key "value") "foo" "bar"))) ; content, not attr
(check-false (xexpr-attr? '(key "value"))) ; not a nested list
(check-false (xexpr-attr? '(("key" "value")))) ; two strings
(check-false (xexpr-attr? '((key value))))) ; two symbols
;; is it xexpr content?
(define/contract (xexpr-element? x)
(any/c . -> . boolean?)
(or (string? x) (tagged-xexpr? x)))
(define/contract (xexpr-elements? x)
(any/c . -> . boolean?)
(match x
;; this is more strict than xexpr definition in xml module
;; don't allow symbols or numbers to be part of content
[(list elem ...) (andmap xexpr-element? elem)]
[else #f]))
(module+ test
(check-true (xexpr-elements? '("p" "foo" "123")))
(check-false (xexpr-elements? "foo")) ; not a list
(check-false (xexpr-elements? '("p" "foo" 123))) ; includes number
(check-false (xexpr-elements? '(p "foo" "123"))) ; includes symbol
(check-false (xexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr
(check-false (xexpr-elements? '("foo" "bar" ((key "value")))))) ; malformed
;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define/contract (tagged-xexpr? x)
(any/c . -> . boolean?)
(and (xexpr? x) ; meets basic xexpr contract
(match x
[(list (? symbol? name) rest ...) ; is a list starting with a symbol
(or (xexpr-elements? rest) ; the rest is content or ...
(and (xexpr-attr? (car rest)) (xexpr-elements? (cdr rest))))] ; attr + content
[else #f])))
(module+ test
(check-true (tagged-xexpr? '(p "foo" "bar")))
(check-true (tagged-xexpr? '(p ((key "value")) "foo" "bar")))
(check-false (tagged-xexpr? "foo")) ; not a list with symbol
(check-false (tagged-xexpr? '(p "foo" "bar" ((key "value"))))) ; malformed
(check-false (tagged-xexpr? '("p" "foo" "bar"))) ; no name
(check-false (tagged-xexpr? '(p 123)))) ; content is a number
;; helper for comparison of values ;; helper for comparison of values
;; normal function won't work for this. Has to be syntax-rule ;; normal function won't work for this. Has to be syntax-rule
(define-syntax-rule (values->list vs) (define-syntax-rule (values->list vs)
@ -333,17 +203,6 @@
(list '(root "hello" "world" (em "goodnight" "moon")) (list '(root "hello" "world" (em "goodnight" "moon"))
'((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3"))))) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))))
;; test for well-formed meta
(define/contract (meta-xexpr? x)
(any/c . -> . boolean?)
(match x
[`(meta ,(? string? key) ,(? string? value)) #t]
[else #f]))
(module+ test
(check-true (meta-xexpr? '(meta "key" "value")))
(check-false (meta-xexpr? '(meta "key" "value" "foo")))
(check-false (meta-xexpr? '(meta))))
;; convert list of meta tags to a hash for export from pollen document. ;; convert list of meta tags to a hash for export from pollen document.

Loading…
Cancel
Save