From e217077aee453d8deda93bdfdad42af04eda80b3 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 16 Aug 2013 23:23:41 -0700 Subject: [PATCH] various tidying. all files compile now. --- command.rkt | 104 ++++++------- decode.rkt | 73 +++------ doclang2_raw.rkt => lang/doclang2_raw.rkt | 0 doclang_raw.rkt => lang/doclang_raw.rkt | 0 css.rkt => library/css.rkt | 0 hyphenate.py => library/hyphenate.py | 0 hyphenate.rkt => library/hyphenate.rkt | 0 .../hyphenation-data.rkt | 0 main.rkt | 4 +- pollen-file-tools.rkt | 121 ++++++++++++++ predicates.rkt | 131 ++++++++++++++++ readability.rkt | 5 +- regenerate.rkt | 39 +---- server.rkt | 28 ++-- tools.rkt | 147 +----------------- 15 files changed, 353 insertions(+), 299 deletions(-) rename doclang2_raw.rkt => lang/doclang2_raw.rkt (100%) rename doclang_raw.rkt => lang/doclang_raw.rkt (100%) rename css.rkt => library/css.rkt (100%) rename hyphenate.py => library/hyphenate.py (100%) rename hyphenate.rkt => library/hyphenate.rkt (100%) rename hyphenation-data.rkt => library/hyphenation-data.rkt (100%) create mode 100644 pollen-file-tools.rkt create mode 100644 predicates.rkt diff --git a/command.rkt b/command.rkt index 7df2dde..ebd7d37 100644 --- a/command.rkt +++ b/command.rkt @@ -1,61 +1,57 @@ #lang racket +(require (for-syntax "readability.rkt")) + (define-syntax (handle-pollen-command stx) (datum->syntax stx - (let ([arg (if (= (vector-length (current-command-line-arguments)) 0) - "" - (vector-ref (current-command-line-arguments) 0))]) + (let* ([args (current-command-line-arguments)] + [arg (if (> (len args) 0) (get args 0) "")]) (case arg - [("serve") - `(require "server.rkt")] - [("regenerate") - `(begin - (displayln "Regenerate all...") - (require "regenerate.rkt") - (regenerate-all-files))] - [("clone") - (let ([target-path (if (> (vector-length (current-command-line-arguments)) 1) - (string->path (vector-ref (current-command-line-arguments) 1)) - (build-path (find-system-path 'desk-dir) (string->path "clone")))]) - - `(begin - (displayln "Clone & bone...") - (require racket/file) - (require "tools.rkt") - - (define (pollen-related-file? file) - (any (list - pollen-source? - preproc-source? - template-source? - pmap-source? - pollen-script? - magic-directory? - racket-file?) - file)) - - (define (delete-it path) - (when (directory-exists? path) - (delete-directory/files path)) - (when (file-exists? path) - (delete-file path))) - - (let ([source-dir (current-directory)] - [target-dir ,target-path]) - (when (directory-exists? target-dir) - (delete-directory/files target-dir)) - (copy-directory/files source-dir target-dir) - (map delete-it (find-files pollen-related-file? target-dir)) - (displayln (format "Completed to ~a" ,target-path)) - )))] - [("") - `(displayln "No command given")] - [else - (let ([possible-file (string->path arg)]) - (if (file-exists? possible-file) - `(begin - (require (planet mb/pollen/regenerate)) - (regenerate ,possible-file)) - `(displayln (format "No command defined for ~a" ,arg))))])))) + [("serve") `(require "server.rkt")] + [("regenerate") `(begin + (displayln "Regenerate all...") + (require "regenerate.rkt") + (regenerate-all-files))] + [("clone") (let ([target-path + (if (> (len args) 1) + (->path (get args 1)) + (build-path (find-system-path 'desk-dir) (->path "clone")))]) + `(begin + (displayln "Clone & prune ...") + (require racket/file) + (require "tools.rkt") + + (define (pollen-related-file? file) + (ormap (λ(proc) (proc file)) (list + pollen-source? + preproc-source? + template-source? + pmap-source? + pollen-script? + magic-directory? + racket-file?))) + + (define (delete-it path) + (when (directory-exists? path) + (delete-directory/files path)) + (when (file-exists? path) + (delete-file path))) + + (let ([source-dir (current-directory)] + [target-dir ,target-path]) + (when (directory-exists? target-dir) + (delete-directory/files target-dir)) + (copy-directory/files source-dir target-dir) + (map delete-it (find-files pollen-related-file? target-dir)) + (displayln (format "Completed to ~a" ,target-path)) + )))] + [("") `(displayln "No command given")] + ;; treat other input as a possible file name for regeneration + [else (let ([possible-file (->path arg)]) + (if (file-exists? possible-file) + `(begin + (require (planet mb/pollen/regenerate)) + (regenerate ,possible-file)) + `(displayln (format "No command defined for ~a" ,arg))))])))) (handle-pollen-command) diff --git a/decode.rkt b/decode.rkt index 08100cf..ed6f810 100644 --- a/decode.rkt +++ b/decode.rkt @@ -6,20 +6,27 @@ (module+ test (require rackunit)) (require "tools.rkt") -(require (prefix-in html: "library/html.rkt")) (provide (all-defined-out)) - ;; split list into list of sublists using test-proc -(define/contract (splitf-at* xs test-proc) - (list? procedure? . -> . (λ(i) (match i [(list (? list?) ...) #t][else #f]))) - (define (&splitf-at* pieces [acc '()]) ; use acc for tail recursion - (if (empty? pieces) - acc +(define/contract (splitf-at* xs split-test) + ;; todo: better error message when split-test is not a predicate + (list? predicate/c . -> . (listof list?)) + (define (&splitf-at* xs [acc '()]) ; use acc for tail recursion + (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) - (splitf-at (dropf pieces test-proc) (compose1 not test-proc))]) - (&splitf-at* rest `(,@acc ,item))))) - (&splitf-at* (trim xs test-proc))) + ;; drop matching elements from front + ;; then split on nonmatching + ;; = 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 (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")))) -(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 ;; 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 ;; 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")))) - - - -(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 (define (trim items test-proc) (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))) - - - ;; decoder wireframe (define/contract (decode nx #:exclude-xexpr-tags [excluded-xexpr-tags '()] @@ -126,7 +101,7 @@ #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)] #:string-proc [string-proc (λ(x)x)]) ;; 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-attr-proc procedure? #:xexpr-elements-proc procedure? @@ -141,18 +116,20 @@ (define (&decode x) (cond [(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)]) - (if (tag . in? . (->list excluded-xexpr-tags)) - x - (let ([decoded-xexpr - (apply make-tagged-xexpr (map &decode (list tag attr elements)))]) + (if (tag . in? . excluded-xexpr-tags) + x ; let x pass through untouched + (let ([decoded-xexpr (apply make-tagged-xexpr + (map &decode (list tag attr elements)))]) ((if (block-xexpr? decoded-xexpr) block-xexpr-proc inline-xexpr-proc) decoded-xexpr))))] [(xexpr-tag? x) (xexpr-tag-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))] [(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)) diff --git a/doclang2_raw.rkt b/lang/doclang2_raw.rkt similarity index 100% rename from doclang2_raw.rkt rename to lang/doclang2_raw.rkt diff --git a/doclang_raw.rkt b/lang/doclang_raw.rkt similarity index 100% rename from doclang_raw.rkt rename to lang/doclang_raw.rkt diff --git a/css.rkt b/library/css.rkt similarity index 100% rename from css.rkt rename to library/css.rkt diff --git a/hyphenate.py b/library/hyphenate.py similarity index 100% rename from hyphenate.py rename to library/hyphenate.py diff --git a/hyphenate.rkt b/library/hyphenate.rkt similarity index 100% rename from hyphenate.rkt rename to library/hyphenate.rkt diff --git a/hyphenation-data.rkt b/library/hyphenation-data.rkt similarity index 100% rename from hyphenation-data.rkt rename to library/hyphenation-data.rkt diff --git a/main.rkt b/main.rkt index 2b36535..bfa2b4d 100644 --- a/main.rkt +++ b/main.rkt @@ -20,7 +20,7 @@ ; doclang2_raw is a clone of scribble/doclang2 with decode disabled ; 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 ; (can't import them from surrounding module due to submodule rules) (require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) @@ -82,4 +82,4 @@ (displayln "; pollen 'metas") (displayln ";-------------------------") metas - ))) + ))) diff --git a/pollen-file-tools.rkt b/pollen-file-tools.rkt new file mode 100644 index 0000000..fd7cdf4 --- /dev/null +++ b/pollen-file-tools.rkt @@ -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)) diff --git a/predicates.rkt b/predicates.rkt new file mode 100644 index 0000000..224baff --- /dev/null +++ b/predicates.rkt @@ -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"))))) + + diff --git a/readability.rkt b/readability.rkt index 45ea1cd..b865e7a 100644 --- a/readability.rkt +++ b/readability.rkt @@ -121,7 +121,7 @@ ;; general way of fetching an item from a container (define/contract (get container start [end #f]) ((gettable-container? any/c) ((λ(i)(or (integer? i) (and (symbol? i) (equal? i 'end))))) - . ->* . any/c) + . ->* . any/c) (set! end (if (sliceable-container? container) @@ -196,4 +196,5 @@ (check-false ("z" . in? . "foobar")) (check-true ('o . in? . 'foobar)) (check-false ('z . in? . 'foobar)) - (check-false ("F" . in? . #\F))) \ No newline at end of file + (check-false ("F" . in? . #\F))) + diff --git a/regenerate.rkt b/regenerate.rkt index 271b851..05c7708 100644 --- a/regenerate.rkt +++ b/regenerate.rkt @@ -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]) ; dispatches path-in to the right place @@ -176,8 +143,10 @@ ;; todo: next ;;;;;;;;;;;;;; - (define meta-hash (make-meta-hash (put source-path))) - (set! template-name (hash-ref-or meta-hash TEMPLATE_META_KEY DEFAULT_TEMPLATE))) + (define metas (dynamic-require source-path 'metas)) + (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)) ; refresh template (it might have its own p file) (regenerate template-path #:force force) diff --git a/server.rkt b/server.rkt index 9e89e90..cfa17b4 100755 --- a/server.rkt +++ b/server.rkt @@ -51,8 +51,8 @@ (define path (build-path pollen-file-root filename)) (regenerate path) (dynamic-rerequire path) - (define-from path body) - body) + (define main (dynamic-require path 'main)) + main) (define (format-as-code data) @@ -73,19 +73,19 @@ (define (route-index req) ; set up filter functions by mapping a function-maker for each file type (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-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 (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 - (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 (define all-preproc-files (sort (append preproc-files post-preproc-files) #:key path->string stringstring stringstring file)] [name (case type - ['direct (str file-string)] + ['direct (->string file-string)] ['preproc-source "source"] - [else (str type)])] + [else (->string type)])] [target (case type ['direct name] [(source xexpr) (format "/~a/~a" type source)] @@ -107,7 +107,7 @@ `(td (a ((href ,target)) ,name)))) `(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 @@ -115,12 +115,12 @@ "td:hover {background: #eee}") (table ((style "font-family:Concourse T3;font-size:115%")) ; 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 - ,@(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 - ; 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)))))) + ; 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)))))) (displayln "Ready to rock") diff --git a/tools.rkt b/tools.rkt index 2f8cfa8..c2636b3 100644 --- a/tools.rkt +++ b/tools.rkt @@ -1,152 +1,22 @@ #lang racket/base (require racket/contract racket/match) -(require (only-in racket/path filename-extension)) (require (only-in racket/format ~a)) (require racket/list) (require (only-in racket/string string-join)) (require (only-in xml xexpr? xexpr/c)) -(require (prefix-in scribble: (only-in scribble/decode whitespace?))) -(require "readability.rkt" "debug.rkt") -(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt")) +(require "readability.rkt" "debug.rkt" "predicates.rkt") +(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt")) ;; setup for test cases -(module+ test - (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)])) +(module+ test (require rackunit)) ; make these independent of local includes (define (map-topic topic . 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 ;; normal function won't work for this. Has to be syntax-rule (define-syntax-rule (values->list vs) @@ -333,17 +203,6 @@ (list '(root "hello" "world" (em "goodnight" "moon")) '((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.