updates
parent
04e7a63583
commit
1e523376c9
@ -1,121 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/path)
|
||||
(require "tools.rkt" "world.rkt" "decode.rkt" sugar txexpr "cache.rkt")
|
||||
|
||||
|
||||
(define+provide current-pagemap (make-parameter #f))
|
||||
|
||||
|
||||
(define+provide (node? x)
|
||||
(->boolean (and (symbol? x) (try (not (whitespace/nbsp? (->string x)))
|
||||
(except [exn:fail? (λ(e) #f)])))))
|
||||
|
||||
|
||||
(define+provide (nodeish? x)
|
||||
(try (node? (->symbol x))
|
||||
(except [exn:fail? (λ(e) #f)])))
|
||||
|
||||
|
||||
(define/contract+provide (->node x)
|
||||
(nodeish? . -> . node?)
|
||||
(->symbol x))
|
||||
|
||||
|
||||
(define+provide/contract (decode-pagemap xs)
|
||||
(txexpr-elements? . -> . any/c) ; because pagemap is being explicitly validated
|
||||
(validate-pagemap
|
||||
(decode (cons world:pagemap-root-node xs)
|
||||
#:txexpr-elements-proc (λ(xs) (filter (compose1 not whitespace?) xs))
|
||||
#:string-proc string->symbol))) ; because faster than ->node
|
||||
|
||||
|
||||
(define+provide (validate-pagemap x)
|
||||
(let ([nodes (pagemap->list x)])
|
||||
(and
|
||||
(andmap (λ(p) (or (node? p) (error (format "validate-pagemap: \"~a\" is not a valid node" p)))) nodes)
|
||||
(try (members-unique?/error nodes)
|
||||
(except [exn:fail? (λ(e) (error (format "validate-pagemap: ~a" (exn-message e))))]))
|
||||
x)))
|
||||
|
||||
|
||||
(define+provide (pagemap? x)
|
||||
(try (->boolean (validate-pagemap x))
|
||||
(except [exn:fail? (λ(e) #f)])))
|
||||
|
||||
|
||||
;; Try loading from pagemap file, or failing that, synthesize pagemap.
|
||||
(define+provide/contract (make-project-pagemap project-dir)
|
||||
(pathish? . -> . pagemap?)
|
||||
(define pagemap-source (build-path project-dir world:default-pagemap))
|
||||
(cached-require pagemap-source world:main-pollen-export))
|
||||
|
||||
|
||||
(define+provide/contract (parent-node p [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
||||
(and pagemap p
|
||||
(let ([node (->node p)])
|
||||
(if (member node (map (λ(x) (if (list? x) (car x) x)) (cdr pagemap)))
|
||||
(car pagemap)
|
||||
(ormap (λ(x) (parent-node node x)) (filter list? pagemap))))))
|
||||
|
||||
|
||||
(define+provide/contract (child-nodes p [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
||||
(and pagemap p
|
||||
(let ([node (->node p)])
|
||||
(if (equal? node (car pagemap))
|
||||
(map (λ(x) (if (list? x) (car x) x)) (cdr pagemap))
|
||||
(ormap (λ(x) (child-nodes node x)) (filter list? pagemap))))))
|
||||
|
||||
|
||||
(define+provide/contract (sibling-nodes p [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
||||
(child-nodes (parent-node p pagemap) pagemap))
|
||||
|
||||
|
||||
;; flatten tree to sequence
|
||||
(define+provide/contract (pagemap->list pagemap)
|
||||
(pagemap? . -> . (listof node?))
|
||||
; use cdr to get rid of root tag at front
|
||||
(cdr (flatten pagemap)))
|
||||
|
||||
|
||||
(define (adjacent-nodes side p [pagemap (current-pagemap)])
|
||||
; ((symbol? (or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
||||
(and pagemap p
|
||||
(let* ([node (->node p)]
|
||||
[proc (if (equal? side 'left) takef takef-right)]
|
||||
[result (proc (pagemap->list pagemap) (λ(x) (not (equal? node x))))])
|
||||
(and (not (empty? result)) result))))
|
||||
|
||||
|
||||
(define+provide/contract (previous-nodes node [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
||||
(adjacent-nodes 'left node pagemap))
|
||||
|
||||
|
||||
(define+provide/contract (next-nodes node [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
||||
(adjacent-nodes 'right node pagemap))
|
||||
|
||||
|
||||
(define+provide/contract (previous-node node [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
||||
(let ([result (previous-nodes node pagemap)])
|
||||
(and result (last result))))
|
||||
|
||||
|
||||
(define+provide/contract (next-node node [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
||||
(let ([result (next-nodes node pagemap)])
|
||||
(and result (first result))))
|
||||
|
||||
|
||||
(define/contract+provide (path->node path)
|
||||
(coerce/path? . -> . coerce/symbol?)
|
||||
(->output-path (find-relative-path (world:current-project-root) (->complete-path path))))
|
||||
|
||||
|
||||
(define+provide/contract (node-in-pagemap? node [pagemap (current-pagemap)])
|
||||
(((or/c #f nodeish?)) (pagemap?) . ->* . boolean?)
|
||||
(->boolean (and node (member node (pagemap->list pagemap)))))
|
@ -0,0 +1,121 @@
|
||||
#lang racket/base
|
||||
(require racket/path)
|
||||
(require "tools.rkt" "world.rkt" "decode.rkt" sugar txexpr "cache.rkt")
|
||||
|
||||
|
||||
(define+provide current-pagetree (make-parameter #f))
|
||||
|
||||
|
||||
(define+provide (pagenode? x)
|
||||
(->boolean (and (symbol? x) (try (not (whitespace/nbsp? (->string x)))
|
||||
(except [exn:fail? (λ(e) #f)])))))
|
||||
|
||||
|
||||
(define+provide (pagenodeish? x)
|
||||
(try (pagenode? (->symbol x))
|
||||
(except [exn:fail? (λ(e) #f)])))
|
||||
|
||||
|
||||
(define/contract+provide (->pagenode x)
|
||||
(pagenodeish? . -> . pagenode?)
|
||||
(->symbol x))
|
||||
|
||||
|
||||
(define+provide/contract (decode-pagetree xs)
|
||||
(txexpr-elements? . -> . any/c) ; because pagetree is being explicitly validated
|
||||
(validate-pagetree
|
||||
(decode (cons world:pagetree-root-node xs)
|
||||
#:txexpr-elements-proc (λ(xs) (filter (compose1 not whitespace?) xs))
|
||||
#:string-proc string->symbol))) ; because faster than ->pagenode
|
||||
|
||||
|
||||
(define+provide (validate-pagetree x)
|
||||
(let ([pagenodes (pagetree->list x)])
|
||||
(and
|
||||
(andmap (λ(p) (or (pagenode? p) (error (format "validate-pagetree: \"~a\" is not a valid pagenode" p)))) pagenodes)
|
||||
(try (members-unique?/error pagenodes)
|
||||
(except [exn:fail? (λ(e) (error (format "validate-pagetree: ~a" (exn-message e))))]))
|
||||
x)))
|
||||
|
||||
|
||||
(define+provide (pagetree? x)
|
||||
(try (->boolean (validate-pagetree x))
|
||||
(except [exn:fail? (λ(e) #f)])))
|
||||
|
||||
|
||||
;; Try loading from pagetree file, or failing that, synthesize pagetree.
|
||||
(define+provide/contract (make-project-pagetree project-dir)
|
||||
(pathish? . -> . pagetree?)
|
||||
(define pagetree-source (build-path project-dir world:default-pagetree))
|
||||
(cached-require pagetree-source world:main-pollen-export))
|
||||
|
||||
|
||||
(define+provide/contract (parent pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?))
|
||||
(and pt pnish
|
||||
(let ([pagenode (->pagenode pnish)])
|
||||
(if (member pagenode (map (λ(x) (if (list? x) (car x) x)) (cdr pt)))
|
||||
(car pt)
|
||||
(ormap (λ(x) (parent pagenode x)) (filter list? pt))))))
|
||||
|
||||
|
||||
(define+provide/contract (children p [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f (listof pagenode?)))
|
||||
(and pt p
|
||||
(let ([pagenode (->pagenode p)])
|
||||
(if (equal? pagenode (car pt))
|
||||
(map (λ(x) (if (list? x) (car x) x)) (cdr pt))
|
||||
(ormap (λ(x) (children pagenode x)) (filter list? pt))))))
|
||||
|
||||
|
||||
(define+provide/contract (siblings pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f (listof pagenode?)))
|
||||
(children (parent pnish pt) pt))
|
||||
|
||||
|
||||
;; flatten tree to sequence
|
||||
(define+provide/contract (pagetree->list pt)
|
||||
(pagetree? . -> . (listof pagenode?))
|
||||
; use cdr to get rid of root tag at front
|
||||
(cdr (flatten pt)))
|
||||
|
||||
|
||||
(define (adjacents side pnish [pt (current-pagetree)])
|
||||
; ((symbol? (or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f (listof pagenode?)))
|
||||
(and pt pnish
|
||||
(let* ([pagenode (->pagenode pnish)]
|
||||
[proc (if (equal? side 'left) takef takef-right)]
|
||||
[result (proc (pagetree->list pt) (λ(x) (not (equal? pagenode x))))])
|
||||
(and (not (empty? result)) result))))
|
||||
|
||||
|
||||
(define+provide/contract (previous* pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f (listof pagenode?)))
|
||||
(adjacents 'left pnish pt))
|
||||
|
||||
|
||||
(define+provide/contract (next* pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f (listof pagenode?)))
|
||||
(adjacents 'right pnish pt))
|
||||
|
||||
|
||||
(define+provide/contract (previous pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?))
|
||||
(let ([result (previous* pnish pt)])
|
||||
(and result (last result))))
|
||||
|
||||
|
||||
(define+provide/contract (next pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?))
|
||||
(let ([result (next* pnish pt)])
|
||||
(and result (first result))))
|
||||
|
||||
|
||||
(define/contract+provide (path->pagenode path)
|
||||
(coerce/path? . -> . coerce/symbol?)
|
||||
(->output-path (find-relative-path (world:current-project-root) (->complete-path path))))
|
||||
|
||||
|
||||
(define+provide/contract (in-pagetree? pnish [pt (current-pagetree)])
|
||||
(((or/c #f pagenodeish?)) (pagetree?) . ->* . boolean?)
|
||||
(->boolean (and pnish (member pnish (pagetree->list pt)))))
|
@ -1,4 +1,4 @@
|
||||
#lang racket/base
|
||||
(require pollen/lang/reader-base)
|
||||
|
||||
(make-reader-with-mode world:reader-mode-pagemap)
|
||||
(make-reader-with-mode world:reader-mode-pagetree)
|
@ -1,69 +1,69 @@
|
||||
#lang racket/base
|
||||
(require rackunit)
|
||||
(require "../pagemap.rkt" "../world.rkt")
|
||||
(require "../pagetree.rkt" "../world.rkt")
|
||||
|
||||
|
||||
(check-false (node? "foo-bar"))
|
||||
(check-false (node? "Foo_Bar_0123"))
|
||||
(check-true (node? 'foo-bar))
|
||||
(check-false (node? "foo-bar.p"))
|
||||
(check-false (node? "/Users/MB/foo-bar"))
|
||||
(check-false (node? #f))
|
||||
(check-false (node? ""))
|
||||
(check-false (node? " "))
|
||||
(check-false (pagenode? "foo-bar"))
|
||||
(check-false (pagenode? "Foo_Bar_0123"))
|
||||
(check-true (pagenode? 'foo-bar))
|
||||
(check-false (pagenode? "foo-bar.p"))
|
||||
(check-false (pagenode? "/Users/MB/foo-bar"))
|
||||
(check-false (pagenode? #f))
|
||||
(check-false (pagenode? ""))
|
||||
(check-false (pagenode? " "))
|
||||
|
||||
(check-true (pagemap? '(foo)))
|
||||
(check-true (pagemap? '(foo (hee))))
|
||||
(check-true (pagemap? '(foo (hee (uncle foo)))))
|
||||
(check-false (pagemap? '(foo (hee hee (uncle foo)))))
|
||||
(check-true (pagetree? '(foo)))
|
||||
(check-true (pagetree? '(foo (hee))))
|
||||
(check-true (pagetree? '(foo (hee (uncle foo)))))
|
||||
(check-false (pagetree? '(foo (hee hee (uncle foo)))))
|
||||
|
||||
|
||||
(define test-pagemap-main `(pagemap-main foo bar (one (two three))))
|
||||
(define test-pagemap (pagemap-root->pagemap test-pagemap-main))
|
||||
(check-equal? (parent 'three test-pagemap) 'two)
|
||||
(check-equal? (parent "three" test-pagemap) 'two)
|
||||
(check-false (parent #f test-pagemap))
|
||||
(check-false (parent 'nonexistent-name test-pagemap))
|
||||
(define test-pagetree-main `(pagetree-main foo bar (one (two three))))
|
||||
(define test-pagetree (pagetree-root->pagetree test-pagetree-main))
|
||||
(check-equal? (parent 'three test-pagetree) 'two)
|
||||
(check-equal? (parent "three" test-pagetree) 'two)
|
||||
(check-false (parent #f test-pagetree))
|
||||
(check-false (parent 'nonexistent-name test-pagetree))
|
||||
|
||||
|
||||
(check-equal? (children 'one test-pagemap) '(two))
|
||||
(check-equal? (children 'two test-pagemap) '(three))
|
||||
(check-false (children 'three test-pagemap))
|
||||
(check-false (children #f test-pagemap))
|
||||
(check-false (children 'fooburger test-pagemap))
|
||||
(check-equal? (children 'one test-pagetree) '(two))
|
||||
(check-equal? (children 'two test-pagetree) '(three))
|
||||
(check-false (children 'three test-pagetree))
|
||||
(check-false (children #f test-pagetree))
|
||||
(check-false (children 'fooburger test-pagetree))
|
||||
|
||||
(check-equal? (siblings 'one test-pagemap) '(foo bar one))
|
||||
(check-equal? (siblings 'foo test-pagemap) '(foo bar one))
|
||||
(check-equal? (siblings 'two test-pagemap) '(two))
|
||||
(check-false (siblings #f test-pagemapap))
|
||||
(check-false (siblings 'invalid-key test-pagemap))
|
||||
(check-equal? (siblings 'one test-pagetree) '(foo bar one))
|
||||
(check-equal? (siblings 'foo test-pagetree) '(foo bar one))
|
||||
(check-equal? (siblings 'two test-pagetree) '(two))
|
||||
(check-false (siblings #f test-pagetree))
|
||||
(check-false (siblings 'invalid-key test-pagetree))
|
||||
|
||||
(check-equal? (previous* 'one test-pagemap) '(foo bar))
|
||||
(check-equal? (previous* 'three test-pagemap) '(foo bar one two))
|
||||
(check-false (previous* 'foo test-pagemap))
|
||||
(check-equal? (previous* 'one test-pagetree) '(foo bar))
|
||||
(check-equal? (previous* 'three test-pagetree) '(foo bar one two))
|
||||
(check-false (previous* 'foo test-pagetree))
|
||||
|
||||
(check-equal? (previous 'one test-pagemap) 'bar)
|
||||
(check-equal? (previous 'three test-pagemap) 'two)
|
||||
(check-false (previous 'foo test-pagemap))
|
||||
(check-equal? (previous 'one test-pagetree) 'bar)
|
||||
(check-equal? (previous 'three test-pagetree) 'two)
|
||||
(check-false (previous 'foo test-pagetree))
|
||||
|
||||
(check-equal? (next 'foo test-pagemap) 'bar)
|
||||
(check-equal? (next 'one test-pagemap) 'two)
|
||||
(check-false (next 'three test-pagemap))
|
||||
(check-equal? (next 'foo test-pagetree) 'bar)
|
||||
(check-equal? (next 'one test-pagetree) 'two)
|
||||
(check-false (next 'three test-pagetree))
|
||||
|
||||
(check-equal? (pagemap->list test-pagemap) '(foo bar one two three))
|
||||
(check-equal? (pagetree->list test-pagetree) '(foo bar one two three))
|
||||
|
||||
|
||||
(let ([sample-main `(world:pollen-tree-root-name foo bar (one (two three)))])
|
||||
(check-equal? (pagemap-root->pagemap sample-main)
|
||||
(check-equal? (pagetree-root->pagetree sample-main)
|
||||
`(world:pollen-tree-root-name foo bar (one (two three)))))
|
||||
|
||||
(define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml"))
|
||||
(check-equal? (node->url/paths 'foo.html files) "foo.html")
|
||||
(check-equal? (node->url/paths 'bar.html files) "bar.html")
|
||||
(check-equal? (pagenode->url/paths 'foo.html files) "foo.html")
|
||||
(check-equal? (pagenode->url/paths 'bar.html files) "bar.html")
|
||||
;; (check-equal? (name->url 'zap files) 'error) ;; todo: how to test error?
|
||||
(check-false (node->url/paths 'hee files))
|
||||
(check-false (pagenode->url/paths 'hee files))
|
||||
|
||||
|
||||
(set! test-pagemap-main `(,world:pagemap-root-node foo bar (one (two three))))
|
||||
(check-equal? (pagemap-root->pagemap test-pagemap-main)
|
||||
`(,world:pagemap-root-node foo bar (one (two three))))
|
||||
(set! test-pagetree-main `(,world:pagetree-root-node foo bar (one (two three))))
|
||||
(check-equal? (pagetree-root->pagetree test-pagetree-main)
|
||||
`(,world:pagetree-root-node foo bar (one (two three))))
|
Loading…
Reference in New Issue