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

improvements

Browse Source
pull/9/head
Matthew Butterick 10 years ago
parent 607a043839
commit f3e5e4324b
6 changed files with 63 additions and 46 deletions
Show Stats Download Patch File Download Diff File

2
cache.rkt
Unescape Escape View File

@ -34,7 +34,7 @@
(when (not (current-cache)) (error "cached-require: No cache set up.")) (when (not (current-cache)) (error "cached-require: No cache set up."))
(define path (define path
(with-handlers ([exn:fail? (λ(exn) (displayln (format "cached-require: ~a is not a valid path" path-string)))]) (with-handlers ([exn:fail? (λ(exn) (error (format "cached-require: ~a is not a valid path" path-string)))])
(->complete-path path-string))) (->complete-path path-string)))
(when (or (not (cache-has-key? path)) (when (or (not (cache-has-key? path))

33
file.rkt
Unescape Escape View File

@ -43,6 +43,7 @@
(let ([stem-datum (syntax->datum #'stem)]) (let ([stem-datum (syntax->datum #'stem)])
(with-syntax ([file-ext (format-id stx "world:~a-source-ext" #'stem)] (with-syntax ([file-ext (format-id stx "world:~a-source-ext" #'stem)]
[stem-source? (format-id stx "~a-source?" #'stem)] [stem-source? (format-id stx "~a-source?" #'stem)]
[get-stem-source (format-id stx "get-~a-source" #'stem)]
[has-stem-source? (format-id stx "has-~a-source?" #'stem)] [has-stem-source? (format-id stx "has-~a-source?" #'stem)]
[has/is-stem-source? (format-id stx "has/is-~a-source?" #'stem)] [has/is-stem-source? (format-id stx "has/is-~a-source?" #'stem)]
[->stem-source-path (format-id stx "->~a-source-path" #'stem)] [->stem-source-path (format-id stx "->~a-source-path" #'stem)]
@ -52,9 +53,14 @@
(define+provide (stem-source? x) (define+provide (stem-source? x)
(->boolean (and (pathish? x) (has-ext? (->path x) file-ext)))) (->boolean (and (pathish? x) (has-ext? (->path x) file-ext))))
(define+provide (get-stem-source x)
(and (pathish? x)
(let ([source-path (->stem-source-path (->path x))])
(and source-path (file-exists? source-path) source-path))))
;; does the source-ified version of the file exist ;; does the source-ified version of the file exist
(define+provide (has-stem-source? x) (define+provide (has-stem-source? x)
(->boolean (and (pathish? x) (file-exists? (->stem-source-path (->path x)))))) (->boolean (get-stem-source x)))
;; it's a file-ext source file, or a file that's the result of a file-ext source ;; it's a file-ext source file, or a file that's the result of a file-ext source
(define+provide (has/is-stem-source? x) (define+provide (has/is-stem-source? x)
@ -62,12 +68,15 @@
;; add the file extension if it's not there ;; add the file extension if it's not there
(define+provide/contract (->stem-source-path x) (define+provide/contract (->stem-source-path x)
(pathish? . -> . path?) (pathish? . -> . (or/c #f path?))
(->path (if (stem-source? x) (define result (if (stem-source? x)
x x
#,(if (equal? stem-datum 'scribble) #,(if (equal? stem-datum 'scribble)
#'(add-ext (remove-all-ext x) file-ext) ; different logic for scribble sources #'(if (x . has-ext? . 'html) ; different logic for scribble sources
#'(add-ext x file-ext))))) (add-ext (remove-all-ext x) file-ext)
#f)
#'(add-ext x file-ext))))
(and result (->path result)))
;; coerce either a source or output file to both ;; coerce either a source or output file to both
(define+provide/contract (->stem-source+output-paths path) (define+provide/contract (->stem-source+output-paths path)
@ -84,15 +93,9 @@
(make-source-utility-functions scribble) (make-source-utility-functions scribble)
;; todo: use has-source? for this
(define/contract+provide (->source-path path) (define/contract+provide (->source-path path)
(coerce/path? . -> . path?) (coerce/path? . -> . (or/c #f path?))
(define possible-sources (ormap (λ(proc) (proc path)) (list get-markup-source get-preproc-source get-null-source get-scribble-source)))
(if (directory-exists? path)
null
(filter file-exists? (map (λ(proc) (proc path)) (list ->preproc-source-path ->markup-source-path ->null-source-path ->scribble-source-path)))))
(if (null? possible-sources) path (car possible-sources)))
(define+provide/contract (->output-path x) (define+provide/contract (->output-path x)
(coerce/path? . -> . coerce/path?) (coerce/path? . -> . coerce/path?)

4
project-requires.rkt
Unescape Escape View File

@ -9,7 +9,7 @@
(define+provide/contract (require+provide-project-require-files here-path #:provide [provide #t]) (define+provide/contract (require+provide-project-require-files here-path #:provide [provide #t])
(coerce/path? . -> . list?) (coerce/path? . -> . (or/c list? void?))
(define (put-file-in-require-form file) (define (put-file-in-require-form file)
`(file ,(path->string file))) `(file ,(path->string file)))
(define project-require-files (get-project-require-files here-path)) (define project-require-files (get-project-require-files here-path))
@ -21,7 +21,7 @@
,@(if provide ,@(if provide
(list `(provide (all-from-out ,@files-in-require-form))) (list `(provide (all-from-out ,@files-in-require-form)))
'()))) '())))
(void))) '(begin)))
(define+provide (require-project-require-files here-path) (define+provide (require-project-require-files here-path)

2
render.rkt
Unescape Escape View File

@ -166,7 +166,7 @@
(local-require pollen/pagemap pollen/template pollen/top) (local-require pollen/pagemap pollen/template pollen/top)
(include-template #:command-char ,world:template-field-delimiter ,(->string (find-relative-path source-dir template-path)))))) (include-template #:command-char ,world:template-field-delimiter ,(->string (find-relative-path source-dir template-path))))))
(time (parameterize ([current-directory source-dir]) (time (parameterize ([current-directory source-dir]) ; because include-template wants to work relative to source location
(render-through-eval expr-to-eval)))) (render-through-eval expr-to-eval))))

29
server-routes.rkt
Unescape Escape View File

@ -138,11 +138,11 @@
;; dashboard route ;; dashboard route
(define (dashboard dashfile) (define (dashboard dashboard-pmap)
(define dir (get-enclosing-dir dashfile)) (define dashboard-dir (get-enclosing-dir dashboard-pmap))
(define (in-project-root?) (define (in-project-root?)
(directories-equal? dir (world:current-project-root))) (directories-equal? dashboard-dir (world:current-project-root)))
(define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dir))) (define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dashboard-dir)))
(define empty-cell (cons #f #f)) (define empty-cell (cons #f #f))
(define (make-link-cell href+text) (define (make-link-cell href+text)
(match-define (cons href text) href+text) (match-define (cons href text) href+text)
@ -157,13 +157,14 @@
`(tr (th ((colspan "3")) (a ((href ,url-to-parent-dashboard)) ,(format "up to ~a" url-to-parent))))) `(tr (th ((colspan "3")) (a ((href ,url-to-parent-dashboard)) ,(format "up to ~a" url-to-parent)))))
`(tr (th ((colspan "3")(class "root")) "Pollen root")))) `(tr (th ((colspan "3")(class "root")) "Pollen root"))))
(define (make-path-row fn) (define (make-path-row filename-path)
(define filename (->string fn)) (define filename (->string filename-path))
(define source (->string (->source-path fn))) (define possible-source (->source-path (build-path dashboard-dir filename-path)))
(define source (and possible-source (->string possible-source)))
`(tr ,@(map make-link-cell `(tr ,@(map make-link-cell
(append (list (append (list
(cond ; main cell (cond ; main cell
[(directory-exists? (build-path dir filename)) ; links subdir to its dashboard [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
(cons (format "~a/~a" filename world:dashboard-name) (format "~a/" filename))] (cons (format "~a/~a" filename world:dashboard-name) (format "~a/" filename))]
[(and source (equal? (get-ext source) "scrbl")) [(and source (equal? (get-ext source) "scrbl"))
(cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,source ")")))] (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,source ")")))]
@ -176,7 +177,7 @@
[else empty-cell]) [else empty-cell])
(cond ; out cell (cond ; out cell
[(directory-exists? (build-path dir filename)) (cons #f #f)] [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
[(pagemap-source? filename) empty-cell] [(pagemap-source? filename) empty-cell]
[else (cons (format "out/~a" filename) "out")])))))) [else (cons (format "out/~a" filename) "out")]))))))
@ -186,7 +187,7 @@
(define output-paths (map ->output-path xs)) (define output-paths (map ->output-path xs))
(define (unique-members xs) (set->list (list->set xs))) (define (unique-members xs) (set->list (list->set xs)))
(define all-paths (unique-members output-paths)) (define all-paths (unique-members output-paths))
(define path-is-directory? (λ(f) (directory-exists? (build-path dir f)))) (define path-is-directory? (λ(f) (directory-exists? (build-path dashboard-dir f))))
(define subdirectories (filter path-is-directory? all-paths)) (define subdirectories (filter path-is-directory? all-paths))
(define files (filter-not path-is-directory? all-paths)) (define files (filter-not path-is-directory? all-paths))
(define pagemap-sources (filter pagemap-source? files)) (define pagemap-sources (filter pagemap-source? files))
@ -195,9 +196,11 @@
;; put subdirs in list ahead of files (so they appear at the top) ;; put subdirs in list ahead of files (so they appear at the top)
(append (sort-names subdirectories) (sort-names pagemap-sources) (sort-names other-files))) (append (sort-names subdirectories) (sort-names pagemap-sources) (sort-names other-files)))
(define project-paths (filter-not ineligible-path? (if (file-exists? dashfile) (define project-paths
(map ->path (pagemap->list (cached-require (->path dashfile) world:main-pollen-export))) (filter-not ineligible-path?
(unique-sorted-output-paths (directory-list dir))))) (if (file-exists? dashboard-pmap)
(map ->path (pagemap->list (cached-require (->path dashboard-pmap) world:main-pollen-export)))
(unique-sorted-output-paths (directory-list dashboard-dir)))))
(body-wrapper (body-wrapper
`(table `(table

39
template.rkt
Unescape Escape View File

@ -9,30 +9,37 @@
(define/contract+provide (get-doc x) (define/contract+provide (get-doc x)
(coerce/path? . -> . txexpr?) (coerce/path? . -> . (or/c #f txexpr? string?))
(cached-require (->source-path x) world:main-pollen-export)) (define source-path (->source-path x))
(if source-path
(cached-require source-path world:main-pollen-export)
(error (format "get-doc: no source found for '~a' in directory ~a" x (current-directory)))))
(define/contract+provide (get-metas x) (define/contract+provide (get-metas x)
(coerce/path? . -> . hash?) (coerce/path? . -> . hash?)
(cached-require (->source-path x) world:meta-pollen-export)) (define source-path (->source-path x))
(if source-path
(cached-require source-path world:meta-pollen-export)
(error (format "get-doc: no source found for '~a' in directory ~a" x (current-directory)))))
(define/contract+provide (find query . xs) (define/contract+provide (from-node query node)
((coerce/symbol?) #:rest (listof (or/c #f hash? txexpr? pathish?)) . ->* . (or/c #f txexpr-element?)) (coerce/symbol? coerce/symbol? . -> . (or/c #f txexpr-element?))
(define result (apply find* query xs)) (define node-path (build-path (world:current-project-root) (->string node)))
(or (null? result) (car result))) (define result (append (find-in-metas query node-path) (find-in-doc query node-path)))
(if (null? result) #f (car result)))
(define/contract+provide (find* query . pxs) (define/contract+provide (find* query . nodes)
((coerce/symbol?) #:rest (listof (or/c #f hash? txexpr? pathish?)) . ->* . (or/c #f txexpr-elements?)) ((coerce/symbol?) #:rest (listof symbol?) . ->* . (or/c #f txexpr-elements?))
(define (finder x) (define (finder x)
(cond (cond
[(hash? x) (find-in-metas query x)] [(hash? x) (find-in-metas query x)]
[(txexpr? x) (find-in-doc query x)] [(txexpr? x) (find-in-doc query x)]
[(pathish? x) (find* query (get-doc x) (get-metas x))] [(pathish? x) (find* query (get-doc x) (get-metas x))]
[else null])) [else null]))
(append-map finder pxs)) (append-map finder nodes))
(define/contract+provide (find-in-metas query hash-or-path) (define/contract+provide (find-in-metas query hash-or-path)
@ -65,8 +72,8 @@
(define+provide/contract (->html x) (define+provide/contract (->html x)
(txexpr? . -> . string?) (xexpr? . -> . string?)
(txexpr->html x)) (xexpr->html x))
(provide when/block) (provide when/block)
@ -74,7 +81,11 @@
(syntax-case stx () (syntax-case stx ()
[(_ condition body ...) [(_ condition body ...)
#'(if condition (string-append* #'(if condition (string-append*
(with-handlers ([exn:fail? (λ(exn) (error (format "when/block: ~a" (exn-message exn))))]) (with-handlers ([exn:fail? (λ(exn) (error (format "within when/block, ~a" (exn-message exn))))])
(map ->string (list body ...)))) ; todo: should this be ->html not ->string? (map ->string (list body ...))))
"")])) "")]))
(module+ main
(parameterize ([current-directory (string->path "/Users/MB/git/bpt/down/")])
(get-doc "introduction.html")))
Write Preview
Loading…
Cancel
Save