transitive loading message (closes #176) and other improvements

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

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/file (require racket/file
racket/list racket/list
racket/fasl racket/path
sugar/define sugar/define
"private/cache-utils.rkt" "private/cache-utils.rkt"
"private/log.rkt" "private/log.rkt"
@ -27,7 +27,12 @@
(define-namespace-anchor cache-module-ns) (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 (define cached-require-base
(let ([ram-cache (make-hash)]) (let ([ram-cache (make-hash)])
@ -42,16 +47,15 @@
(cond (cond
[(setup:compile-cache-active path) [(setup:compile-cache-active path)
(define key (paths->key path)) (define key (paths->key path))
(define (convert-path-to-cache-record) ((if use-fasl? s-exp->fasl values) (path->hash path))) (define (convert-path-to-cache-record)
(define (get-cache-record) ((if use-fasl? fasl->s-exp values) (cache-ref! key 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)) (define ram-cache-record (hash-ref! ram-cache key get-cache-record))
(hash-ref ram-cache-record subkey)] (hash-ref ram-cache-record subkey)]
[else [else (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+provide (cached-require path-string subkey) (define+provide (cached-require path-string subkey)
(cached-require-base path-string subkey 'cached-require)) (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 (cache-dir private-cache-dir) (make-cache-dirs dest-path))
(define-values (dest-path-dir dest-path-filename _) (split-path 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 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)) (write-to-file (path-hash-thunk) dest-file #:exists 'replace))
;; `cache-file` looks for a file in private-cache-dir previously cached with key ;; `cache-file` looks for a file in private-cache-dir previously cached with key
;; (which in this case carries modification dates and POLLEN env). ;; (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) ;; 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. ;; it is copied to private-cache-dir and recorded with key.
(cache-file dest-file (cache-file dest-file
#:exists-ok? #true #:exists-ok? #true
key key
private-cache-dir private-cache-dir
fetch-dest-file generate-dest-file
#:notify-cache-use notify-proc #:notify-cache-use notify-proc
#:max-cache-size (setup:compile-cache-max-size)) #:max-cache-size (setup:compile-cache-max-size))
(file->value dest-file)) (file->value dest-file))

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

@ -28,7 +28,9 @@
(define (strip-leading-newlines doc) (define (strip-leading-newlines doc)
;; drop leading newlines, as they're often the result of `defines` and `requires` ;; 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) (define-syntax (pollen-module-begin stx)
(syntax-case stx () (syntax-case stx ()
@ -43,7 +45,7 @@
DOC-ID ; positional arg for doclang-raw: name of export DOC-ID ; positional arg for doclang-raw: name of export
(λ (xs) (λ (xs)
(define proc (make-parse-proc PARSER-MODE ROOT-ID)) (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))) (define doc-elements (splice trimmed-xs (setup:splicing-tag)))
(proc doc-elements)) ; positional arg for doclang-raw: post-processor (proc doc-elements)) ; positional arg for doclang-raw: post-processor
(module META-MOD-ID racket/base (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/define
sugar/file sugar/file
sugar/coerce sugar/coerce
version/utils
"private/file-utils.rkt" "private/file-utils.rkt"
"cache.rkt" "cache.rkt"
"private/log.rkt" "private/log.rkt"
@ -150,9 +151,11 @@
(message (format "rendering /~a" (message (format "rendering /~a"
(find-relative-path (current-project-root) source-path))) (find-relative-path (current-project-root) source-path)))
(match-define-values ((cons render-result _) _ real _) (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)) (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)))) (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.
@ -170,13 +173,14 @@
;; todo: add test to avoid copying if unnecessary (good idea in case the file is large) ;; todo: add test to avoid copying if unnecessary (good idea in case the file is large)
(file->bytes source-path)) (file->bytes source-path))
(define-namespace-anchor render-module-ns)
(define (render-scribble-source source-path . _) (define (render-scribble-source source-path . _)
;((complete-path?) #:rest any/c . ->* . string?) ;((complete-path?) #:rest any/c . ->* . string?)
(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)
(parameterize ([current-namespace (make-base-namespace)] (parameterize ([current-namespace (make-base-namespace)])
[current-directory (->complete-path source-dir)])
(define outer-ns (namespace-anchor->namespace render-module-ns)) (define outer-ns (namespace-anchor->namespace render-module-ns))
(namespace-attach-module outer-ns 'scribble/core) (namespace-attach-module outer-ns 'scribble/core)
(namespace-attach-module outer-ns 'scribble/manual) (namespace-attach-module outer-ns 'scribble/manual)
@ -193,11 +197,7 @@
(delete-file (->output-path source-path)))) (delete-file (->output-path source-path))))
(define (render-preproc-source source-path . _) (define (render-preproc-source source-path . _)
(parameterize ([current-directory (->complete-path (dirname source-path))]) (cached-doc (->string source-path)))
(render-datum-through-eval (syntax->datum
(with-syntax ([SOURCE-PATH source-path])
#'(begin (require pollen/cache)
(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)))
@ -207,36 +207,18 @@
(unless template-path (unless template-path
(raise-argument-error 'render-markup-or-markdown-source "valid template path" 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 (render-from-source-or-output-path template-path) ; because template might have its own preprocessor source
(define datum-to-eval (parameterize ([current-output-port (current-error-port)])
(syntax->datum (eval (with-syntax ([MODNAME (gensym)]
(with-syntax ([DIRECTORY-REQUIRE-FILES (require-directory-require-files source-path)] [SOURCE-PATH-STRING (->string source-path)]
[DOC-ID (setup:main-export source-path)] [TEMPLATE-PATH-STRING (->string template-path)]
[META-ID (setup:meta-export source-path)] [REQUIRE (if (version<? (version) "6.3") 'local-require 'require)])
[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 #'(begin
(require (for-syntax racket/base) (module MODNAME pollen/private/render-helper
pollen/private/external/include-template #:source SOURCE-PATH-STRING
pollen/cache #:template TEMPLATE-PATH-STRING
pollen/private/log #:result-id result)
pollen/pagetree (REQUIRE 'MODNAME)
pollen/core) result)))))
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)))
(define (templated-source? path) (define (templated-source? path)
(or (markup-source? path) (markdown-source? path))) (or (markup-source? path) (markdown-source? path)))
@ -296,10 +278,3 @@
(check-false (get-template-for (->complete-path "foo.poly.pm"))) (check-false (get-template-for (->complete-path "foo.poly.pm")))
(check-equal? (get-template-for (->complete-path "foo.html.pm")) fallback.html))) (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-port (make-parameter (project-server-port)))
(define+provide current-server-listen-ip (make-parameter #f)) (define+provide current-server-listen-ip (make-parameter #f))
(define+provide current-render-source (make-parameter #f))
(define-settable dashboard-css "poldash.css") (define-settable dashboard-css "poldash.css")
(define-runtime-path server-extras-dir "private/server-extras") (define-runtime-path server-extras-dir "private/server-extras")

Loading…
Cancel
Save