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

simplify messages

Browse Source
dev-stylish
Matthew Butterick 6 years ago
parent fff6c3f5e9
commit a7c4733e58
2 changed files with 106 additions and 103 deletions
Show Stats Download Patch File Download Diff File

148
pollen/private/project-server-routes.rkt
Unescape Escape View File

@ -61,11 +61,11 @@
(define client (request-client-ip req)) (define client (request-client-ip req))
(define localhost-client "::1") (define localhost-client "::1")
(define url-string (url->string (request-uri req))) (define url-string (url->string (request-uri req)))
(when (not (ends-with? url-string "favicon.ico")) (unless (ends-with? url-string "favicon.ico")
(message "request:" (if (regexp-match #rx"/$" url-string) (message (if (regexp-match #rx"/$" url-string)
(string-append url-string " directory default page") (string-append url-string " directory default page")
(string-replace url-string (setup:main-pagetree) " dashboard")) (string-replace url-string (setup:main-pagetree) " dashboard"))
(if (not (equal? client localhost-client)) (format "from ~a" client) "")))) (if (not (equal? client localhost-client)) (format "from ~a" client) "")))
;; pass string args to route, then ;; pass string args to route, then
;; package route into right format for web server ;; package route into right format for web server
@ -164,9 +164,9 @@
(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)
(filter-not void? `(cell ,(when text (filter-not void? `(cell ,(when text
(if href (if href
`(a ((href ,href)) ,text) `(a ((href ,href)) ,text)
text))))) text)))))
(define (make-parent-row) (define (make-parent-row)
(define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) ""))) (define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) "")))
@ -180,51 +180,51 @@
(define (make-path-row filename source indent-level) (define (make-path-row filename source indent-level)
`(row ,@(map make-link-cell `(row ,@(map make-link-cell
(append (list (append (list
(let ([main-cell (cond ; main cell (let ([main-cell (cond ; main cell
[(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
(cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))]
[(and source (equal? (get-ext source) "scrbl")) ; scribble source [(and source (equal? (get-ext source) "scrbl")) ; scribble source
(cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))]
[source ; ordinary source. use remove-ext because source may have escaped extension in it [source ; ordinary source. use remove-ext because source may have escaped extension in it
(define source-first-ext (get-ext source)) (define source-first-ext (get-ext source))
(define source-minus-ext (unescape-ext (remove-ext source))) (define source-minus-ext (unescape-ext (remove-ext source)))
(define source-second-ext (get-ext source-minus-ext)) (define source-second-ext (get-ext source-minus-ext))
(cond ; multi source. expand to multiple output files. (cond ; multi source. expand to multiple output files.
[(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source)))))
(define source-base (remove-ext source-minus-ext)) (define source-base (remove-ext source-minus-ext))
(define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source))))
(cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))]
[else [else
(define extra-row-string (define extra-row-string
(if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal
"" ; no extra string needed "" ; no extra string needed
(format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) (format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))
(cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])]
[else ; other non-source file [else ; other non-source file
(cons filename filename)])]) (cons filename filename)])])
(cons (car main-cell) (cons (car main-cell)
(let* ([cell-content (cdr main-cell)] (let* ([cell-content (cdr main-cell)]
[indent-padding (+ 1 indent-level)] [indent-padding (+ 1 indent-level)]
[padding-attr `(class ,(format "indent_~a" indent-padding))]) [padding-attr `(class ,(format "indent_~a" indent-padding))])
(cond (cond
[(string? cell-content) `(span (,padding-attr) ,cell-content)] [(string? cell-content) `(span (,padding-attr) ,cell-content)]
[(txexpr? cell-content) [(txexpr? cell-content)
;; indent link text by depth in pagetree ;; indent link text by depth in pagetree
`(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))]
[else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))]))))
(cond ; 'in' cell (cond ; 'in' cell
[source (cons (format "in/~a" source) "in")] [source (cons (format "in/~a" source) "in")]
[(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")] [(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")]
[else empty-cell]) [else empty-cell])
(cond ; 'out' cell (cond ; 'out' cell
[(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)] [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
[(pagetree-source? filename) empty-cell] [(pagetree-source? filename) empty-cell]
[else (cons (format "out/~a" filename) "out")])))))) [else (cons (format "out/~a" filename) "out")]))))))
(define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard))) (define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard)))
@ -241,32 +241,32 @@
depth))) depth)))
(apply body-wrapper #:title (format "~a" dashboard-dir) (apply body-wrapper #:title (format "~a" dashboard-dir)
(cons (make-parent-row) (cons (make-parent-row)
(cond (cond
[(not (null? project-paths)) [(not (null? project-paths))
(define path-source-pairs (define path-source-pairs
(map (map
(λ (p) (define source (λ (p) (define source
(let ([possible-source (get-source (build-path dashboard-dir p))]) (let ([possible-source (get-source (build-path dashboard-dir p))])
(and possible-source (->string (find-relative-path dashboard-dir possible-source))))) (and possible-source (->string (find-relative-path dashboard-dir possible-source)))))
(cons p source)) (cons p source))
project-paths)) project-paths))
(define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources
(for/fold ([psps empty][seen-source-paths empty]) (for/fold ([psps empty][seen-source-paths empty])
([psp (in-list path-source-pairs)]) ([psp (in-list path-source-pairs)])
(define source-path (cdr psp)) (define source-path (cdr psp))
(if (and source-path (member source-path seen-source-paths)) (if (and source-path (member source-path seen-source-paths))
(values psps seen-source-paths) ; skip the pair (values psps seen-source-paths) ; skip the pair
(values (cons psp psps) (cons source-path seen-source-paths))))) (values (cons psp psps) (cons source-path seen-source-paths)))))
(define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs))
(define filenames (map (compose1 ->string car) unique-path-source-pairs)) (define filenames (map (compose1 ->string car) unique-path-source-pairs))
(define sources (map cdr unique-path-source-pairs)) (define sources (map cdr unique-path-source-pairs))
(define indent-levels (map directory-pagetree-depth filenames)) (define indent-levels (map directory-pagetree-depth filenames))
(parameterize ([current-directory dashboard-dir]) (parameterize ([current-directory dashboard-dir])
(map make-path-row filenames sources indent-levels))] (map make-path-row filenames sources indent-levels))]
[else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))]))))
(define route-dashboard (route-wrapper dashboard)) (define route-dashboard (route-wrapper dashboard))
@ -307,7 +307,7 @@
(define/contract (route-404 req) (define/contract (route-404 req)
(request? . -> . response?) (request? . -> . response?)
(define missing-path-string (path->string (simplify-path (req->path req)))) (define missing-path-string (path->string (simplify-path (req->path req))))
(message (format "route-404: Can't find ~a" missing-path-string)) (message (format "can't find ~a" missing-path-string))
(response/xexpr+doctype (response/xexpr+doctype
`(html `(html
(head (title "404 error") (link ((href "/error.css") (rel "stylesheet")))) (head (title "404 error") (link ((href "/error.css") (rel "stylesheet"))))

61
pollen/render.rkt
Unescape Escape View File

@ -107,7 +107,7 @@
#:dest-path 'output #:dest-path 'output
#:notify-cache-use #:notify-cache-use
(λ (str) (λ (str)
(message (format "rendering: /~a (from cache)" (message (format "loading from cache /~a"
(find-relative-path (current-project-root) output-path))))))))) ; will either be string or bytes (find-relative-path (current-project-root) output-path))))))))) ; will either be string or bytes
(display-to-file render-result output-path (display-to-file render-result output-path
#:exists 'replace #:exists 'replace
@ -145,16 +145,19 @@
(raise-argument-error 'render (format "valid rendering function for ~a" source-path) render-proc)) (raise-argument-error 'render (format "valid rendering function for ~a" source-path) render-proc))
(define template-path (or maybe-template-path (get-template-for source-path output-path))) (define template-path (or maybe-template-path (get-template-for source-path output-path)))
(message (format "rendering: /~a as /~a"
(find-relative-path (current-project-root) source-path)
(find-relative-path (current-project-root) output-path)))
;; output-path and template-path may not have an extension, so check them in order with fallback ;; output-path and template-path may not have an extension, so check them in order with fallback
(define render-result (parameterize ([current-poly-target (->symbol (or (get-ext output-path) (match-define-values ((cons render-result _) _ real _)
(and template-path (get-ext template-path)) (parameterize ([current-poly-target (->symbol (or (get-ext output-path)
(current-poly-target)))]) (and template-path (get-ext template-path))
(apply render-proc (list source-path template-path output-path)))) (current-poly-target)))])
(time-apply render-proc (list source-path template-path output-path))))
;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders ;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders
;; e.g., of a template. ;; e.g., of a template.
(message (format "rendering /~a as /~a (~a ms)"
(find-relative-path (current-project-root) source-path)
(find-relative-path (current-project-root) output-path)
real))
(update-mod-date-hash! source-path template-path) (update-mod-date-hash! source-path template-path)
render-result) render-result)
@ -169,29 +172,29 @@
(local-require scribble/core scribble/manual (prefix-in scribble- scribble/render)) (local-require scribble/core scribble/manual (prefix-in scribble- scribble/render))
(define source-dir (dirname source-path)) (define source-dir (dirname source-path))
;; make fresh namespace for scribble rendering (avoids dep/zo caching) ;; make fresh namespace for scribble rendering (avoids dep/zo caching)
(time (parameterize ([current-namespace (make-base-namespace)] (parameterize ([current-namespace (make-base-namespace)]
[current-directory (->complete-path source-dir)]) [current-directory (->complete-path source-dir)])
(define ns (namespace-anchor->namespace render-module-ns)) (define ns (namespace-anchor->namespace render-module-ns))
(namespace-attach-module ns 'scribble/core (current-namespace)) (namespace-attach-module ns 'scribble/core (current-namespace))
(namespace-attach-module ns 'scribble/manual (current-namespace)) (namespace-attach-module ns 'scribble/manual (current-namespace))
;; scribble/lp files have their doc export in a 'doc submodule, so check both locations ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations
(match (cond (match (cond
[(dynamic-require source-path 'doc (λ () #false))] [(dynamic-require source-path 'doc (λ () #false))]
[(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))] [(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))]
[else #false]) [else #false])
;; BTW this next action has side effects: scribble will copy in its core files if they don't exist. ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist.
[(? part? doc) (scribble-render (list doc) (list source-path))] [(? part? doc) (scribble-render (list doc) (list source-path))]
[_ (void)]))) [_ (void)]))
(begin0 ; because render promises the data, not the side effect (begin0 ; because render promises the data, not the side effect
(file->string (->output-path source-path)) (file->string (->output-path source-path))
(delete-file (->output-path source-path)))) (delete-file (->output-path source-path))))
(define (render-preproc-source source-path . _) (define (render-preproc-source source-path . _)
(time (parameterize ([current-directory (->complete-path (dirname source-path))]) (parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval (syntax->datum (render-datum-through-eval (syntax->datum
(with-syntax ([SOURCE-PATH source-path]) (with-syntax ([SOURCE-PATH source-path])
#'(begin (require pollen/cache) #'(begin (require pollen/cache)
(cached-doc SOURCE-PATH)))))))) (cached-doc SOURCE-PATH)))))))
(define (render-markup-or-markdown-source source-path [maybe-template-path #f] [maybe-output-path #f]) (define (render-markup-or-markdown-source source-path [maybe-template-path #f] [maybe-output-path #f])
(define output-path (or maybe-output-path (->output-path source-path))) (define output-path (or maybe-output-path (->output-path source-path)))
@ -229,8 +232,8 @@
DOC-ID DOC-ID
(include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH)))))))) (include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH))))))))
;; set current-directory because include-template wants to work relative to source location ;; set current-directory because include-template wants to work relative to source location
(time (parameterize ([current-directory (->complete-path (dirname source-path))]) (parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval datum-to-eval)))) (render-datum-through-eval datum-to-eval)))
(define (templated-source? path) (define (templated-source? path)
(or (markup-source? path) (markdown-source? path))) (or (markup-source? path) (markdown-source? path)))

Write Preview
Loading…
Cancel
Save