transitive loading message (closes #176) and other improvements

pull/181/head
Matthew Butterick 5 years ago
parent 75ec407890
commit f3fb154704

@ -1,7 +1,7 @@
#lang racket/base
(require racket/file
racket/list
racket/fasl
racket/path
sugar/define
"private/cache-utils.rkt"
"private/log.rkt"
@ -19,15 +19,20 @@
(raise-argument-error 'reset-cache "path-string to existing directory" starting-dir))
(for ([path (in-directory starting-dir)]
#:when (cache-directory? path))
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(define ((path-error-handler caller-name path-or-path-string) e)
(raise-argument-error caller-name "valid path or path-string" path-or-path-string))
(define-namespace-anchor cache-module-ns)
(define use-fasl? #false)
(define (fetch-val path subkey)
(parameterize ([current-namespace (make-base-namespace)])
;; brings in currently instantiated params (unlike namespace-require)
(define outer-ns (namespace-anchor->namespace cache-module-ns))
(namespace-attach-module outer-ns 'pollen/setup)
(dynamic-require path subkey)))
(define cached-require-base
(let ([ram-cache (make-hash)])
@ -42,16 +47,15 @@
(cond
[(setup:compile-cache-active path)
(define key (paths->key path))
(define (convert-path-to-cache-record) ((if use-fasl? s-exp->fasl values) (path->hash path)))
(define (get-cache-record) ((if use-fasl? fasl->s-exp values) (cache-ref! key convert-path-to-cache-record)))
(define (convert-path-to-cache-record)
(when (let ([crs (current-render-source)])
(and crs (not (equal? crs path))))
(message (format "transitively loading /~a" (find-relative-path (current-project-root) path))))
(path->hash path))
(define (get-cache-record) (cache-ref! key convert-path-to-cache-record))
(define ram-cache-record (hash-ref! ram-cache key get-cache-record))
(hash-ref ram-cache-record subkey)]
[else
(parameterize ([current-namespace (make-base-namespace)])
;; brings in currently instantiated params (unlike namespace-require)
(define outer-ns (namespace-anchor->namespace cache-module-ns))
(namespace-attach-module outer-ns 'pollen/setup)
(dynamic-require path subkey))]))))
[else (fetch-val path subkey)]))))
(define+provide (cached-require path-string subkey)
(cached-require-base path-string subkey 'cached-require))

@ -93,19 +93,19 @@
(define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path))
(define-values (dest-path-dir dest-path-filename _) (split-path dest-path))
(define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename)))
(define (fetch-dest-file)
(define (generate-dest-file)
(write-to-file (path-hash-thunk) dest-file #:exists 'replace))
;; `cache-file` looks for a file in private-cache-dir previously cached with key
;; (which in this case carries modification dates and POLLEN env).
;; If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
;; Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file,
;; Otherwise, generate-dest-file is called; if dest-file exists after calling fetch-dest-file,
;; it is copied to private-cache-dir and recorded with key.
(cache-file dest-file
#:exists-ok? #true
key
private-cache-dir
fetch-dest-file
generate-dest-file
#:notify-cache-use notify-proc
#:max-cache-size (setup:compile-cache-max-size))
(file->value dest-file))

@ -156,13 +156,13 @@
[->STEM-SOURCE+OUTPUT-PATHS (format-id stx "->~a-source+output-paths" #'STEM)])
#`(begin
;; does file have particular extension
(define+provide/contract (STEM-SOURCE? x)
(any/c . -> . boolean?)
(and (pathish? x) (has-ext? (->path x) (SETUP:STEM-SOURCE-EXT)) #t))
(define+provide (STEM-SOURCE? x)
#;(any/c . -> . boolean?)
(and (pathish? x) (has-ext? (->path x) (SETUP:STEM-SOURCE-EXT)) #true))
;; non-theoretical: want the first possible source that exists in the filesystem
(define+provide/contract (GET-STEM-SOURCE x)
(coerce/path? . -> . (or/c #f path?))
(define+provide (GET-STEM-SOURCE x)
#;(coerce/path? . -> . (or/c #f path?))
(define source-paths (or (->STEM-SOURCE-PATHS x) null))
(for/first ([sp (in-list source-paths)]
#:when (file-exists? sp))
@ -173,8 +173,8 @@
(->boolean (and (pathish? x) (ormap (λ (proc) (proc (->path x))) (list STEM-SOURCE? GET-STEM-SOURCE)))))
;; get first possible source path (does not check filesystem)
(define+provide/contract (->STEM-SOURCE-PATH x)
(pathish? . -> . (or/c #f path?))
(define+provide (->STEM-SOURCE-PATH x)
#;(pathish? . -> . (or/c #f path?))
(define paths (->STEM-SOURCE-PATHS x))
(and paths (car paths)))
@ -186,7 +186,7 @@
#,(if (eq? (syntax->datum #'STEM) 'scribble)
#'(if (x . has-ext? . 'html) ; different logic for scribble sources
(list (add-ext (remove-ext* x) (SETUP:STEM-SOURCE-EXT)))
#f)
#false)
#'(let ([x-ext (get-ext x)]
[source-ext (SETUP:STEM-SOURCE-EXT)])
(cons

@ -28,7 +28,9 @@
(define (strip-leading-newlines doc)
;; drop leading newlines, as they're often the result of `defines` and `requires`
(dropf doc (λ (ln) (member ln (list (setup:newline) "")))))
(if (setup:trim-whitespace?)
(dropf doc (λ (ln) (member ln (list (setup:newline) ""))))
doc))
(define-syntax (pollen-module-begin stx)
(syntax-case stx ()
@ -43,7 +45,7 @@
DOC-ID ; positional arg for doclang-raw: name of export
(λ (xs)
(define proc (make-parse-proc PARSER-MODE ROOT-ID))
(define trimmed-xs ((if (setup:trim-whitespace?) strip-leading-newlines values) xs))
(define trimmed-xs (strip-leading-newlines xs))
(define doc-elements (splice trimmed-xs (setup:splicing-tag)))
(proc doc-elements)) ; positional arg for doclang-raw: post-processor
(module META-MOD-ID racket/base

@ -0,0 +1,51 @@
#lang racket/base
(require (for-syntax racket/base
syntax/strip-context
"project.rkt"
"../setup.rkt")
racket/stxparam
racket/splicing
"external/include-template.rkt"
"../cache.rkt"
"../pagetree.rkt"
"../core.rkt"
"../setup.rkt"
"../template.rkt"
"../top.rkt")
(provide (rename-out [mb #%module-begin])
(except-out (all-from-out racket/base) #%module-begin))
(define-syntax-parameter doc (λ (stx) (error 'doc-not-parameterized)))
(define-syntax-parameter metas (λ (stx) (error 'metas-not-parameterized)))
(define-syntax-parameter result (λ (stx) (error 'result-not-parameterized)))
(define-syntax (mb stx)
(syntax-case stx ()
;; markup / markdown branch
[(_ #:source SOURCE-PATH-STRING
#:template TEMPLATE-PATH-STRING
#:result-id RESULT-ID)
(let ([source-path (syntax->datum #'SOURCE-PATH-STRING)])
(with-syntax ([DIRECTORY-REQUIRE-FILES
(replace-context #'here (require-directory-require-files source-path))]
[DOC-ID (setup:main-export source-path)]
[METAS-ID (setup:meta-export source-path)]
[COMMAND-CHAR (setup:command-char source-path)])
#'(#%module-begin
DIRECTORY-REQUIRE-FILES
(splicing-syntax-parameterize
([doc (make-rename-transformer #'DOC-ID)]
[metas (make-rename-transformer #'METAS-ID)]
[result (make-rename-transformer #'RESULT-ID)])
(define result
(parameterize ([current-pagetree (make-project-pagetree (current-project-root))]
[current-metas (cached-metas SOURCE-PATH-STRING)])
(define doc (cached-doc SOURCE-PATH-STRING))
(define metas (current-metas))
(define here (path->pagenode
(or (select-from-metas (setup:here-path-key SOURCE-PATH-STRING) metas) 'unknown)))
(if (bytes? doc) ; if main export is binary, just pass it through
doc
(include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH-STRING)))))
(provide result)))))]))

@ -1 +1 @@
1541019731
1541194651

@ -6,6 +6,7 @@
sugar/define
sugar/file
sugar/coerce
version/utils
"private/file-utils.rkt"
"cache.rkt"
"private/log.rkt"
@ -69,7 +70,7 @@
has/is-markup-source?
has/is-scribble-source?
has/is-markdown-source?))])
(pred so-path))
(pred so-path))
(define-values (source-path output-path) (->source+output-paths so-path))
(render-to-file-if-needed source-path #f output-path)]
[(pagetree-source? so-path) (render-pagenodes so-path)])
@ -140,19 +141,21 @@
(define render-proc (for/first ([test (in-list tests)]
[render-proc (in-list render-procs)]
#:when (test source-path))
render-proc))
render-proc))
(unless 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)))
;; output-path and template-path may not have an extension, so check them in order with fallback
(message (format "rendering /~a"
(message (format "rendering /~a"
(find-relative-path (current-project-root) source-path)))
(match-define-values ((cons render-result _) _ real _)
(parameterize ([current-poly-target (->symbol (or (get-ext output-path)
(parameterize ([current-directory (->complete-path (dirname source-path))]
[current-poly-target (->symbol (or (get-ext output-path)
(and template-path (get-ext template-path))
(current-poly-target)))])
(current-poly-target)))]
[current-render-source source-path])
(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
;; e.g., of a template.
@ -170,13 +173,14 @@
;; todo: add test to avoid copying if unnecessary (good idea in case the file is large)
(file->bytes source-path))
(define-namespace-anchor render-module-ns)
(define (render-scribble-source source-path . _)
;((complete-path?) #:rest any/c . ->* . string?)
(local-require scribble/core scribble/manual (prefix-in scribble- scribble/render))
(define source-dir (dirname source-path))
;; make fresh namespace for scribble rendering (avoids dep/zo caching)
(parameterize ([current-namespace (make-base-namespace)]
[current-directory (->complete-path source-dir)])
(parameterize ([current-namespace (make-base-namespace)])
(define outer-ns (namespace-anchor->namespace render-module-ns))
(namespace-attach-module outer-ns 'scribble/core)
(namespace-attach-module outer-ns 'scribble/manual)
@ -193,11 +197,7 @@
(delete-file (->output-path source-path))))
(define (render-preproc-source source-path . _)
(parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval (syntax->datum
(with-syntax ([SOURCE-PATH source-path])
#'(begin (require pollen/cache)
(cached-doc SOURCE-PATH)))))))
(cached-doc (->string source-path)))
(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)))
@ -207,36 +207,18 @@
(unless template-path
(raise-argument-error 'render-markup-or-markdown-source "valid template path" template-path))
(render-from-source-or-output-path template-path) ; because template might have its own preprocessor source
(define datum-to-eval
(syntax->datum
(with-syntax ([DIRECTORY-REQUIRE-FILES (require-directory-require-files source-path)]
[DOC-ID (setup:main-export source-path)]
[META-ID (setup:meta-export source-path)]
[SOURCE-PATH-STRING (path->string source-path)]
[CPR (current-project-root)]
[HERE-PATH-KEY (setup:here-path-key source-path)]
[COMMAND-CHAR (setup:command-char source-path)]
[TEMPLATE-PATH (->string template-path)])
#'(begin
(require (for-syntax racket/base)
pollen/private/external/include-template
pollen/cache
pollen/private/log
pollen/pagetree
pollen/core)
DIRECTORY-REQUIRE-FILES
(parameterize ([current-pagetree (make-project-pagetree CPR)]
[current-metas (cached-metas SOURCE-PATH-STRING)])
(local-require pollen/template pollen/top)
(define DOC-ID (cached-doc SOURCE-PATH-STRING))
(define META-ID (current-metas))
(define here (path->pagenode (or (select-from-metas 'HERE-PATH-KEY META-ID) 'unknown)))
(if (bytes? DOC-ID) ; if main export is binary, just pass it through
DOC-ID
(include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH))))))))
;; set current-directory because include-template wants to work relative to source location
(parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval datum-to-eval)))
(parameterize ([current-output-port (current-error-port)])
(eval (with-syntax ([MODNAME (gensym)]
[SOURCE-PATH-STRING (->string source-path)]
[TEMPLATE-PATH-STRING (->string template-path)]
[REQUIRE (if (version<? (version) "6.3") 'local-require 'require)])
#'(begin
(module MODNAME pollen/private/render-helper
#:source SOURCE-PATH-STRING
#:template TEMPLATE-PATH-STRING
#:result-id result)
(REQUIRE 'MODNAME)
result)))))
(define (templated-source? path)
(or (markup-source? path) (markdown-source? path)))
@ -244,7 +226,7 @@
(define (file-exists-or-has-source? path) ; path could be #f
(and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
#:when (file-exists? (proc path)))
path)))
path)))
(define (get-template-from-metas source-path output-path-ext)
(with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require
@ -275,7 +257,7 @@
;; output-path may not have an extension
(define output-path-ext (or (get-ext output-path) (current-poly-target)))
(for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)])
(file-exists-or-has-source? (proc source-path output-path-ext))))))
(file-exists-or-has-source? (proc source-path output-path-ext))))))
(module-test-external
(require pollen/setup sugar/file sugar/coerce)
@ -296,10 +278,3 @@
(check-false (get-template-for (->complete-path "foo.poly.pm")))
(check-equal? (get-template-for (->complete-path "foo.html.pm")) fallback.html)))
(define-namespace-anchor render-module-ns)
(define (render-datum-through-eval datum-to-eval)
;; render a datum, not a syntax object, so that it can have fresh bindings.
(parameterize ([current-namespace (make-base-namespace)]
[current-output-port (current-error-port)])
(namespace-attach-module (namespace-anchor->namespace render-module-ns) 'pollen/setup) ; brings in params
(eval datum-to-eval)))

@ -101,6 +101,8 @@
(define+provide current-server-port (make-parameter (project-server-port)))
(define+provide current-server-listen-ip (make-parameter #f))
(define+provide current-render-source (make-parameter #f))
(define-settable dashboard-css "poldash.css")
(define-runtime-path server-extras-dir "private/server-extras")

Loading…
Cancel
Save