transitive loading message (closes #176) and other improvements

pollen/cache.rkt

@@ -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))

pollen/private/cache-utils.rkt

@@ -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))

pollen/private/file-utils.rkt

@@ -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

pollen/private/main-base.rkt

@@ -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

pollen/private/render-helper.rkt

@@ -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)))))]))

pollen/private/ts.rktd

@@ -1 +1 @@
-1541019731
+1541194651

pollen/render.rkt

@@ -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)))

pollen/setup.rkt

@@ -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")