improvements

pull/9/head
Matthew Butterick 11 years ago
parent 607a043839
commit f3e5e4324b

@ -34,7 +34,7 @@
(when (not (current-cache)) (error "cached-require: No cache set up."))
(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)))
(when (or (not (cache-has-key? path))

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

@ -9,7 +9,7 @@
(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)
`(file ,(path->string file)))
(define project-require-files (get-project-require-files here-path))
@ -21,7 +21,7 @@
,@(if provide
(list `(provide (all-from-out ,@files-in-require-form)))
'())))
(void)))
'(begin)))
(define+provide (require-project-require-files here-path)

@ -166,7 +166,7 @@
(local-require pollen/pagemap pollen/template pollen/top)
(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))))

@ -138,11 +138,11 @@
;; dashboard route
(define (dashboard dashfile)
(define dir (get-enclosing-dir dashfile))
(define (dashboard dashboard-pmap)
(define dashboard-dir (get-enclosing-dir dashboard-pmap))
(define (in-project-root?)
(directories-equal? dir (world:current-project-root)))
(define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dir)))
(directories-equal? dashboard-dir (world:current-project-root)))
(define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dashboard-dir)))
(define empty-cell (cons #f #f))
(define (make-link-cell 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")(class "root")) "Pollen root"))))
(define (make-path-row fn)
(define filename (->string fn))
(define source (->string (->source-path fn)))
(define (make-path-row filename-path)
(define filename (->string filename-path))
(define possible-source (->source-path (build-path dashboard-dir filename-path)))
(define source (and possible-source (->string possible-source)))
`(tr ,@(map make-link-cell
(append (list
(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))]
[(and source (equal? (get-ext source) "scrbl"))
(cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,source ")")))]
@ -176,7 +177,7 @@
[else empty-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]
[else (cons (format "out/~a" filename) "out")]))))))
@ -186,7 +187,7 @@
(define output-paths (map ->output-path xs))
(define (unique-members xs) (set->list (list->set xs)))
(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 files (filter-not path-is-directory? all-paths))
(define pagemap-sources (filter pagemap-source? files))
@ -195,9 +196,11 @@
;; 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)))
(define project-paths (filter-not ineligible-path? (if (file-exists? dashfile)
(map ->path (pagemap->list (cached-require (->path dashfile) world:main-pollen-export)))
(unique-sorted-output-paths (directory-list dir)))))
(define project-paths
(filter-not ineligible-path?
(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
`(table

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