From 4af414708708e96de9f2d8cf747eddaa238b6507 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 27 Nov 2013 22:57:50 -0800 Subject: [PATCH] updates --- main-helper.rkt | 8 +- main-imports.rkt | 2 +- main.rkt | 34 ++++---- predicates.rkt | 24 +++--- ptree.rkt | 198 ++++++++++++++++++++++++----------------------- template.rkt | 11 ++- 6 files changed, 144 insertions(+), 133 deletions(-) diff --git a/main-helper.rkt b/main-helper.rkt index 362d37a..aa2f4a8 100644 --- a/main-helper.rkt +++ b/main-helper.rkt @@ -37,7 +37,7 @@ ;; We want to make this identifier behave as a runtime function ;; This requires two steps. ;; First, define the underlying function as syntax-rule -(define-syntax (get-here stx) +(define-syntax (get-here-path stx) (datum->syntax stx '(begin ;; Even though begin permits defines, @@ -45,7 +45,7 @@ ;; whereupon define would cause an error. ;; Therefore, best to use let. (let* ([ccr (current-contract-region)] ; trick for getting current module name - [here-path (cond + [hp (cond ;; if contract-region is called from within submodule, ;; you get a list ;; in which case, just grab the path from the front @@ -59,7 +59,7 @@ ;; so raises possibility of inconsistent values. ;; Whereas the complete path is unambiguous, ;; and can be made relative by the caller (or otherwise altered). - (->string here-path))))) + (->string hp))))) ;; todo: update tests ;(module+ test @@ -68,7 +68,7 @@ ; Second step: apply a separate syntax transform to the identifier itself ; We can't do this in one step, because if the macro goes from identifier to function definition, ; The macro processor will evaluate the body at compile-time, not at runtime. -(define-syntax here (λ(stx) (datum->syntax stx '(get-here)))) +(define-syntax here-path (λ(stx) (datum->syntax stx '(get-here-path)))) ;; todo: update test ;(module+ test diff --git a/main-imports.rkt b/main-imports.rkt index 72fa72d..ba9f7ab 100644 --- a/main-imports.rkt +++ b/main-imports.rkt @@ -8,7 +8,7 @@ (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/ptree) ptree-source-decode path->name) (only-in (planet mb/pollen/predicates) ptree?)) (provide (all-from-out racket/list diff --git a/main.rkt b/main.rkt index 4d8d8c3..3e90f3e 100644 --- a/main.rkt +++ b/main.rkt @@ -42,23 +42,26 @@ ;; set up a hook for identifier 'here' ;; (but under a different name to avoid macrofication) - (define inner-here here) + (define inner-here-path here-path) (provide (all-defined-out)) (provide (all-from-out ; pollen file should bring its requires (planet mb/pollen/tools)))) (require 'pollen-inner) ; provides doc & #%top, among other things - ;; prepare the elements, and append inner-here as meta. - (define all-elements (cons - ;; append inner-here as meta - ;; put it first so it can be overridden by custom meta later on - `(meta "here" ,inner-here) - (cond - ;; doc is probably a list, but might be a single string - [(string? doc) (list doc)] - [(tagged-xexpr? doc) (list doc)] ; if it's a single nx, just leave it - [(list? doc) doc]))) ; if it's nx content, splice it in + (define here (path->name inner-here-path)) + + ;; prepare the elements, and append inner-here-path as meta. + ;; put it first so it can be overridden by custom meta later on + (define all-elements (cons `(meta "here-path" ,inner-here-path) + (cons `(meta "here" ,here) + (cond + ;; doc is probably a list, but might be a single string + [(string? doc) (list doc)] + ;; if it's a single nx, just leave it + [(tagged-xexpr? doc) (list doc)] + ;; if it's nx content, splice it in + [(list? doc) doc])))) ;; split out the metas now (in raw form) @@ -78,7 +81,7 @@ ;; Because if it's overridden to something other than *.ptree, ;; ptree processing will fail. ;; This defeats rule that ptree file suffix triggers ptree decoding. - (define here-is-ptree? (ptree-source? (->path inner-here))) + (define here-is-ptree? (ptree-source? (->path inner-here-path))) (define main (apply (if here-is-ptree? ;; ptree source files will go this way, @@ -89,9 +92,10 @@ ;; it just hits #%top and becomes a tagged-xexpr. root) (tagged-xexpr-elements main-raw))) - (provide main metas - (except-out (all-from-out 'pollen-inner) inner-here) ; everything from user - (rename-out (inner-here here))) ; change identifier back (now safe from macrofication) + + (provide main metas here + (except-out (all-from-out 'pollen-inner) inner-here-path) ; everything from user + (rename-out (inner-here-path here-path))) ; change identifier back (now safe from macrofication) (module+ main (displayln ";-------------------------") diff --git a/predicates.rkt b/predicates.rkt index 8653b0b..6bd8845 100644 --- a/predicates.rkt +++ b/predicates.rkt @@ -161,7 +161,7 @@ ;; certain ptree requirements are enforced at compile-time. -;; (such as pnodes must be valid strings, and unique.) +;; (such as names must be valid strings, and unique.) ;; otherwise this becomes a rather expensive contract ;; because every function in ptree.rkt uses it. ;; note that a ptree is just a bunch of recursively nested ptrees. @@ -170,7 +170,7 @@ (and (match x ;; a tagged-xexpr with one attr ('parent) ;; whose subelements recursively meet the same test. - [(list (? pnode? tag) (? ptree-attr? attr) elements ...) + [(list (? ptree-name? tag) (? ptree-attr? attr) elements ...) (andmap ptree? elements)] [else #f]))) @@ -196,7 +196,7 @@ ;; ptree location must represent a possible valid filename -(define/contract (pnode? x #:loud [loud #f]) +(define/contract (ptree-name? x #:loud [loud #f]) ((any/c) (#:loud boolean?) . ->* . boolean?) ;; todo: how to express the fact that the ptree-location must be ;; a valid base name for a file? @@ -205,21 +205,21 @@ (define result (or (eq? x #f) ; OK for map-key to be #f (and (or (symbol? x) (string? x)) - ;; todo: should test be same as valid module name? + ;; todo: should test be same as valid module ptree-name? (->boolean (regexp-match #px"^[-_A-Za-z0-9]+$" (->string x)))))) (if (and (not result) loud) (error "Not a valid ptree key:" x) result)) (module+ test - (check-true (pnode? #f)) - (check-true (pnode? "foo-bar")) - (check-true (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? "")) - (check-false (pnode? " "))) + (check-true (ptree-name? #f)) + (check-true (ptree-name? "foo-bar")) + (check-true (ptree-name? "Foo_Bar_0123")) + (check-true (ptree-name? 'foo-bar)) + (check-false (ptree-name? "foo-bar.p")) + (check-false (ptree-name? "/Users/MB/foo-bar")) + (check-false (ptree-name? "")) + (check-false (ptree-name? " "))) ;; recursive whitespace test diff --git a/ptree.rkt b/ptree.rkt index aacb458..03e31f9 100644 --- a/ptree.rkt +++ b/ptree.rkt @@ -19,7 +19,7 @@ (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))))) + (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->name files))))) ;; Try loading from ptree file, or failing that, synthesize ptree. @@ -50,12 +50,14 @@ ;; 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)]) +(define/contract (parent name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?)) + (and name (let ([result (se-path* `(,(->symbol name) #:parent) ptree)]) (and result (->string result))))) ; se-path* returns #f if nothing found +(define ptree-parent parent) + (module+ test (define test-ptree-main `(ptree-main "foo" "bar" (one (two "three")))) (define test-ptree (ptree-root->ptree test-ptree-main)) @@ -65,12 +67,12 @@ -; get children of a particular pnode -(define/contract (children pnode [ptree current-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) +; get children of a particular name +(define/contract (children name [ptree current-ptree]) + ((ptree-name?) (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 name (let ([children (se-path*/list `(,(->symbol name)) ptree)]) + ; If there are sublists, just take first name (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) (module+ test @@ -81,11 +83,11 @@ ;; 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)) +(define/contract (siblings name [ptree current-ptree]) + ;; this never returns false: name is always a sibling of itself. + ;; todo: how to use input value in contract? e.g., to check that name is part of output list + ((ptree-name?) (ptree?) . ->* . (or/c list? boolean?)) + (children (parent name ptree) ptree)) (module+ test (check-equal? (siblings 'one test-ptree) '("foo" "bar" "one")) @@ -95,11 +97,11 @@ -(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)))))]) +(define/contract (siblings-split name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (values (or/c (listof ptree-name?) boolean?) + (or/c (listof ptree-name?) boolean?))) + (let-values ([(left right) (splitf-at (siblings name ptree) + (λ(e) (not (equal? (->string e) (->string name)))))]) (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right))))) (module+ test @@ -107,18 +109,18 @@ (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)]) +;; siblings to the left of target name (i.e., precede in tree order) +(define (siblings-left name [ptree current-ptree]) + (let-values ([(left right) (siblings-split name 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)]) +;; siblings to the right of target name (i.e., follow in tree order) +(define (siblings-right name [ptree current-ptree]) + (let-values ([(left right) (siblings-split name ptree)]) right)) (module+ test @@ -126,20 +128,20 @@ (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)]) +;; get name immediately to the left in tree +(define/contract (sibling-previous name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-left name 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)]) +;; get name immediately to the right in tree +(define/contract (sibling-next name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-right name ptree)]) (and siblings (first siblings)))) (module+ test @@ -148,106 +150,108 @@ ;; flatten tree to sequence -(define/contract (all-pnodes [ptree current-ptree]) +(define/contract (all-names [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-pnodes test-ptree) '("foo" "bar" "one" "two" "three"))) + (check-equal? (all-names test-ptree) '("foo" "bar" "one" "two" "three"))) -;; helper function for get-previous-pnodes and get-next-pnodes -(define/contract (adjacent-pnodes side pnode [ptree current-ptree]) - ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?)) +;; helper function for get-previous-names and get-next-names +(define/contract (adjacent-names side name [ptree current-ptree]) + ((symbol? ptree-name?) (ptree?) . ->* . (or/c list? boolean?)) (let ([result ((if (equal? side 'left) takef - takef-right) (all-pnodes ptree) - (λ(y) (not (equal? (->string pnode) (->string y)))))]) + takef-right) (all-names ptree) + (λ(y) (not (equal? (->string name) (->string y)))))]) (and (not (empty? result)) result))) (module+ test - (check-equal? (adjacent-pnodes 'left 'one test-ptree) '("foo" "bar")) - (check-equal? (adjacent-pnodes 'left 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (adjacent-pnodes 'left 'foo test-ptree))) + (check-equal? (adjacent-names 'left 'one test-ptree) '("foo" "bar")) + (check-equal? (adjacent-names 'left 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (adjacent-names 'left 'foo test-ptree))) -;; get sequence of earlier pnodes -(define/contract (previous-pnodes pnode [ptree current-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pnodes 'left pnode ptree)) +;; get sequence of earlier names +(define/contract (ptree-previous* name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-names 'left name ptree)) (module+ test - (check-equal? (previous-pnodes 'one test-ptree) '("foo" "bar")) - (check-equal? (previous-pnodes 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (previous-pnodes 'foo test-ptree))) + (check-equal? (ptree-previous* 'one test-ptree) '("foo" "bar")) + (check-equal? (ptree-previous* 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (ptree-previous* 'foo test-ptree))) -;; get sequence of next pnodes -(define (next-pnodes pnode [ptree current-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pnodes 'right pnode ptree)) +;; get sequence of next names +(define (ptree-next* name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-names 'right name ptree)) (module+ test - (check-equal? (next-pnodes 'foo test-ptree) '("bar" "one" "two" "three")) - (check-equal? (next-pnodes 'one test-ptree) '("two" "three")) - (check-false (next-pnodes 'three test-ptree))) - -;; get pnode immediately previous -(define/contract (previous-pnode pnode [ptree current-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (previous-pnodes pnode ptree)]) + (check-equal? (ptree-next* 'foo test-ptree) '("bar" "one" "two" "three")) + (check-equal? (ptree-next* 'one test-ptree) '("two" "three")) + (check-false (ptree-next* 'three test-ptree))) + +;; get name immediately previous +(define/contract (ptree-previous name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (ptree-previous* name ptree)]) (and result (last result)))) (module+ test - (check-equal? (previous-pnode 'one test-ptree) "bar") - (check-equal? (previous-pnode 'three test-ptree) "two") - (check-false (previous-pnode 'foo test-ptree))) - -;; get pnode immediately next -(define (next-pnode pnode [ptree current-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (next-pnodes pnode ptree)]) + (check-equal? (ptree-previous 'one test-ptree) "bar") + (check-equal? (ptree-previous 'three test-ptree) "two") + (check-false (ptree-previous 'foo test-ptree))) + +;; get name immediately next +(define (ptree-next name [ptree current-ptree]) + ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (ptree-next* name ptree)]) (and result (first result)))) (module+ test - (check-equal? (next-pnode 'foo test-ptree) "bar") - (check-equal? (next-pnode 'one test-ptree) "two") - (check-false (next-pnode 'three test-ptree))) - -;; convert path to pnode -;; used for converting "here" values to pnodes -(define/contract (path->pnode x) - (pathish? . -> . pnode?) + (check-equal? (ptree-next 'foo test-ptree) "bar") + (check-equal? (ptree-next 'one test-ptree) "two") + (check-false (ptree-next 'three test-ptree))) + +;; convert path to name +;; used for converting "here" values to names +(define/contract (path->name x) + (pathish? . -> . ptree-name?) (->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")) + (check-equal? (path->name "bar") "bar") + (check-equal? (path->name "foo/bar") "bar") + (check-equal? (path->name "foo/bar.html") "bar") + (check-equal? (path->name "/Users/this/that/foo/bar.html.pp") "bar")) -(define here->pnode path->pnode) +(define here->name path->name) -(define/contract (pnode->url pnode [files current-url-context]) - ((pnode?) ((listof pathish?)) . ->* . (or/c string? boolean?)) +(define/contract (name->url name [files current-url-context]) + ((ptree-name?) ((listof pathish?)) . ->* . (or/c string? boolean?)) ;; 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) (equal? (path->pnode x) (->string pnode))) output-paths)) + ;; find ones that match name + (define matching-paths (filter (λ(x) (equal? (path->name x) (->string name))) output-paths)) (cond [((len matching-paths) . = . 1) (->string (car matching-paths))] - [((len matching-paths) . > . 1) (error "More than one matching URL for" pnode)] + [((len matching-paths) . > . 1) (error "More than one matching URL for" name)] [else #f] )) +(define ptree-name->url name->url) + (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-false (pnode->url 'hee files))) + (check-equal? (name->url 'foo files) "foo.html") + (check-equal? (name->url 'bar files) "bar.html") + ;; (check-equal? (name->url 'zap files) 'error) ;; todo: how to test error? + (check-false (name->url 'hee files))) ;; recursively processes tree, converting tree locations & their parents into xexprs of this shape: @@ -280,19 +284,19 @@ ;; contract for ptree-source-decode -(define/contract (valid-pnodes? x) +(define/contract (valid-names? x) (any/c . -> . boolean?) - (andmap (λ(x) (pnode? #:loud #t x)) (filter-not whitespace? (flatten x)))) + (andmap (λ(x) (ptree-name? #:loud #t x)) (filter-not whitespace? (flatten x)))) ;; contract for ptree-source-decode -(define/contract (unique-pnodes? x) +(define/contract (unique-names? 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?) + (() #:rest (and/c valid-names? unique-names?) . ->* . ptree?) (ptree-root->ptree (decode (cons POLLEN_TREE_ROOT_NAME elements) #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))))) @@ -322,4 +326,4 @@ (displayln "Running module main") (set-current-ptree (make-project-ptree (->path "/Users/MB/git/bpt/"))) (set-current-url-context "/Users/MB/git/bpt/") - (pnode->url (previous-pnode (previous-pnode 'what-is-typography)))) + (name->url (ptree-previous (ptree-previous 'what-is-typography)))) diff --git a/template.rkt b/template.rkt index 5010e04..428fab1 100644 --- a/template.rkt +++ b/template.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/contract racket/string xml xml/path racket/bool) -(require "tools.rkt") +(require "tools.rkt" "ptree.rkt") ;; setup for test cases (module+ test (require rackunit racket/path)) @@ -15,7 +15,9 @@ (define/contract (puttable-item? x) (any/c . -> . boolean?) - (or (tagged-xexpr? x) (has-pollen-source? x))) + (or (tagged-xexpr? x) + (has-pollen-source? x) + (has-pollen-source? (name->url x)))) (define/contract (query-key? x) (any/c . -> . boolean?) @@ -26,7 +28,8 @@ (cond ;; Using put has no effect on tagged-xexprs. It's here to make the idiom smooth. [(tagged-xexpr? x) x] - [(has-pollen-source? x) (dynamic-require (->pollen-source-path x) 'main)])) + [(has-pollen-source? x) (dynamic-require (->pollen-source-path x) 'main)] + [(has-pollen-source? (name->url x)) (dynamic-require (->pollen-source-path (name->url x)) 'main)])) (module+ test (check-equal? (put '(foo "bar")) '(foo "bar")) @@ -58,7 +61,7 @@ (let* ([metas (dynamic-require (->pollen-source-path 'put) 'metas)] [here (find-in-metas 'put 'here)] [here-relative (list (->string (find-relative-path (current-directory) (car here))))]) - (check-equal? here-relative (list "put.p"))))) + (check-equal? here-relative (list "put"))))) (define/contract (find-in-main px query)