diff --git a/pagetree.rkt b/pagetree.rkt index 02cc71e..c67b2f5 100644 --- a/pagetree.rkt +++ b/pagetree.rkt @@ -44,12 +44,29 @@ (except [exn:fail? (λ(e) #f)]))) +(define+provide/contract (directory->pagetree dir) + (coerce/path? . -> . pagetree?) + + (define (unique-sorted-output-paths xs) + (define output-paths (map ->output-path xs)) + (define all-paths (filter visible? (remove-duplicates output-paths))) + (define path-is-directory? (λ(f) (directory-exists? (build-path dir f)))) + (define-values (subdirectories files) (partition path-is-directory? all-paths)) + (define-values (pagetree-sources other-files) (partition pagetree-source? files)) + (define (sort-names xs) (sort xs #:key ->string stringsymbol (unique-sorted-output-paths (directory-list dir)))) + (error (format "directory->pagetree: directory ~a doesn't exist" dir)))) + ;; Try loading from pagetree file, or failing that, synthesize pagetree. (define+provide/contract (make-project-pagetree project-dir) (pathish? . -> . pagetree?) - (define pagetree-source (build-path project-dir world:default-pagetree)) - (cached-require pagetree-source world:main-pollen-export)) - + (with-handlers ([exn:fail? (λ(exn) (directory->pagetree project-dir))]) + (define pagetree-source (build-path project-dir world:default-pagetree)) + (cached-require pagetree-source world:main-pollen-export))) (define+provide/contract (parent pnish [pt (current-pagetree)]) (((or/c #f pagenodeish?)) (pagetree?) . ->* . (or/c #f pagenode?)) diff --git a/server-routes.rkt b/server-routes.rkt index 605dbab..1ce89f2 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -154,8 +154,8 @@ (explode-path (find-relative-path (world:current-project-root) dashboard-dir)) null))) (define dirlinks (cons "/" (map (λ(ps) (format "/~a/" (apply build-path ps))) - (for/list ([i (length (cdr dirs))]) - (take (cdr dirs) (add1 i)))))) + (for/list ([i (length (cdr dirs))]) + (take (cdr dirs) (add1 i)))))) `(tr (th ((colspan "3")) ,@(add-between (map (λ(dir dirlink) `(a ((href ,(format "~a~a" dirlink world:default-pagetree))) ,(->string dir))) dirs dirlinks) "/")))) (define (make-path-row filename-path) @@ -182,26 +182,13 @@ [(pagetree-source? filename) empty-cell] [else (cons (format "out/~a" filename) "out")])))))) - (define (ineligible-path? x) (or (not (visible? x)) (member x world:paths-excluded-from-dashboard))) - - (define (unique-sorted-output-paths xs) - (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 dashboard-dir f)))) - (define subdirectories (filter path-is-directory? all-paths)) - (define files (filter-not path-is-directory? all-paths)) - (define pagetree-sources (filter pagetree-source? files)) - (define other-files (filter-not pagetree-source? files)) - (define (sort-names xs) (sort xs #:key ->string stringpath (pagetree->list (cached-require (->path dashboard-ptree) world:main-pollen-export))) - (unique-sorted-output-paths (directory-list dashboard-dir))))) + (filter-not ineligible-path? (map ->path (pagetree->list + (if (file-exists? dashboard-ptree) + (cached-require (->path dashboard-ptree) world:main-pollen-export) + (directory->pagetree dashboard-dir)))))) (body-wrapper `(table diff --git a/template.rkt b/template.rkt index 4025c26..99b55b3 100644 --- a/template.rkt +++ b/template.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (for-syntax racket/base)) (require racket/string xml xml/path sugar/define sugar/container sugar/coerce/contract) -(require "file.rkt" txexpr "world.rkt" "cache.rkt" "pagetree.rkt") +(require "file.rkt" txexpr "world.rkt" "cache.rkt" "pagetree.rkt" "debug.rkt") (require sugar/coerce/value) @@ -10,7 +10,7 @@ (define/contract+provide (metas->here metas) (hash? . -> . pagenode?) - (path->pagenode (select-from-metas 'here-path metas))) + (path->pagenode (report (select-from-metas 'here-path metas)))) (define (pagenode->path pagenode)