mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

many changes

Browse Source
pull/9/head
Matthew Butterick 12 years ago
parent 3ba36bb347
commit 71bac1483a
16 changed files with 377 additions and 355 deletions
Show Stats Download Patch File Download Diff File

2
library/html.rkt
Unescape Escape View File

@ -1,7 +1,5 @@
#lang racket/base #lang racket/base
(require "../syntax.rkt")
;; for now, body is deemed a block, not inline ;; for now, body is deemed a block, not inline
;; todo: is this legit? Why is body inline? ;; todo: is this legit? Why is body inline?
(define block-tags (define block-tags

6
main-helper.rkt
Unescape Escape View File

@ -55,10 +55,10 @@
[(equal? 'pollen-lang-module ccr) 'nowhere] [(equal? 'pollen-lang-module ccr) 'nowhere]
[else ccr])]) [else ccr])])
(match-let-values ([(_ here-name _) (split-path ccr)]) (match-let-values ([(_ here-name _) (split-path ccr)])
(->string (remove-all-ext here-name))))))) (->string here-name))))))
(module+ test (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 ; 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, ; 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)))) (define-syntax here (λ (stx) (datum->syntax stx '(get-here))))
(module+ test (module+ test
(check-equal? here "main-helper")) (check-equal? here "main-helper.rkt"))

251
map.rkt
Unescape Escape View File

@ -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))

257
pmap.rkt
Unescape Escape View File

@ -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"))

10
pollen-file-tools.rkt
Unescape Escape View File

@ -75,6 +75,16 @@
(check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext (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)) (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) (define/contract (preproc-source? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_PREPROC_EXT)) (has-ext? (->path x) POLLEN_PREPROC_EXT))

5
readability.rkt
Unescape Escape View File

@ -148,12 +148,13 @@
[else #f])) [else #f]))
;; don't return single-item results inside a list ;; 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)) (car (->list result))
result)) result))
(module+ test (module+ test
(check-equal? (get '(0 1 2 3 4 5) 2) 2) (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) 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 -1) '(2 3 4))
(check-equal? (get '(0 1 2 3 4 5) 2 'end) '(2 3 4 5)) (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 0 2) 'pu)
(check-equal? (get 'purple 2 -1) 'rpl) (check-equal? (get 'purple 2 -1) 'rpl)
(check-equal? (get 'purple 2 'end) 'rple) (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') ;; general way of testing for membership (à la Python 'in')
;; put item as first arg so function can use infix notation ;; put item as first arg so function can use infix notation

134
regenerate.rkt
Unescape Escape View File

@ -1,56 +1,96 @@
#lang racket #lang racket/base
(require xml/path) (require racket/list racket/path racket/port racket/system
(require "world.rkt" "tools.rkt" "map.rkt") racket/file racket/rerequire racket/contract)
(require racket/rerequire) (require "world.rkt" "tools.rkt" "pmap.rkt" "readability.rkt")
; hash of mod-dates takes lists of paths as keys, (module+ test (require rackunit))
; and lists of modification times as values.
; Reason: a templated page is a combination of two source files. ;; mod-dates is a hash that takes lists of paths as keys,
; Because templates have a one-to-many relationship with source files, ;; and lists of modification times as values.
; Need to track template mod-date for each source file. ;; Reason: a templated page is a combination of two source files.
; Otherwise a changed template will get reloaded only once, ;; Because templates have a one-to-many relationship with source files,
; and after that get reported as being up to date. ;; Need to track template mod-date for each source file.
; Possible: store hash on disk so mod records are preserved ;; Otherwise a changed template will get reloaded only once,
; between development sessions (prob a worthless optimization) ;; 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-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) ;; convert a path to a modification date value
(set! paths (flatten paths)) (define/contract (path->mod-date-value path)
(hash-set! mod-dates paths (mod-date paths))) (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) (module+ test
(set! paths (flatten paths)) (check-false (path->mod-date-value (->path "foobarfoo.rkt")))
(or (not (in? mod-dates paths)) ; no mod date (check-true (exact-integer? (path->mod-date-value (build-path (current-directory) (->path "regenerate.rkt"))))))
(not (equal? (mod-date paths) (get mod-dates paths))))) ; data changed
;; 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 ; helper functions for regenerate functions
(define pollen-file-root (current-directory)) (define pollen-file-root (current-directory))
(define (regenerate-file f) ; complete pollen path =
(let ([path (build-path pollen-file-root f)]) ;(build-path pollen-file-root f)
(displayln (format "Regenerating: ~a" f))
(regenerate path)))
;; 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) ;; todo next
(let-values ([(dir filename ignored) (split-path path)])
filename))
(define (regenerate-pmap-pages pmap) (define/contract (regenerate-with-pmap/message pmap)
(define pmap-sequence (pmap-source? . -> . void?)
(make-page-sequence (main->tree (dynamic-require pmap 'main)))) (message "Regenerating pages from pollen map: " (filename-of pmap))
(displayln (format "Regenerating pages from pollen map: ~a" (filename-of pmap))) (for-each regenerate-path/message
(for-each regenerate-file pmap-sequence)) (make-page-sequence (main->pmap (dynamic-require pmap 'main)))))
(define (get-pollen-files-with-ext ext) (define (get-pollen-files-with-ext ext)
(filter (λ(f) (has-ext? f ext)) (directory-list pollen-file-root))) (filter (λ(f) (has-ext? f ext)) (directory-list pollen-file-root)))
@ -60,10 +100,10 @@
(reset-mod-dates) (reset-mod-dates)
(define all-preproc-files (get-pollen-files-with-ext POLLEN_PREPROC_EXT)) (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)) (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")) (displayln "Completed"))
@ -77,7 +117,7 @@
(cond (cond
[(needs-preproc? path) (do-preproc path #:force force)] [(needs-preproc? path) (do-preproc path #:force force)]
[(needs-template? path) (do-template 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 (or force
(not (file-exists? preproc-out-path)) (not (file-exists? preproc-out-path))
(source-needs-refresh? preproc-in-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 ; use single quotes to escape spaces in pathnames
(define command (define command
(format "~a '~a' > '~a'" RACKET_PATH preproc-in-path preproc-out-path)) (format "~a '~a' > '~a'" RACKET_PATH preproc-in-path preproc-out-path))
@ -160,7 +200,7 @@
(not (file-exists? generated-path)) (not (file-exists? generated-path))
(source-needs-refresh? source-path template-path) (source-needs-refresh? source-path template-path)
file-was-reloaded?) 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. ; Templates are part of the compile operation.
; Therefore no way to arbitrarily invoke template at run-time. ; Therefore no way to arbitrarily invoke template at run-time.

7
server-routes.rkt
Unescape Escape View File

@ -17,13 +17,12 @@
(complete-path? . -> . tagged-xexpr?) (complete-path? . -> . tagged-xexpr?)
(regenerate path) (regenerate path)
(dynamic-rerequire path) (dynamic-rerequire path)
(define main (dynamic-require path 'main)) (dynamic-require path 'main))
main)
(define/contract (slurp path #:regenerate? [regenerate? #t]) (define/contract (slurp path #:regenerate? [regenerate? #t])
(complete-path? . -> . string?) (complete-path? . -> . string?)
(when regenerate? (when regenerate? (regenerate path))
(regenerate path))
(file->string path)) (file->string path))
(define/contract (format-as-code tx) (define/contract (format-as-code tx)

23
syntax.rkt
Unescape Escape View File

@ -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))

2
tests/requires/include-me.rkt
Unescape Escape View File

@ -219,7 +219,7 @@
(define/contract (root . items) (define/contract (root . items)
(() #:rest (listof xexpr-element?) . ->* . tagged-xexpr?) (() #:rest (listof xexpr-element?) . ->* . tagged-xexpr?)
(decode (cons 'root items) (decode (cons 'root-function items)
; #:exclude-xexpr-tags 'em ; #:exclude-xexpr-tags 'em
; #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)] ; #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)]
; #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)] ; #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]

8
tests/test-pmap.p
Unescape Escape View File

@ -1,21 +1,21 @@
#lang planet mb/pollen #lang planet mb/pollen
◊map-topic{index ◊pmap-topic{index
typography-in-ten-minutes typography-in-ten-minutes
summary-of-key-rules summary-of-key-rules
foreword foreword
introduction introduction
how-to-use how-to-use
how-to-pay-for-this-book how-to-pay-for-this-book
◊map-topic{why-typography-matters ◊pmap-topic{why-typography-matters
what-is-typography what-is-typography
where-do-the-rules-come-from} where-do-the-rules-come-from}
◊map-topic{type-composition ◊pmap-topic{type-composition
straight-and-curly-quotes straight-and-curly-quotes
one-space-between-sentences one-space-between-sentences
trademark-and-copyright-symbols trademark-and-copyright-symbols
ligatures} ligatures}
◊map-topic{appendix ◊pmap-topic{appendix
printers-and-paper printers-and-paper
how-to-make-a-pdf how-to-make-a-pdf
typewriter-habits typewriter-habits

6
tests/test-requirer.p
Unescape Escape View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require (planet mb/pollen/map)) (require (planet mb/pollen/pmap))
; ;
;(require "test-pmap.p") ;(require "test-pmap.p")
;(require "pollen-lang-test.p") ;(require "pollen-lang-test.p")
(let ([left (make-page-sequence (main->tree (dynamic-require "test.pmap" 'main)))] (let ([left (make-page-sequence (main->pmap (dynamic-require "test.pmap" 'main)))]
[right (make-page-sequence (main->tree (dynamic-require "test-pmap.p" 'main)))]) [right (make-page-sequence (main->pmap (dynamic-require "test-pmap.p" 'main)))])
(print left) (print left)
(print right) (print right)
(andmap (λ(l r) (equal? l r)) left right)) (andmap (λ(l r) (equal? l r)) left right))

8
tests/test.pmap
Unescape Escape View File

@ -1,21 +1,21 @@
#lang planet mb/pollen #lang planet mb/pollen
◊map-topic{index ◊pmap-topic{index
typography-in-ten-minutes typography-in-ten-minutes
summary-of-key-rules summary-of-key-rules
foreword foreword
introduction introduction
how-to-use how-to-use
how-to-pay-for-this-book how-to-pay-for-this-book
◊map-topic{why-typography-matters ◊pmap-topic{why-typography-matters
what-is-typography what-is-typography
where-do-the-rules-come-from} where-do-the-rules-come-from}
◊map-topic{type-composition ◊pmap-topic{type-composition
straight-and-curly-quotes straight-and-curly-quotes
one-space-between-sentences one-space-between-sentences
trademark-and-copyright-symbols trademark-and-copyright-symbols
ligatures} ligatures}
◊map-topic{appendix ◊pmap-topic{appendix
printers-and-paper printers-and-paper
how-to-make-a-pdf how-to-make-a-pdf
typewriter-habits typewriter-habits

2
tools.rkt
Unescape Escape View File

@ -13,7 +13,7 @@
(module+ test (require rackunit)) (module+ test (require rackunit))
; make these independent of local includes ; 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))) (make-tagged-xexpr (->symbol topic) empty (filter-not whitespace? subtopics)))

7
where.rkt
Unescape Escape View File

@ -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)))

4
world.rkt
Unescape Escape View File

@ -1,6 +1,4 @@
#lang racket #lang racket/base
; in the dev branch
(define POLLEN_PREPROC_EXT 'pp) (define POLLEN_PREPROC_EXT 'pp)
(define POLLEN_SOURCE_EXT 'p) (define POLLEN_SOURCE_EXT 'p)

Write Preview
Loading…
Cancel
Save