various tidying. all files compile now.

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

@ -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)

@ -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))

@ -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
)))
)))

@ -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")))))

@ -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)))
(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])
; 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)

@ -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 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<?))
@ -95,9 +95,9 @@
[preproc-source (add-ext file POLLEN_PREPROC_EXT)]
[file-string (path->string 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")

@ -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.

Loading…
Cancel
Save