You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
pollen/ptree.rkt

249 lines
9.0 KiB
Racket

#lang racket/base
11 years ago
(require racket/contract racket/match racket/path xml/path racket/bool racket/rerequire)
(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt" sugar tagged-xexpr)
(module+ test (require rackunit))
11 years ago
(provide pnode? ptree? parent children previous next pnode->url ptree-source-decode path->pnode ptree->list file->ptree make-project-ptree current-ptree current-url-context)
11 years ago
(define/contract (pnode? x)
11 years ago
(any/c . -> . boolean?)
11 years ago
(try (not (whitespace? (->string x)))
(except [exn:fail? (λ(e) #f)])))
11 years ago
11 years ago
(define/contract (pnode?/error x)
11 years ago
(any/c . -> . boolean?)
11 years ago
(or (pnode? x) (error "Not a valid pnode:" x)))
11 years ago
(module+ test
11 years ago
(check-true (pnode? "foo-bar"))
(check-true (pnode? "Foo_Bar_0123"))
(check-true (pnode? 'foo-bar))
(check-true (pnode? "foo-bar.p"))
(check-true (pnode? "/Users/MB/foo-bar"))
(check-false (pnode? #f))
(check-false (pnode? ""))
(check-false (pnode? " ")))
11 years ago
(define/contract (ptree? x)
(any/c . -> . boolean?)
11 years ago
(and (tagged-xexpr? x) (andmap (λ(i) (or (pnode? i) (ptree? i))) x)))
11 years ago
(module+ test
(check-true (ptree? '(foo)))
(check-true (ptree? '(foo (hee))))
(check-true (ptree? '(foo (hee (uncle "foo"))))))
11 years ago
;; implement the caching with two hashes rather than composite key of (cons file mod-date)
;; so that cached copies don't pile up indefinitely
(define ptree-cache (make-hash))
(define ptree-source-mod-dates (make-hash))
11 years ago
(define (not-modified-since-last-pass? ptree-source-path)
11 years ago
(and (hash-has-key? ptree-source-mod-dates ptree-source-path)
((file-or-directory-modify-seconds ptree-source-path) . = . (hash-ref ptree-source-mod-dates ptree-source-path))))
(define/contract (file->ptree p)
(pathish? . -> . ptree?)
11 years ago
(define path (->path p))
;; (message "Loading ptree file" (->string (file-name-from-path path)))
(dynamic-rerequire path)
(dynamic-require path MAIN_POLLEN_EXPORT))
(define/contract (directory->ptree dir)
(directory-pathish? . -> . ptree?)
(let ([files (map remove-ext (filter (λ(x) (has-ext? x DECODER_SOURCE_EXT)) (directory-list dir)))])
11 years ago
(message "Generating ptree from file listing of" dir)
(ptree-root->ptree (cons PTREE_ROOT_NODE files))))
;; Try loading from ptree file, or failing that, synthesize ptree.
11 years ago
(define/contract (make-project-ptree project-dir)
(directory-pathish? . -> . ptree?)
(define ptree-source (build-path project-dir DEFAULT_PTREE))
(if (file-exists? ptree-source)
11 years ago
(if (not-modified-since-last-pass? ptree-source)
11 years ago
(hash-ref ptree-cache ptree-source)
(begin
(hash-set! ptree-source-mod-dates ptree-source (file-or-directory-modify-seconds ptree-source))
(hash-ref! ptree-cache ptree-source (file->ptree ptree-source))))
(directory->ptree project-dir)))
(module+ test
(let ([sample-main `(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three")))])
(check-equal? (ptree-root->ptree sample-main)
`(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three"))))))
11 years ago
(define/contract (parent pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
11 years ago
(and pnode
(if (member (->string pnode) (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree)))
(->string (car ptree))
11 years ago
(ormap (λ(x) (parent pnode x)) (filter list? ptree)))))
11 years ago
(module+ test
(define test-ptree-main `(ptree-main "foo" "bar" (one (two "three"))))
(define test-ptree (ptree-root->ptree test-ptree-main))
(check-equal? (parent 'three test-ptree) "two")
(check-equal? (parent "three" test-ptree) "two")
11 years ago
(check-false (parent #f test-ptree))
(check-false (parent 'nonexistent-name test-ptree)))
11 years ago
(define/contract (children pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
11 years ago
(and pnode
(if (equal? (->string pnode) (->string (car ptree)))
(map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree))
11 years ago
(ormap (λ(x) (children pnode x)) (filter list? ptree)))))
(module+ test
(check-equal? (children 'one test-ptree) (list "two"))
(check-equal? (children 'two test-ptree) (list "three"))
(check-false (children 'three test-ptree))
11 years ago
(check-false (children #f test-ptree))
(check-false (children 'fooburger test-ptree)))
11 years ago
(define/contract (siblings pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof string?)))
11 years ago
(children (parent pnode ptree) ptree))
(module+ test
(check-equal? (siblings 'one test-ptree) '("foo" "bar" "one"))
(check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one"))
(check-equal? (siblings 'two test-ptree) '("two"))
11 years ago
(check-false (siblings #f test-ptree))
(check-false (siblings 'invalid-key test-ptree)))
;; flatten tree to sequence
11 years ago
(define/contract (ptree->list [ptree (current-ptree)])
(ptree? . -> . (listof string?))
; use cdr to get rid of root tag at front
(map ->string (cdr (flatten ptree))))
(module+ test
11 years ago
(check-equal? (ptree->list test-ptree) '("foo" "bar" "one" "two" "three")))
11 years ago
(define (adjacents side pnode [ptree (current-ptree)])
(and pnode
(let* ([proc (if (equal? side 'left) takef takef-right)]
[result (proc (ptree->list ptree) (λ(x) (not (equal? (->string pnode) (->string x)))))])
11 years ago
(and (not (empty? result)) result))))
11 years ago
(define/contract (left-adjacents pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
11 years ago
(adjacents 'left pnode ptree))
(module+ test
11 years ago
(check-equal? (left-adjacents 'one test-ptree) '("foo" "bar"))
(check-equal? (left-adjacents 'three test-ptree) '("foo" "bar" "one" "two"))
(check-false (left-adjacents 'foo test-ptree)))
11 years ago
(define/contract (right-adjacents pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
11 years ago
(adjacents 'right pnode ptree))
11 years ago
(define/contract (previous pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
11 years ago
(let ([result (left-adjacents pnode ptree)])
(and result (last result))))
(module+ test
11 years ago
(check-equal? (previous 'one test-ptree) "bar")
(check-equal? (previous 'three test-ptree) "two")
(check-false (previous 'foo test-ptree)))
11 years ago
11 years ago
11 years ago
(define (next pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
11 years ago
(let ([result (right-adjacents pnode ptree)])
(and result (first result))))
(module+ test
11 years ago
(check-equal? (next 'foo test-ptree) "bar")
(check-equal? (next 'one test-ptree) "two")
(check-false (next 'three test-ptree)))
11 years ago
;; this is a helper function to permit unit tests
(define (pnode->url/paths pnode url-list)
11 years ago
;; check for duplicates because some sources might have already been rendered
(define output-paths (remove-duplicates (map ->output-path url-list) equal?))
(define matching-paths (filter (λ(x) (equal? (->string x) (->string pnode))) output-paths))
(cond
[((len matching-paths) . = . 1) (->string (car matching-paths))]
[((len matching-paths) . > . 1) (error "More than one matching URL for" pnode)]
[else #f]))
(module+ test
(define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml"))
(check-equal? (pnode->url/paths 'foo.html files) "foo.html")
(check-equal? (pnode->url/paths 'bar.html files) "bar.html")
11 years ago
;; (check-equal? (name->url 'zap files) 'error) ;; todo: how to test error?
(check-false (pnode->url/paths 'hee files)))
(define/contract (pnode->url pnode [url-context (current-url-context)])
((pnode?) (pathish?) . ->* . (or/c false? pnode?))
(parameterize ([current-url-context url-context])
(pnode->url/paths pnode (directory-list (current-url-context)))))
;; this sets default input for following functions
(define/contract (ptree-root->ptree tx)
;; (not/c ptree) prevents ptrees from being accepted as input
((and/c tagged-xexpr?) . -> . ptree?)
tx)
(module+ test
(set! test-ptree-main `(,PTREE_ROOT_NODE "foo" "bar" (one (two "three"))))
(check-equal? (ptree-root->ptree test-ptree-main)
`(,PTREE_ROOT_NODE "foo" "bar" (one (two "three")))))
(define/contract (pnodes-unique?/error x)
(any/c . -> . boolean?)
(define members (filter-not whitespace? (flatten x)))
(and (andmap pnode?/error members)
(members-unique?/error (map ->string members))))
(define/contract (ptree-source-decode . elements)
(() #:rest pnodes-unique?/error . ->* . ptree?)
(ptree-root->ptree (decode (cons PTREE_ROOT_NODE elements)
#:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs)))))
(define current-ptree (make-parameter `(,PTREE_ROOT_NODE)))
11 years ago
(define current-url-context (make-parameter PROJECT_ROOT))
11 years ago
11 years ago
;; used to convert here-path into here
11 years ago
(define/contract (path->pnode path)
(pathish? . -> . pnode?)
11 years ago
(->string (->output-path (find-relative-path PROJECT_ROOT (->path path)))))
#|
(module+ main
11 years ago
(displayln "Running module main")
(set-current-ptree (make-project-ptree (->path "/Users/MB/git/bpt/")))
11 years ago
(set-current-url-context "/Users/MB/git/bpt/")
(ptree-previous (ptree-previous 'what-is-typography.html))
(name->url "how-to-pay-for-this-book.html"))
|#