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