From cccae538cfcdd330e14b54dc040daa30bff3bf0d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 16 Oct 2013 22:29:53 -0700 Subject: [PATCH] reconsolidate ptree modules --- file-tools.rkt | 28 +++- main-imports.rkt | 18 +-- predicates.rkt | 1 - ptree-decode.rkt | 58 -------- ptree-nav.rkt | 231 -------------------------------- ptree.rkt | 334 +++++++++++++++++++++++++++++++++++++++++++---- render.rkt | 11 +- world.rkt | 2 +- 8 files changed, 346 insertions(+), 337 deletions(-) delete mode 100644 ptree-decode.rkt delete mode 100644 ptree-nav.rkt diff --git a/file-tools.rkt b/file-tools.rkt index e7b8e81..dee58a6 100644 --- a/file-tools.rkt +++ b/file-tools.rkt @@ -11,14 +11,30 @@ ; helper functions for regenerate functions (define pollen-project-directory (current-directory)) -;; this is for regenerate module. -;; when we want to be friendly with inputs for functions that require a path. -;; Strings & symbols often result from xexpr parsing -;; and are trivially converted to paths. -;; so let's say close enough. +;; if something can be successfully coerced to a path, +;; it's pathish. (define/contract (pathish? x) (any/c . -> . boolean?) - (->boolean (or path? string? symbol?))) + (with-handlers ([exn:fail? (λ(e) #f)]) + (->boolean (->path x)))) + +(module+ test + (check-true (pathish? (->path "/Users/MB/home"))) + (check-true (pathish? "/Users/MB/home")) + (check-true (pathish? (->symbol "/Users/MB/home")))) + +;; like pathish, but for directories +;; todo: is this contract too restrictive? +;; pathish doesn't require the path to exist, +;; but this one does. +(define/contract (directory-pathish? x) + (any/c . -> . boolean?) + (->boolean (and (pathish? x) (directory-exists? (->path x))))) + +(module+ test + (check-true (directory-pathish? "/Users/")) + (check-false (directory-pathish? "foobar"))) + ;; does path have a certain extension (define/contract (has-ext? x ext) diff --git a/main-imports.rkt b/main-imports.rkt index f82f2ac..72fa72d 100644 --- a/main-imports.rkt +++ b/main-imports.rkt @@ -5,12 +5,14 @@ ;; and cached for the benefit of the render eval function. -(require racket/list) -(require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) -(require (only-in (planet mb/pollen/ptree-decode) ptree-source-decode)) -(require (only-in (planet mb/pollen/predicates) ptree?)) +(require racket/list + (planet mb/pollen/tools) + (planet mb/pollen/main-helper) + (only-in (planet mb/pollen/ptree) ptree-source-decode) + (only-in (planet mb/pollen/predicates) ptree?)) -(provide (all-from-out - racket/list - (planet mb/pollen/tools) (planet mb/pollen/main-helper) - (planet mb/pollen/ptree-decode)(planet mb/pollen/predicates))) \ No newline at end of file +(provide (all-from-out racket/list + (planet mb/pollen/tools) + (planet mb/pollen/main-helper) + (planet mb/pollen/ptree) + (planet mb/pollen/predicates))) \ No newline at end of file diff --git a/predicates.rkt b/predicates.rkt index af29e58..2c9ee94 100644 --- a/predicates.rkt +++ b/predicates.rkt @@ -186,7 +186,6 @@ ;; ptree attr must be ((parent "value")) (define/contract (ptree-attr? x) (any/c . -> . boolean?) - (define foo 'bar) (match x ;; todo: how can I use POLLEN_MAP_PARENT_KEY [`((parent ,(? string?))) #t] diff --git a/ptree-decode.rkt b/ptree-decode.rkt deleted file mode 100644 index 9b32f67..0000000 --- a/ptree-decode.rkt +++ /dev/null @@ -1,58 +0,0 @@ -#lang racket/base -(require racket/list racket/string racket/contract racket/match racket/set) -(require "tools.rkt" "world.rkt" "decode.rkt") - -(module+ test (require rackunit)) - -(provide (all-defined-out)) - -;; These functions need to be separated so that they can be accessed by pollen parser (in main.rkt) -;; ptree decoder takes ptree source and returns a full ptree structure. - -;; recursively processes tree, converting tree locations & their parents into xexprs of this shape: -;; '(location ((parent "parent"))) -(define/contract (add-parents x [parent empty]) - ((tagged-xexpr?) (xexpr-tag?) . ->* . ptree?) - (match x - ;; this pattern signifies next level in hierarchy - ;; where first element is new parent, and rest are children. - [(list (? xexpr-tag? next-parent) children ...) - (let-values ([(tag attr _) (break-tagged-xexpr (add-parents next-parent parent))]) - ;; xexpr with tag as name, parent as attr, children as elements with tag as next parent - (make-tagged-xexpr tag attr (map (λ(c) (add-parents c tag)) children)))] - ;; single map entry: convert to xexpr with parent - [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_TREE_PARENT_NAME (->string parent)))])) - - -;; 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? (not/c ptree?)) . -> . ptree?) - (add-parents tx)) - - -(module+ test - (define test-ptree-main `(ptree-main "foo" "bar" (one (two "three")))) - (check-equal? (ptree-root->ptree test-ptree-main) - `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (bar ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (one ((,POLLEN_TREE_PARENT_NAME "ptree-main")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two")))))))) - - - -;; contract for ptree-source-decode -(define/contract (valid-pnodes? x) - (any/c . -> . boolean?) - (andmap (λ(x) (pnode? #:loud #t x)) (filter-not whitespace? (flatten x)))) - -;; contract for ptree-source-decode -(define/contract (unique-pnodes? x) - (any/c . -> . boolean?) - ;; use map ->string to make keys comparable - (elements-unique? #:loud #t (map ->string (filter-not whitespace? (flatten x))))) - - -(define/contract (ptree-source-decode . elements) - (() #:rest (and/c valid-pnodes? unique-pnodes?) . ->* . ptree?) - (ptree-root->ptree (decode (cons POLLEN_TREE_ROOT_NAME elements) - #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))))) - - diff --git a/ptree-nav.rkt b/ptree-nav.rkt deleted file mode 100644 index b84cdbb..0000000 --- a/ptree-nav.rkt +++ /dev/null @@ -1,231 +0,0 @@ -#lang racket/base -(require xml/path racket/contract) -(require "tools.rkt" "world.rkt" "ptree-decode.rkt" "debug.rkt") - -(module+ test (require rackunit)) - -(provide (all-defined-out)) - -;; These functions are separated so that they can be cached outside by pollen page renderer - -;; remove parents from tree (i.e., just remove attrs) -;; is not the inverse of add-parents, i.e., you do not get back your original input. -(define/contract (remove-parents mt) - (ptree? . -> . tagged-xexpr?) - (remove-attrs mt)) - -(module+ test - (check-equal? (remove-parents - `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME ""))) (bar ((,POLLEN_TREE_PARENT_NAME ""))) (one ((,POLLEN_TREE_PARENT_NAME "")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))) - '(ptree-main (foo) (bar) (one (two (three)))))) - - -(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 ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (bar ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (one ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))))) - - - -;; return the parent of a given name -(define/contract (parent pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (and pnode (let ([result (se-path* `(,(->symbol pnode) #:parent) ptree)]) - (and result (->string result))))) ; se-path* returns #f if nothing found - - -(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") - (check-false (parent 'nonexistent-name test-ptree))) - - - -; get children of a particular pnode -(define/contract (children pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - ;; se-path*/list returns '() if nothing found - (and pnode (let ([children (se-path*/list `(,(->symbol pnode)) ptree)]) - ; If there are sublists, just take first pnode - (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) - -(module+ test - (check-equal? (children 'one test-ptree) (list "two")) - (check-equal? (children 'two test-ptree) (list "three")) - (check-false (children 'three test-ptree)) - (check-false (children 'fooburger test-ptree))) - - -;; find all siblings on current level: go up to parent and ask for children -(define/contract (siblings pnode [ptree project-ptree]) - ;; this never returns false: pnode is always a sibling of itself. - ;; todo: how to use input value in contract? e.g., to check that pnode is part of output list - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (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")) - (check-false (siblings 'invalid-key test-ptree))) - - - -(define/contract (siblings-split pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (values (or/c (listof pnode?) boolean?) - (or/c (listof pnode?) boolean?))) - (let-values ([(left right) (splitf-at (siblings pnode ptree) - (λ(e) (not (equal? (->string e) (->string pnode)))))]) - (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right))))) - -(module+ test - (check-equal? (values->list (siblings-split 'one test-ptree)) '(("foo" "bar") #f)) - (check-equal? (values->list (siblings-split 'bar test-ptree)) (list '("foo") '("one")))) - - -;; siblings to the left of target pnode (i.e., precede in tree order) -(define (siblings-left pnode [ptree project-ptree]) - (let-values ([(left right) (siblings-split pnode ptree)]) - left)) - -(module+ test - (check-equal? (siblings-left 'one test-ptree) '("foo" "bar")) - (check-false (siblings-left 'foo test-ptree))) - -;; siblings to the right of target pnode (i.e., follow in tree order) -(define (siblings-right pnode [ptree project-ptree]) - (let-values ([(left right) (siblings-split pnode ptree)]) - right)) - -(module+ test - (check-false (siblings-right 'one test-ptree)) - (check-equal? (siblings-right 'foo test-ptree) '("bar" "one"))) - - -;; get pnode immediately to the left in tree -(define/contract (sibling-previous pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([siblings (siblings-left pnode ptree)]) - (and siblings (last siblings)))) - -(module+ test - (check-equal? (sibling-previous 'bar test-ptree) "foo") - (check-false (sibling-previous 'foo test-ptree))) - -;; get pnode immediately to the right in tree -(define/contract (sibling-next pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([siblings (siblings-right pnode ptree)]) - (and siblings (first siblings)))) - -(module+ test - (check-equal? (sibling-next 'foo test-ptree) "bar") - (check-false (sibling-next 'one test-ptree))) - - -;; flatten tree to sequence -(define/contract (all-pages [ptree project-ptree]) - (ptree? . -> . (listof string?)) - ; use cdr to get rid of root tag at front - (map ->string (cdr (flatten (remove-parents ptree))))) - -(module+ test - (check-equal? (all-pages test-ptree) '("foo" "bar" "one" "two" "three"))) - -;; helper function for get-previous-pages and get-next-pages -(define/contract (adjacent-pages side pnode [ptree project-ptree]) - ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (let ([result ((if (equal? side 'left) - takef - takef-right) (all-pages ptree) - (λ(y) (not (equal? (->string pnode) (->string y)))))]) - (and (not (empty? result)) result))) - -(module+ test - (check-equal? (adjacent-pages 'left 'one test-ptree) '("foo" "bar")) - (check-equal? (adjacent-pages 'left 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (adjacent-pages 'left 'foo test-ptree))) - - -;; get sequence of earlier pages -(define/contract (previous-pages pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'left pnode ptree)) - -(module+ test - (check-equal? (previous-pages 'one test-ptree) '("foo" "bar")) - (check-equal? (previous-pages 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (previous-pages 'foo test-ptree))) - - -;; get sequence of next pages -(define (next-pages pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'right pnode ptree)) - -(module+ test - (check-equal? (next-pages 'foo test-ptree) '("bar" "one" "two" "three")) - (check-equal? (next-pages 'one test-ptree) '("two" "three")) - (check-false (next-pages 'three test-ptree))) - -;; get page immediately previous -(define/contract (previous-page pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (previous-pages pnode ptree)]) - (and result (last result)))) - -(module+ test - (check-equal? (previous-page 'one test-ptree) "bar") - (check-equal? (previous-page 'three test-ptree) "two") - (check-false (previous-page 'foo test-ptree))) - -;; get page immediately next -(define (next-page pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (next-pages pnode ptree)]) - (and result (first result)))) - -(module+ test - (check-equal? (next-page 'foo test-ptree) "bar") - (check-equal? (next-page 'one test-ptree) "two") - (check-false (next-page 'three test-ptree))) - -;; convert path to pnode -;; used for converting "here" values to pnodes -(define/contract (path->pnode x) - (pathish? . -> . pnode?) - (->string (remove-all-ext (last (explode-path (->path x)))))) - -(module+ test - (check-equal? (path->pnode "bar") "bar") - (check-equal? (path->pnode "foo/bar") "bar") - (check-equal? (path->pnode "foo/bar.html") "bar") - (check-equal? (path->pnode "/Users/this/that/foo/bar.html.pp") "bar")) - -(define here->pnode path->pnode) - -(define/contract (pnode->url pnode) - (pnode? . -> . string?) - (define files (directory-list START_DIR)) - (define (source-matches-pnode? x) - ;; todo: consider this test further. - ;; could pnode refer to files without pollen source? - ;; if so, the test is too narrow. - (and (x . starts-with? . pnode) (pollen-source? x))) - (define file-matches (filter source-matches-pnode? files)) - (if ((length file-matches) . > . 1) - (error "Duplicate source files for pnode" pnode) - (->string (->output-path (car file-matches))))) - -;; todo: make tests - - -;; this project setup must follow definitions to prevent undefined errors -(define project-ptree empty) - -(define/contract (set-project-ptree new-tree) - (ptree? . -> . void?) - (set! project-ptree new-tree)) - diff --git a/ptree.rkt b/ptree.rkt index b4815c5..3a7516b 100644 --- a/ptree.rkt +++ b/ptree.rkt @@ -1,33 +1,315 @@ #lang racket/base -(require racket/contract) -(require "tools.rkt" "world.rkt" "ptree-nav.rkt" "ptree-decode.rkt" "debug.rkt") +(require racket/contract racket/match xml/path) +(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt") (module+ test (require rackunit)) -(provide (all-defined-out) (all-from-out "ptree-nav.rkt")) +(provide (all-defined-out)) +;; Load ptree file & return ptree +(define/contract (ptree-source->ptree path) + (pathish? . -> . ptree?) + ;; dynamic require of a ptree source file gets you a full ptree. + (message "Loading ptree file" (->string (file-name-from-path path))) + (dynamic-require path POLLEN_ROOT)) -;; function to set up the project-ptree. -;; this is to make life simpler when using tree navigation functions. -;; the current main.ptree of the project is used as the default input. -;; without this, you'd have to pass it over and over. -;; which is sort of the functional lifestyle, -;; but in templates, gets tiresome and error-prone. -(define/contract (make-project-ptree) - (-> ptree?) - (define ptree-source (build-path START_DIR DEFAULT_POLLEN_TREE)) +;; Synthesize ptree from directory listing. +;; Fallback in case ptree file isn't available. +(define/contract (directory->ptree dir) + (directory-pathish? . -> . ptree?) + (let ([files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) (directory-list dir)))]) + (message "Generating ptree from file listing") + (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files))))) + + +;; Try loading from ptree file, or failing that, synthesize ptree. +(define/contract (make-project-ptree [project-dir pollen-project-directory]) + (() (directory-pathish?) . ->* . ptree?) + (define ptree-source (build-path project-dir DEFAULT_POLLEN_TREE)) (if (file-exists? ptree-source) - ;; Load it from default path. - ;; dynamic require of a ptree source file gets you a full ptree. - (begin - (message "Using ptree file" (->string (file-name-from-path ptree-source))) - (dynamic-require ptree-source POLLEN_ROOT)) - ;; ... or else synthesize it - (let* ([files (directory-list START_DIR)] - ;; restrict files to those with pollen extensions - [files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))]) - ;; make a POLLEN_TREE_ROOT_NAME structure and convert it to a full ptree - (message "Generating ptree from file listing") - (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files)))))) - -(set-project-ptree (make-project-ptree)) + (ptree-source->ptree ptree-source) + (directory->ptree project-dir))) + +;; remove parents from tree (i.e., just remove attrs) +;; is not the inverse of add-parents, i.e., you do not get back your original input. +(define/contract (remove-parents mt) + (ptree? . -> . tagged-xexpr?) + (remove-attrs mt)) + +(module+ test + (check-equal? (remove-parents + `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME ""))) (bar ((,POLLEN_TREE_PARENT_NAME ""))) (one ((,POLLEN_TREE_PARENT_NAME "")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))) + '(ptree-main (foo) (bar) (one (two (three)))))) + + +(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 ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (bar ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (one ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))))) + + + +;; return the parent of a given name +(define/contract (parent pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (and pnode (let ([result (se-path* `(,(->symbol pnode) #:parent) ptree)]) + (and result (->string result))))) ; se-path* returns #f if nothing found + + +(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") + (check-false (parent 'nonexistent-name test-ptree))) + + + +; get children of a particular pnode +(define/contract (children pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + ;; se-path*/list returns '() if nothing found + (and pnode (let ([children (se-path*/list `(,(->symbol pnode)) ptree)]) + ; If there are sublists, just take first pnode + (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) + +(module+ test + (check-equal? (children 'one test-ptree) (list "two")) + (check-equal? (children 'two test-ptree) (list "three")) + (check-false (children 'three test-ptree)) + (check-false (children 'fooburger test-ptree))) + + +;; find all siblings on current level: go up to parent and ask for children +(define/contract (siblings pnode [ptree current-ptree]) + ;; this never returns false: pnode is always a sibling of itself. + ;; todo: how to use input value in contract? e.g., to check that pnode is part of output list + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (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")) + (check-false (siblings 'invalid-key test-ptree))) + + + +(define/contract (siblings-split pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (values (or/c (listof pnode?) boolean?) + (or/c (listof pnode?) boolean?))) + (let-values ([(left right) (splitf-at (siblings pnode ptree) + (λ(e) (not (equal? (->string e) (->string pnode)))))]) + (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right))))) + +(module+ test + (check-equal? (values->list (siblings-split 'one test-ptree)) '(("foo" "bar") #f)) + (check-equal? (values->list (siblings-split 'bar test-ptree)) (list '("foo") '("one")))) + + +;; siblings to the left of target pnode (i.e., precede in tree order) +(define (siblings-left pnode [ptree current-ptree]) + (let-values ([(left right) (siblings-split pnode ptree)]) + left)) + +(module+ test + (check-equal? (siblings-left 'one test-ptree) '("foo" "bar")) + (check-false (siblings-left 'foo test-ptree))) + +;; siblings to the right of target pnode (i.e., follow in tree order) +(define (siblings-right pnode [ptree current-ptree]) + (let-values ([(left right) (siblings-split pnode ptree)]) + right)) + +(module+ test + (check-false (siblings-right 'one test-ptree)) + (check-equal? (siblings-right 'foo test-ptree) '("bar" "one"))) + + +;; get pnode immediately to the left in tree +(define/contract (sibling-previous pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-left pnode ptree)]) + (and siblings (last siblings)))) + +(module+ test + (check-equal? (sibling-previous 'bar test-ptree) "foo") + (check-false (sibling-previous 'foo test-ptree))) + +;; get pnode immediately to the right in tree +(define/contract (sibling-next pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-right pnode ptree)]) + (and siblings (first siblings)))) + +(module+ test + (check-equal? (sibling-next 'foo test-ptree) "bar") + (check-false (sibling-next 'one test-ptree))) + + +;; flatten tree to sequence +(define/contract (all-pages [ptree current-ptree]) + (ptree? . -> . (listof string?)) + ; use cdr to get rid of root tag at front + (map ->string (cdr (flatten (remove-parents ptree))))) + +(module+ test + (check-equal? (all-pages test-ptree) '("foo" "bar" "one" "two" "three"))) + +;; helper function for get-previous-pages and get-next-pages +(define/contract (adjacent-pages side pnode [ptree current-ptree]) + ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (let ([result ((if (equal? side 'left) + takef + takef-right) (all-pages ptree) + (λ(y) (not (equal? (->string pnode) (->string y)))))]) + (and (not (empty? result)) result))) + +(module+ test + (check-equal? (adjacent-pages 'left 'one test-ptree) '("foo" "bar")) + (check-equal? (adjacent-pages 'left 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (adjacent-pages 'left 'foo test-ptree))) + + +;; get sequence of earlier pages +(define/contract (previous-pages pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'left pnode ptree)) + +(module+ test + (check-equal? (previous-pages 'one test-ptree) '("foo" "bar")) + (check-equal? (previous-pages 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (previous-pages 'foo test-ptree))) + + +;; get sequence of next pages +(define (next-pages pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'right pnode ptree)) + +(module+ test + (check-equal? (next-pages 'foo test-ptree) '("bar" "one" "two" "three")) + (check-equal? (next-pages 'one test-ptree) '("two" "three")) + (check-false (next-pages 'three test-ptree))) + +;; get page immediately previous +(define/contract (previous-page pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (previous-pages pnode ptree)]) + (and result (last result)))) + +(module+ test + (check-equal? (previous-page 'one test-ptree) "bar") + (check-equal? (previous-page 'three test-ptree) "two") + (check-false (previous-page 'foo test-ptree))) + +;; get page immediately next +(define (next-page pnode [ptree current-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (next-pages pnode ptree)]) + (and result (first result)))) + +(module+ test + (check-equal? (next-page 'foo test-ptree) "bar") + (check-equal? (next-page 'one test-ptree) "two") + (check-false (next-page 'three test-ptree))) + +;; convert path to pnode +;; used for converting "here" values to pnodes +(define/contract (path->pnode x) + (pathish? . -> . pnode?) + (->string (remove-all-ext (last (explode-path (->path x)))))) + +(module+ test + (check-equal? (path->pnode "bar") "bar") + (check-equal? (path->pnode "foo/bar") "bar") + (check-equal? (path->pnode "foo/bar.html") "bar") + (check-equal? (path->pnode "/Users/this/that/foo/bar.html.pp") "bar")) + +(define here->pnode path->pnode) + +(define/contract (pnode->url pnode [files current-url-context]) + ((pnode?) ((listof pathish?)) . ->* . string?) + ;; upconvert all files to their output path + ;; then remove duplicates because some sources might have already been rendered + (define output-paths (remove-duplicates (map ->output-path files) equal?)) + ;; find ones that match pnode + (define matching-paths (filter (λ(x) (x . starts-with? . pnode)) output-paths)) + (cond + [((len matching-paths) . = . 0) "#"] ; conventional way to write a null URL + [((len matching-paths) . = . 1) (->string (car matching-paths))] + [((len matching-paths) . > . 1) (error "More than one matching URL for" pnode)])) + + +(module+ test + (define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml")) + (check-equal? (pnode->url 'foo files) "foo.html") + (check-equal? (pnode->url 'bar files) "bar.html") + ;; (check-equal? (pnode->url 'zap files) 'error) ;; todo: how to test error? + (check-equal? (pnode->url 'hee files) "#")) + + +;; recursively processes tree, converting tree locations & their parents into xexprs of this shape: +;; '(location ((parent "parent"))) +(define/contract (add-parents x [parent empty]) + ((tagged-xexpr?) (xexpr-tag?) . ->* . ptree?) + (match x + ;; this pattern signifies next level in hierarchy + ;; where first element is new parent, and rest are children. + [(list (? xexpr-tag? next-parent) children ...) + (let-values ([(tag attr _) (break-tagged-xexpr (add-parents next-parent parent))]) + ;; xexpr with tag as name, parent as attr, children as elements with tag as next parent + (make-tagged-xexpr tag attr (map (λ(c) (add-parents c tag)) children)))] + ;; single map entry: convert to xexpr with parent + [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_TREE_PARENT_NAME (->string parent)))])) + + +;; 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? (not/c ptree?)) . -> . ptree?) + (add-parents tx)) + + +(module+ test + (set! test-ptree-main `(ptree-main "foo" "bar" (one (two "three")))) + (check-equal? (ptree-root->ptree test-ptree-main) + `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (bar ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (one ((,POLLEN_TREE_PARENT_NAME "ptree-main")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two")))))))) + + + +;; contract for ptree-source-decode +(define/contract (valid-pnodes? x) + (any/c . -> . boolean?) + (andmap (λ(x) (pnode? #:loud #t x)) (filter-not whitespace? (flatten x)))) + +;; contract for ptree-source-decode +(define/contract (unique-pnodes? x) + (any/c . -> . boolean?) + ;; use map ->string to make keys comparable + (elements-unique? #:loud #t (map ->string (filter-not whitespace? (flatten x))))) + + +(define/contract (ptree-source-decode . elements) + (() #:rest (and/c valid-pnodes? unique-pnodes?) . ->* . ptree?) + (ptree-root->ptree (decode (cons POLLEN_TREE_ROOT_NAME elements) + #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))))) + + + +(define current-ptree '(empty ((parent "")))) ;; simplest empty ptree that will meet ptree contract +(define current-url-context pollen-project-directory) + +(define/contract (set-current-ptree ptree) + (ptree? . -> . void?) + (set! current-ptree ptree)) + +(define/contract (set-current-url-context x) + ((or/c directory-pathish? (listof pathish?)) . -> . void) + (set! current-url-context (with-handlers ([exn:fail? (λ(e) x)]) + (directory-list x)))) + +(module+ main + (set-current-ptree (make-project-ptree (->path "/Users/MB/git/bpt/"))) + (set-current-url-context (directory-list "/Users/MB/git/bpt/")) + (pnode->url (previous-page (previous-page 'what-is-typography)))) \ No newline at end of file diff --git a/render.rkt b/render.rkt index 3496848..5042853 100644 --- a/render.rkt +++ b/render.rkt @@ -296,8 +296,7 @@ (planet mb/pollen/main-imports) (planet mb/pollen/main-preproc-imports) (planet mb/pollen/predicates) - (planet mb/pollen/ptree-nav) - (planet mb/pollen/ptree-decode) + (planet mb/pollen/ptree) (planet mb/pollen/readability) (planet mb/pollen/template) (planet mb/pollen/tools) @@ -321,8 +320,7 @@ ;; that represents the output of the operation. (parameterize ([current-namespace (make-base-empty-namespace)] [current-directory source-dir] - [current-output-port nowhere-port] - [current-error-port nowhere-port]) ; silent evaluation; exceptions still thrown + [current-output-port nowhere-port]) ;; attach already-imported modules ;; this is a performance optimization: this way, ;; the eval namespace doesn't have to re-import these @@ -342,8 +340,7 @@ (planet mb/pollen/main-imports) (planet mb/pollen/main-preproc-imports) (planet mb/pollen/predicates) - (planet mb/pollen/ptree-nav) - (planet mb/pollen/ptree-decode) + (planet mb/pollen/ptree) (planet mb/pollen/readability) (planet mb/pollen/template) (planet mb/pollen/tools) @@ -356,6 +353,8 @@ (require (planet mb/pollen/debug) (planet mb/pollen/ptree) (planet mb/pollen/template)) ;; import source into eval space. This sets up main & metas (require ,(->string source-name)) + (set-current-ptree (make-project-ptree ,pollen-project-directory)) + (set-current-url-context ,pollen-project-directory) (include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name))) (current-namespace)))) diff --git a/world.rkt b/world.rkt index 749e200..68129c7 100644 --- a/world.rkt +++ b/world.rkt @@ -35,7 +35,7 @@ (define POLLEN_ROOT 'main) ; get the starting directory, which is the parent of 'run-file -(define START_DIR +(define POLLEN_PROJECT_DIR (let-values ([(dir ignored also-ignored) (split-path (find-system-path 'run-file))]) (if (equal? dir 'relative)