diff --git a/library/html.rkt b/library/html.rkt index 8be96b8..ec748bc 100644 --- a/library/html.rkt +++ b/library/html.rkt @@ -1,7 +1,5 @@ #lang racket/base -(require "../syntax.rkt") - ;; for now, body is deemed a block, not inline ;; todo: is this legit? Why is body inline? (define block-tags diff --git a/main-helper.rkt b/main-helper.rkt index 52836cd..f2704a8 100644 --- a/main-helper.rkt +++ b/main-helper.rkt @@ -55,10 +55,10 @@ [(equal? 'pollen-lang-module ccr) 'nowhere] [else ccr])]) (match-let-values ([(_ here-name _) (split-path ccr)]) - (->string (remove-all-ext here-name))))))) + (->string here-name)))))) (module+ test - (check-equal? (get-here) "main-helper")) + (check-equal? (get-here) "main-helper.rkt")) ; 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, @@ -66,6 +66,6 @@ (define-syntax here (λ (stx) (datum->syntax stx '(get-here)))) (module+ test - (check-equal? here "main-helper")) + (check-equal? here "main-helper.rkt")) diff --git a/map.rkt b/map.rkt deleted file mode 100644 index 3f8dced..0000000 --- a/map.rkt +++ /dev/null @@ -1,251 +0,0 @@ -#lang racket/base -(require xml xml/path racket/list racket/string racket/contract racket/match racket/set) -(require "tools.rkt" "world.rkt" "decode.rkt") - -(module+ test (require rackunit)) - -; get the values out of the file, or make them up -(define map-file (build-path START_DIR DEFAULT_MAP)) -(define map-main empty) - - -;; todo: this ain't a function -(if (file-exists? map-file) - ; load it, or ... - (set! map-main (dynamic-require map-file POLLEN_ROOT)) - ; ... synthesize it - (let ([files (directory-list START_DIR)]) - (set! files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))) - (set! map-main (make-tagged-xexpr 'map-main empty (map path->string files))))) - -;; todo: restrict this test -;; all names must be unique -(define/contract (map-tree? x) - (any/c . -> . boolean?) - (and (tagged-xexpr? x) - ;; all locations must be unique. Check this by converting x to a list of strings ... - (let ([locations (map ->string (flatten (remove-attrs x)))]) - ;; and then coercing to set (because set impliedly enforces uniqueness) - ;; If set has same number of elements as original, all are unique. - (= (len (apply set locations)) (len locations))))) - -;; recursively processes tree, converting map locations & their parents into xexprs of this shape: -;; '(location ((parent "parent"))) -(define/contract (add-parents x [parent empty]) - ((map-tree?) (xexpr-tag?) . ->* . map-tree?) - ; disallow map-main as parent tag - ; (when (equal? parent 'map-main) (set! parent empty)) - (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 'parent (->string parent)))])) - -(module+ test - (define test-map `(map-main "foo" "bar" ,(map-topic "one" (map-topic "two" "three")))) - (check-equal? (add-parents test-map) - '(map-main ((parent "")) (foo ((parent "map-main"))) (bar ((parent "map-main"))) (one ((parent "map-main")) (two ((parent "one")) (three ((parent "two")))))))) - -;; 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) - (map-tree? . -> . map-tree?) - (remove-attrs mt)) - -(module+ test - (check-equal? (remove-parents - '(map-main ((parent "")) (foo ((parent ""))) (bar ((parent ""))) - (one ((parent "")) (two ((parent "one")) (three ((parent "two"))))))) - '(map-main (foo) (bar) (one (two (three)))))) - -;; todo: what is this for? -(define/contract (main->tree main) - (tagged-xexpr? . -> . map-tree?) - (let-values ([(nx metas) (extract-tag-from-xexpr 'meta main)]) - (add-parents nx))) - -(module+ test - (define mt-map `(map-main "foo" "bar" ,(map-topic "one" (map-topic "two" "three")) (meta "foo" "bar"))) - (check-equal? (main->tree mt-map) - '(map-main ((parent "")) (foo ((parent "map-main"))) (bar ((parent "map-main"))) (one ((parent "map-main")) (two ((parent "one")) (three ((parent "two")))))))) - - -;; todo: what is this for? to have default input? -(define tree (main->tree map-main)) - - -(define/contract (map-key? x) - (any/c . -> . boolean?) - ;; OK for map-key to be #f - (or (symbol? x) (string? x) (eq? x #f))) - -;; return the parent of a given name -(define/contract (parent element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c string? boolean?)) - (and element (let ([result (se-path* `(,(->symbol element) #:parent) tree)]) - (and result (->string result))))) ; se-path* returns #f if nothing found - - -(module+ test - (define test-tree (main->tree test-map)) - (check-equal? (parent 'three test-tree) "two") - (check-equal? (parent "three" test-tree) "two") - (check-false (parent 'nonexistent-name test-tree))) - - - -; get children of a particular element -(define/contract (children element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c list? boolean?)) - ;; se-path*/list returns '() if nothing found - (and element (let ([children (se-path*/list `(,(->symbol element)) tree)]) - ; If there are sublists, just take first element - (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) - -(module+ test - (check-equal? (children 'one test-tree) (list "two")) - (check-equal? (children 'two test-tree) (list "three")) - (check-false (children 'three test-tree)) - (check-false (children 'fooburger test-tree))) - - -;; find all siblings on current level: go up to parent and ask for children -(define/contract (siblings element [tree tree]) - ;; this never returns false: element is always a sibling of itself. - ;; todo: how to use input value in contract? e.g., to check that element is part of output list - ((map-key?) (map-tree?) . ->* . (or/c list? boolean?)) - (children (parent element tree) tree)) - -(module+ test - (check-equal? (siblings 'one test-tree) '("foo" "bar" "one")) - (check-equal? (siblings 'foo test-tree) '("foo" "bar" "one")) - (check-equal? (siblings 'two test-tree) '("two")) - (check-false (siblings 'invalid-key test-tree))) - -;; helper function -(define/contract (side-siblings side element [tree tree]) - ((symbol? map-key?) (map-tree?) . ->* . (or/c list? boolean?)) - (define result ((if (equal? side 'left) takef takef-right) - (siblings element tree) - (λ(i) (not (equal? (->string element) (->string i)))))) - (and (not (empty? result)) result)) - - -(define/contract (map-split element elements) - (map-key? (listof map-key?) . -> . (values (listof map-key?) (listof map-key?))) - (define-values (left right) (splitf-at elements - (λ(e) (not (equal? (->string e) (->string element)))))) - (values left (cdr right))) - -(module+ test - (check-equal? (values->list (map-split 'bar (siblings 'bar test-tree))) (list '("foo") '("one")))) - - -;; siblings to the left of target element (i.e., precede in map order) -(define (left-siblings element [tree tree]) - (side-siblings 'left element tree)) - -(module+ test - (check-equal? (left-siblings 'one test-tree) '("foo" "bar")) - (check-false (left-siblings 'foo test-tree))) - -;; siblings to the right of target element (i.e., follow in map order) -(define (right-siblings element [tree tree]) - (side-siblings 'right element tree)) - -(module+ test - (check-false (right-siblings 'one test-tree)) - (check-equal? (right-siblings 'foo test-tree) '("bar" "one"))) - - -;; get element immediately to the left in map -(define/contract (left-sibling element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c string? boolean?)) - (define siblings (left-siblings element tree)) - (and siblings (last siblings))) - -(module+ test - (check-equal? (left-sibling 'bar test-tree) "foo") - (check-false (left-sibling 'foo test-tree))) - -;; get element immediately to the right in map -(define/contract (right-sibling element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c string? boolean?)) - (define siblings (right-siblings element tree)) - (and siblings (first siblings))) - -(module+ test - (check-equal? (right-sibling 'foo test-tree) "bar") - (check-false (right-sibling 'one test-tree))) - - -;; flatten tree to sequence -(define/contract (make-page-sequence [tree tree]) - (map-tree? . -> . (listof string?)) - ; use cdr to get rid of main-map tag at front - (map ->string (cdr (flatten (remove-parents tree))))) - -(module+ test - (check-equal? (make-page-sequence test-tree) '("foo" "bar" "one" "two" "three"))) - -;; helper function for get-previous-pages and get-next-pages -(define/contract (adjacent-pages side element [tree tree]) - ((map-key? symbol?) (map-tree?) . ->* . (or/c list? boolean?)) - (define result ((if (equal? side 'left) takef takef-right) - (make-page-sequence tree) (λ(y) (not (equal? (->string element) (->string y)))))) - (and (not (empty? result)) result)) - -(module+ test - (check-equal? (adjacent-pages 'left 'one test-tree) '("foo" "bar")) - (check-equal? (adjacent-pages 'left 'three test-tree) '("foo" "bar" "one" "two")) - (check-false (adjacent-pages 'left 'foo test-tree))) - - -;; get sequence of earlier pages -(define/contract (previous-pages element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'left element tree)) - -(module+ test - (check-equal? (previous-pages 'one test-tree) '("foo" "bar")) - (check-equal? (previous-pages 'three test-tree) '("foo" "bar" "one" "two")) - (check-false (previous-pages 'foo test-tree))) - - -;; get sequence of next pages -(define (next-pages element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'right element tree)) - -(module+ test - (check-equal? (next-pages 'foo test-tree) '("bar" "one" "two" "three")) - (check-equal? (next-pages 'one test-tree) '("two" "three")) - (check-false (next-pages 'three test-tree))) - -;; get page immediately previous -(define/contract (previous-page element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c string? boolean?)) - (define result (previous-pages element tree)) - (and result (last result))) - -(module+ test - (check-equal? (previous-page 'one test-tree) "bar") - (check-equal? (previous-page 'three test-tree) "two") - (check-false (previous-page 'foo test-tree))) - -;; get page immediately next -(define (next-page element [tree tree]) - ((map-key?) (map-tree?) . ->* . (or/c string? boolean?)) - (define result (next-pages element tree)) - (and result (first result))) - -(module+ test - (check-equal? (next-page 'foo test-tree) "bar") - (check-equal? (next-page 'one test-tree) "two") - (check-false (next-page 'three test-tree))) - -(provide (all-defined-out)) \ No newline at end of file diff --git a/pmap.rkt b/pmap.rkt new file mode 100644 index 0000000..d3c9190 --- /dev/null +++ b/pmap.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require xml xml/path 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)) + +; get the values out of the file, or make them up +(define pmap-file (build-path START_DIR DEFAULT_MAP)) +(define pmap-main empty) + +;; todo: this ain't a function +(if (file-exists? pmap-file) + ; load it, or ... + (set! pmap-main (dynamic-require pmap-file POLLEN_ROOT)) + ; ... synthesize it + (let ([files (directory-list START_DIR)]) + (set! files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))) + (set! pmap-main (make-tagged-xexpr 'map-main empty (map path->string files))))) + +;; todo: restrict this test +;; all names must be unique +(define/contract (pmap? x) + (any/c . -> . boolean?) + (and (tagged-xexpr? x) + ;; all locations must be unique. Check this by converting x to a list of strings ... + (let ([locations (map ->string (flatten (remove-attrs x)))]) + ;; and then coercing to set (because set impliedly enforces uniqueness) + ;; If set has same number of elements as original, all are unique. + (= (len (apply set locations)) (len locations))))) + +;; recursively processes map, converting map locations & their parents into xexprs of this shape: +;; '(location ((parent "parent"))) +(define/contract (add-parents x [parent empty]) + ((pmap?) (xexpr-tag?) . ->* . pmap?) + ; disallow map-main as parent tag + ; (when (equal? parent 'map-main) (set! parent empty)) + (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 'parent (->string parent)))])) + +(module+ test + (define test-pmap-main `(pmap-main "foo" "bar" ,(pmap-topic "one" (pmap-topic "two" "three")))) + (check-equal? (add-parents test-pmap-main) + '(pmap-main ((parent "")) (foo ((parent "pmap-main"))) (bar ((parent "pmap-main"))) (one ((parent "pmap-main")) (two ((parent "one")) (three ((parent "two")))))))) + +;; remove parents from map (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) + (pmap? . -> . pmap?) + (remove-attrs mt)) + +(module+ test + (check-equal? (remove-parents + '(pmap-main ((parent "")) (foo ((parent ""))) (bar ((parent ""))) + (one ((parent "")) (two ((parent "one")) (three ((parent "two"))))))) + '(pmap-main (foo) (bar) (one (two (three)))))) + +;; todo: what is this for? +(define/contract (main->pmap main) + (tagged-xexpr? . -> . pmap?) + (let-values ([(nx metas) (extract-tag-from-xexpr 'meta main)]) + (add-parents nx))) + +(module+ test + (define mt-pmap `(pmap-main "foo" "bar" ,(pmap-topic "one" (pmap-topic "two" "three")) (meta "foo" "bar"))) + (check-equal? (main->pmap mt-pmap) + '(pmap-main ((parent "")) (foo ((parent "pmap-main"))) (bar ((parent "pmap-main"))) (one ((parent "pmap-main")) (two ((parent "one")) (three ((parent "two")))))))) + + +;; todo: what is this for? to have default input? +(define pmap (main->pmap pmap-main)) + + +(define/contract (pmap-key? x) + (any/c . -> . boolean?) + ;; OK for map-key to be #f + (or (symbol? x) (string? x) (eq? x #f))) + +;; return the parent of a given name +(define/contract (parent element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) + (and element (let ([result (se-path* `(,(->symbol element) #:parent) pmap)]) + (and result (->string result))))) ; se-path* returns #f if nothing found + + +(module+ test + (define test-pmap (main->pmap test-pmap-main)) + (check-equal? (parent 'three test-pmap) "two") + (check-equal? (parent "three" test-pmap) "two") + (check-false (parent 'nonexistent-name test-pmap))) + + + +; get children of a particular element +(define/contract (children element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + ;; se-path*/list returns '() if nothing found + (and element (let ([children (se-path*/list `(,(->symbol element)) pmap)]) + ; If there are sublists, just take first element + (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) + +(module+ test + (check-equal? (children 'one test-pmap) (list "two")) + (check-equal? (children 'two test-pmap) (list "three")) + (check-false (children 'three test-pmap)) + (check-false (children 'fooburger test-pmap))) + + +;; find all siblings on current level: go up to parent and ask for children +(define/contract (siblings element [pmap pmap]) + ;; this never returns false: element is always a sibling of itself. + ;; todo: how to use input value in contract? e.g., to check that element is part of output list + ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + (children (parent element pmap) pmap)) + +(module+ test + (check-equal? (siblings 'one test-pmap) '("foo" "bar" "one")) + (check-equal? (siblings 'foo test-pmap) '("foo" "bar" "one")) + (check-equal? (siblings 'two test-pmap) '("two")) + (check-false (siblings 'invalid-key test-pmap))) + +;; helper function +(define/contract (side-siblings side element [pmap pmap]) + ((symbol? pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + (define result ((if (equal? side 'left) takef takef-right) + (siblings element pmap) + (λ(i) (not (equal? (->string element) (->string i)))))) + (and (not (empty? result)) result)) + + +(define/contract (pmap-split element elements) + (pmap-key? (listof pmap-key?) . -> . (values (listof pmap-key?) (listof pmap-key?))) + (define-values (left right) (splitf-at elements + (λ(e) (not (equal? (->string e) (->string element)))))) + (values left (cdr right))) + +(module+ test + (check-equal? (values->list (pmap-split 'bar (siblings 'bar test-pmap))) (list '("foo") '("one")))) + + +;; siblings to the left of target element (i.e., precede in map order) +(define (left-siblings element [pmap pmap]) + (side-siblings 'left element pmap)) + +(module+ test + (check-equal? (left-siblings 'one test-pmap) '("foo" "bar")) + (check-false (left-siblings 'foo test-pmap))) + +;; siblings to the right of target element (i.e., follow in map order) +(define (right-siblings element [pmap pmap]) + (side-siblings 'right element pmap)) + +(module+ test + (check-false (right-siblings 'one test-pmap)) + (check-equal? (right-siblings 'foo test-pmap) '("bar" "one"))) + + +;; get element immediately to the left in map +(define/contract (left-sibling element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) + (define siblings (left-siblings element pmap)) + (and siblings (last siblings))) + +(module+ test + (check-equal? (left-sibling 'bar test-pmap) "foo") + (check-false (left-sibling 'foo test-pmap))) + +;; get element immediately to the right in map +(define/contract (right-sibling element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) + (define siblings (right-siblings element pmap)) + (and siblings (first siblings))) + +(module+ test + (check-equal? (right-sibling 'foo test-pmap) "bar") + (check-false (right-sibling 'one test-pmap))) + + +;; flatten map to sequence +(define/contract (make-page-sequence [pmap pmap]) + (pmap? . -> . (listof string?)) + ; use cdr to get rid of main-map tag at front + (map ->string (cdr (flatten (remove-parents pmap))))) + +(module+ test + (check-equal? (make-page-sequence test-pmap) '("foo" "bar" "one" "two" "three"))) + +;; helper function for get-previous-pages and get-next-pages +(define/contract (adjacent-pages side element [pmap pmap]) + ((symbol? pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + (define result ((if (equal? side 'left) takef takef-right) + (make-page-sequence pmap) (λ(y) (not (equal? (->string element) (->string y)))))) + (and (not (empty? result)) result)) + +(module+ test + (check-equal? (adjacent-pages 'left 'one test-pmap) '("foo" "bar")) + (check-equal? (adjacent-pages 'left 'three test-pmap) '("foo" "bar" "one" "two")) + (check-false (adjacent-pages 'left 'foo test-pmap))) + + +;; get sequence of earlier pages +(define/contract (previous-pages element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'left element pmap)) + +(module+ test + (check-equal? (previous-pages 'one test-pmap) '("foo" "bar")) + (check-equal? (previous-pages 'three test-pmap) '("foo" "bar" "one" "two")) + (check-false (previous-pages 'foo test-pmap))) + + +;; get sequence of next pages +(define (next-pages element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'right element pmap)) + +(module+ test + (check-equal? (next-pages 'foo test-pmap) '("bar" "one" "two" "three")) + (check-equal? (next-pages 'one test-pmap) '("two" "three")) + (check-false (next-pages 'three test-pmap))) + +;; get page immediately previous +(define/contract (previous-page element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) + (define result (previous-pages element pmap)) + (and result (last result))) + +(module+ test + (check-equal? (previous-page 'one test-pmap) "bar") + (check-equal? (previous-page 'three test-pmap) "two") + (check-false (previous-page 'foo test-pmap))) + +;; get page immediately next +(define (next-page element [pmap pmap]) + ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) + (define result (next-pages element pmap)) + (and result (first result))) + +(module+ test + (check-equal? (next-page 'foo test-pmap) "bar") + (check-equal? (next-page 'one test-pmap) "two") + (check-false (next-page 'three test-pmap))) + +(module+ test + ;; need to parameterize current-directory + ;; because pollen main depends on it to find the include functions + (define pm (parameterize ([current-directory "./tests/"]) + (main->pmap (dynamic-require "test-pmap.p" 'main)))) + (check-equal? (previous-page (parent 'printers-and-paper pm) pm) "ligatures")) \ No newline at end of file diff --git a/pollen-file-tools.rkt b/pollen-file-tools.rkt index fd7cdf4..a55792b 100644 --- a/pollen-file-tools.rkt +++ b/pollen-file-tools.rkt @@ -75,6 +75,16 @@ (check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext (check-equal? (remove-all-ext foo.bar.txt-path) foo-path)) + +(define/contract (filename-of path) + (complete-path? . -> . path?) + (define-values (dir filename ignored) (split-path path)) + filename) + +(module+ test + (check-equal? (filename-of (build-path (current-directory) "pollen-file-tools.rkt")) (->path "pollen-file-tools.rkt"))) + + (define/contract (preproc-source? x) (any/c . -> . boolean?) (has-ext? (->path x) POLLEN_PREPROC_EXT)) diff --git a/readability.rkt b/readability.rkt index b865e7a..926e6e4 100644 --- a/readability.rkt +++ b/readability.rkt @@ -148,12 +148,13 @@ [else #f])) ;; don't return single-item results inside a list - (if (and (sliceable-container? result) (= (len result) 1)) + (if (and (sliceable-container? container) (= (len result) 1)) (car (->list result)) result)) (module+ test (check-equal? (get '(0 1 2 3 4 5) 2) 2) + (check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2)) (check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1)) (check-equal? (get '(0 1 2 3 4 5) 2 -1) '(2 3 4)) (check-equal? (get '(0 1 2 3 4 5) 2 'end) '(2 3 4 5)) @@ -169,7 +170,7 @@ (check-equal? (get 'purple 0 2) 'pu) (check-equal? (get 'purple 2 -1) 'rpl) (check-equal? (get 'purple 2 'end) 'rple) - (check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'a) 1)) + (check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1))) ;; general way of testing for membership (à la Python 'in') ;; put item as first arg so function can use infix notation diff --git a/regenerate.rkt b/regenerate.rkt index 05c7708..b1a8207 100644 --- a/regenerate.rkt +++ b/regenerate.rkt @@ -1,56 +1,96 @@ -#lang racket -(require xml/path) -(require "world.rkt" "tools.rkt" "map.rkt") -(require racket/rerequire) - -; hash of mod-dates takes lists of paths as keys, -; and lists of modification times as values. -; Reason: a templated page is a combination of two source files. -; Because templates have a one-to-many relationship with source files, -; Need to track template mod-date for each source file. -; Otherwise a changed template will get reloaded only once, -; and after that get reported as being up to date. -; Possible: store hash on disk so mod records are preserved -; between development sessions (prob a worthless optimization) +#lang racket/base +(require racket/list racket/path racket/port racket/system + racket/file racket/rerequire racket/contract) +(require "world.rkt" "tools.rkt" "pmap.rkt" "readability.rkt") + +(module+ test (require rackunit)) + +;; mod-dates is a hash that takes lists of paths as keys, +;; and lists of modification times as values. +;; Reason: a templated page is a combination of two source files. +;; Because templates have a one-to-many relationship with source files, +;; Need to track template mod-date for each source file. +;; Otherwise a changed template will get reloaded only once, +;; and after that get reported as being up to date. +;; Possible: store hash on disk so mod records are preserved +;; between development sessions (prob a worthless optimization) (define mod-dates (make-hash)) -(define (mod-date . paths) - (set! paths (flatten paths)) - (when (andmap file-exists? paths) - (map file-or-directory-modify-seconds paths))) -(define (log-refresh . paths) - (set! paths (flatten paths)) - (hash-set! mod-dates paths (mod-date paths))) +;; convert a path to a modification date value +(define/contract (path->mod-date-value path) + (path? . -> . (or/c exact-integer? #f)) + (and (file-exists? path) ; returns #f if a file doesn't exist + (file-or-directory-modify-seconds path))) -(define (source-needs-refresh? . paths) - (set! paths (flatten paths)) - (or (not (in? mod-dates paths)) ; no mod date - (not (equal? (mod-date paths) (get mod-dates paths))))) ; data changed +(module+ test + (check-false (path->mod-date-value (->path "foobarfoo.rkt"))) + (check-true (exact-integer? (path->mod-date-value (build-path (current-directory) (->path "regenerate.rkt")))))) + +;; put list of paths into mod-dates +;; want to take list as input (rather than individual path) +;; because hash key needs to be a list +(define/contract (store-refresh-in-mod-dates paths) + ((listof path?) . -> . void?) + (hash-set! mod-dates paths (map path->mod-date-value paths))) + +(module+ test + (reset-mod-dates) + (store-refresh-in-mod-dates (list (build-path (current-directory) (->path "regenerate.rkt")))) + (check-true (= (len mod-dates) 1)) + (reset-mod-dates)) + +;; when you want to generate everything fresh, +;; but without having to #:force everything. +;; Regenerate functions will always go when no mod-date is found. +(define/contract (reset-mod-dates) + (-> void?) + (set! mod-dates (make-hash))) + +(module+ test + (reset-mod-dates) + (store-refresh-in-mod-dates (list (build-path (current-directory) (->path "regenerate.rkt")))) + (reset-mod-dates) + (check-true (= (len mod-dates) 0))) + +;; how to know whether a certain combination of paths needs a refresh +(define/contract (source-needs-refresh? paths) + ((listof path?) . -> . boolean?) + (or (not (paths . in? . mod-dates)) ; no stored mod date + (not (equal? (map path->mod-date-value paths) (get mod-dates paths))))) ; data has changed + +(module+ test + (reset-mod-dates) + (let ([path (build-path (current-directory) (->path "regenerate.rkt"))]) + (store-refresh-in-mod-dates (list path)) + (check-false (source-needs-refresh? (list path))) + (reset-mod-dates) + (check-true (source-needs-refresh? (list path))))) -; when you want to generate everything fresh, but not force everything -(define (reset-mod-dates) - (let [(keys (hash-keys mod-dates))] - (map (λ(k) (hash-remove mod-dates k)) keys))) ; helper functions for regenerate functions (define pollen-file-root (current-directory)) -(define (regenerate-file f) - (let ([path (build-path pollen-file-root f)]) - (displayln (format "Regenerating: ~a" f)) - (regenerate path))) +; complete pollen path = +;(build-path pollen-file-root f) + + +;; regenerate with message +(define/contract (regenerate-path/message path) + (complete-path? . -> . void?) + (message "Regenerating: " path) + (regenerate path)) + +;; todo: write test -;; todo: maybe move this tools.rkt as a utility -(define (filename-of path) - (let-values ([(dir filename ignored) (split-path path)]) - filename)) +;;;;;;;;;;;;; +;; todo next -(define (regenerate-pmap-pages pmap) - (define pmap-sequence - (make-page-sequence (main->tree (dynamic-require pmap 'main)))) - (displayln (format "Regenerating pages from pollen map: ~a" (filename-of pmap))) - (for-each regenerate-file pmap-sequence)) +(define/contract (regenerate-with-pmap/message pmap) + (pmap-source? . -> . void?) + (message "Regenerating pages from pollen map: " (filename-of pmap)) + (for-each regenerate-path/message + (make-page-sequence (main->pmap (dynamic-require pmap 'main))))) (define (get-pollen-files-with-ext ext) (filter (λ(f) (has-ext? f ext)) (directory-list pollen-file-root))) @@ -60,10 +100,10 @@ (reset-mod-dates) (define all-preproc-files (get-pollen-files-with-ext POLLEN_PREPROC_EXT)) - (for-each regenerate-file all-preproc-files) + (for-each regenerate-path/message all-preproc-files) (define all-pollen-maps (get-pollen-files-with-ext POLLEN_MAP_EXT)) - (for-each regenerate-pmap-pages all-pollen-maps) + (for-each regenerate-with-pmap/message all-pollen-maps) (displayln "Completed")) @@ -77,7 +117,7 @@ (cond [(needs-preproc? path) (do-preproc path #:force force)] [(needs-template? path) (do-template path #:force force)] - [(pmap-source? path) (regenerate-pmap-pages path)]))) + [(pmap-source? path) (regenerate-with-pmap/message path)]))) @@ -96,7 +136,7 @@ (or force (not (file-exists? preproc-out-path)) (source-needs-refresh? preproc-in-path))) - (log-refresh preproc-in-path) + (store-refresh-in-mod-dates preproc-in-path) ; use single quotes to escape spaces in pathnames (define command (format "~a '~a' > '~a'" RACKET_PATH preproc-in-path preproc-out-path)) @@ -160,7 +200,7 @@ (not (file-exists? generated-path)) (source-needs-refresh? source-path template-path) file-was-reloaded?) - (log-refresh source-path template-path) + (store-refresh-in-mod-dates source-path template-path) ; Templates are part of the compile operation. ; Therefore no way to arbitrarily invoke template at run-time. diff --git a/server-routes.rkt b/server-routes.rkt index 37497d0..0cc6b56 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -17,13 +17,12 @@ (complete-path? . -> . tagged-xexpr?) (regenerate path) (dynamic-rerequire path) - (define main (dynamic-require path 'main)) - main) + (dynamic-require path 'main)) + (define/contract (slurp path #:regenerate? [regenerate? #t]) (complete-path? . -> . string?) - (when regenerate? - (regenerate path)) + (when regenerate? (regenerate path)) (file->string path)) (define/contract (format-as-code tx) diff --git a/syntax.rkt b/syntax.rkt deleted file mode 100644 index 963d837..0000000 --- a/syntax.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Macro that generates all the little xexpr functions -;; For each tag. -;; - -(require (for-syntax racket/syntax)) -(define-syntax (define-tags stx) - (syntax-case stx () - [(_ name '(tags ...)) ; match pattern of the calling form - #`(begin ; start with quasiquoted begin block & splice into it - (define name '(tags ...)) ; assign the provided name to the tags as a group - #,@(for/list ([tag (syntax->list #'(tags ...))]) ; step through list of tags - (with-syntax ((tag-as-id (format-id stx "~a" tag))) ; convert tag into identifier - ; todo: edit this to use tools:tagger - #`(define (tag-as-id . x) `(tag-as-id ,@x)))))])) ; write out the xexpr function - - - -(provide (all-defined-out)) \ No newline at end of file diff --git a/tests/requires/include-me.rkt b/tests/requires/include-me.rkt index 441e4fc..cc57eb1 100644 --- a/tests/requires/include-me.rkt +++ b/tests/requires/include-me.rkt @@ -219,7 +219,7 @@ (define/contract (root . items) (() #:rest (listof xexpr-element?) . ->* . tagged-xexpr?) - (decode (cons 'root items) + (decode (cons 'root-function items) ; #:exclude-xexpr-tags 'em ; #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)] ; #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)] diff --git a/tests/test-pmap.p b/tests/test-pmap.p index 25aad1e..834929c 100644 --- a/tests/test-pmap.p +++ b/tests/test-pmap.p @@ -1,21 +1,21 @@ #lang planet mb/pollen -◊map-topic{index +◊pmap-topic{index typography-in-ten-minutes summary-of-key-rules foreword introduction how-to-use how-to-pay-for-this-book - ◊map-topic{why-typography-matters + ◊pmap-topic{why-typography-matters what-is-typography where-do-the-rules-come-from} - ◊map-topic{type-composition + ◊pmap-topic{type-composition straight-and-curly-quotes one-space-between-sentences trademark-and-copyright-symbols ligatures} - ◊map-topic{appendix + ◊pmap-topic{appendix printers-and-paper how-to-make-a-pdf typewriter-habits diff --git a/tests/test-requirer.p b/tests/test-requirer.p index 09b85a1..0e2ad82 100644 --- a/tests/test-requirer.p +++ b/tests/test-requirer.p @@ -1,13 +1,13 @@ #lang racket/base -(require (planet mb/pollen/map)) +(require (planet mb/pollen/pmap)) ; ;(require "test-pmap.p") ;(require "pollen-lang-test.p") -(let ([left (make-page-sequence (main->tree (dynamic-require "test.pmap" 'main)))] - [right (make-page-sequence (main->tree (dynamic-require "test-pmap.p" 'main)))]) +(let ([left (make-page-sequence (main->pmap (dynamic-require "test.pmap" 'main)))] + [right (make-page-sequence (main->pmap (dynamic-require "test-pmap.p" 'main)))]) (print left) (print right) (andmap (λ(l r) (equal? l r)) left right)) \ No newline at end of file diff --git a/tests/test.pmap b/tests/test.pmap index 25aad1e..834929c 100644 --- a/tests/test.pmap +++ b/tests/test.pmap @@ -1,21 +1,21 @@ #lang planet mb/pollen -◊map-topic{index +◊pmap-topic{index typography-in-ten-minutes summary-of-key-rules foreword introduction how-to-use how-to-pay-for-this-book - ◊map-topic{why-typography-matters + ◊pmap-topic{why-typography-matters what-is-typography where-do-the-rules-come-from} - ◊map-topic{type-composition + ◊pmap-topic{type-composition straight-and-curly-quotes one-space-between-sentences trademark-and-copyright-symbols ligatures} - ◊map-topic{appendix + ◊pmap-topic{appendix printers-and-paper how-to-make-a-pdf typewriter-habits diff --git a/tools.rkt b/tools.rkt index c2636b3..ced9acb 100644 --- a/tools.rkt +++ b/tools.rkt @@ -13,7 +13,7 @@ (module+ test (require rackunit)) ; make these independent of local includes -(define (map-topic topic . subtopics) +(define (pmap-topic topic . subtopics) (make-tagged-xexpr (->symbol topic) empty (filter-not whitespace? subtopics))) diff --git a/where.rkt b/where.rkt deleted file mode 100644 index ada9fad..0000000 --- a/where.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket - -(define places '(home-dir pref-dir pref-file temp-dir init-dir init-file links-file addon-dir doc-dir desk-dir sys-dir exec-file run-file collects-dir orig-dir)) - -(displayln (string-join (map (λ(x) (format "~a: ~a" x (find-system-path x))) places) "\n") ) - -(displayln (format "current-directory: ~a" (current-directory))) \ No newline at end of file diff --git a/world.rkt b/world.rkt index 3cdacd5..cf8bc36 100644 --- a/world.rkt +++ b/world.rkt @@ -1,6 +1,4 @@ -#lang racket - -; in the dev branch +#lang racket/base (define POLLEN_PREPROC_EXT 'pp) (define POLLEN_SOURCE_EXT 'p)