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

refactor file-utils

Browse Source
pull/155/head
Matthew Butterick 7 years ago
parent e3d872f79a
commit aa8313058d
2 changed files with 92 additions and 93 deletions
Show Stats Download Patch File Download Diff File

179
pollen/private/file-utils.rkt
Unescape Escape View File

@ -29,9 +29,9 @@
;; but have a textual representation separate from their display. ;; but have a textual representation separate from their display.
(define+provide (sourceish? x) (define+provide (sourceish? x)
;(any/c . -> . coerce/boolean?) ;(any/c . -> . coerce/boolean?)
(define sourceish-extensions (list "svg")) (define sourceish-extensions '("svg"))
(with-handlers ([exn:fail? (λ (e) #f)]) (for/or ([ext (in-list sourceish-extensions)])
(and (member (get-ext x) sourceish-extensions) #t))) (equal? (get-ext x) ext)))
(module-test-external (module-test-external
(check-true (sourceish? "foo.svg")) (check-true (sourceish? "foo.svg"))
@ -52,18 +52,10 @@
(define (paths? x) (and (list? x) (andmap path? x))) (define (paths? x) (and (list? x) (andmap path? x)))
(define (complete-paths? x) (and (list? x) (andmap complete-path? x))) (define (complete-paths? x) (and (list? x) (andmap complete-path? x)))
(define+provide (path-visible? path) (define+provide (path-visible? path)
;; make paths absolute to test whether files exist,
;; then convert back to relative
(not (regexp-match #rx"^\\." (path->string path)))) (not (regexp-match #rx"^\\." (path->string path))))
(define+provide (visible-files dir)
(let ([dir (->path dir)])
(filter path-visible?
(map (λ (p) (find-relative-path dir p))
(filter file-exists?
(directory-list dir #:build? #t))))))
(define+provide (escape-last-ext x [escape-char (setup:extension-escape-char)]) (define+provide (escape-last-ext x [escape-char (setup:extension-escape-char)])
;((pathish?) (char?) . ->* . coerce/path?) ;((pathish?) (char?) . ->* . coerce/path?)
@ -87,7 +79,7 @@
(define+provide (unescape-ext x [escape-char (setup:extension-escape-char)]) (define+provide (unescape-ext x [escape-char (setup:extension-escape-char)])
;((coerce/string?) (char?) . ->* . coerce/path?) ;((coerce/string?) (char?) . ->* . coerce/path?)
;; if x has an escaped extension, unescape it. ;; if x has an escaped extension, unescape it.
(define-values (base name dir?) (split-path x)) (define-values (base _ dir?) (split-path x))
(->path (->path
(cond (cond
[dir? x] [dir? x]
@ -152,109 +144,115 @@
(check-false (has-inner-poly-ext? "foo.poly")) (check-false (has-inner-poly-ext? "foo.poly"))
(check-false (has-inner-poly-ext? "foo.wrong.pm"))) (check-false (has-inner-poly-ext? "foo.wrong.pm")))
(define-syntax (make-source-utility-functions stx) (define-syntax (define-utility-functions stx)
(syntax-case stx () (syntax-case stx ()
[(_ stem) [(_ STEM)
(with-syntax ([setup:stem-source-ext (format-id stx "setup:~a-source-ext" #'stem)] (with-syntax ([SETUP:STEM-SOURCE-EXT (format-id stx "setup:~a-source-ext" #'STEM)]
[stem-source? (format-id stx "~a-source?" #'stem)] [STEM-SOURCE? (format-id stx "~a-source?" #'STEM)]
[get-stem-source (format-id stx "get-~a-source" #'stem)] [GET-STEM-SOURCE (format-id stx "get-~a-source" #'STEM)]
[has/is-stem-source? (format-id stx "has/is-~a-source?" #'stem)] [HAS/IS-STEM-SOURCE? (format-id stx "has/is-~a-source?" #'STEM)]
[->stem-source-path (format-id stx "->~a-source-path" #'stem)] [->STEM-SOURCE-PATH (format-id stx "->~a-source-path" #'STEM)]
[->stem-source-paths (format-id stx "->~a-source-paths" #'stem)] [->STEM-SOURCE-PATHS (format-id stx "->~a-source-paths" #'STEM)]
[->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/contract (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)) #t))
;; 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/contract (GET-STEM-SOURCE x)
(coerce/path? . -> . (or/c #f path?)) (coerce/path? . -> . (or/c #f path?))
(let ([source-paths (->stem-source-paths x)]) (define source-paths (or (->STEM-SOURCE-PATHS x) null))
(and source-paths (for/first ([sp (in-list source-paths)] (for/first ([sp (in-list source-paths)]
#:when (file-exists? sp)) #:when (file-exists? sp))
sp)))) sp))
;; it's a file-ext source file, or a file that's the result of a file-ext source ;; it's a file-ext source file, or a file that's the result of a file-ext source
(define+provide (has/is-stem-source? x) (define+provide (HAS/IS-STEM-SOURCE? x)
(->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/contract (->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)))
;; get all possible source paths (does not check filesystem) ;; get all possible source paths (does not check filesystem)
(define (->stem-source-paths x) (define (->STEM-SOURCE-PATHS x)
(define results (if (stem-source? x) (define results
(list x) ; already has the source extension (if (STEM-SOURCE? x)
#,(if (eq? (syntax->datum #'stem) 'scribble) (list x) ; already has the source extension
#'(if (x . has-ext? . 'html) ; different logic for scribble sources #,(if (eq? (syntax->datum #'STEM) 'scribble)
(list (add-ext (remove-ext* x) (setup:stem-source-ext))) #'(if (x . has-ext? . 'html) ; different logic for scribble sources
#f) (list (add-ext (remove-ext* x) (SETUP:STEM-SOURCE-EXT)))
#'(let ([x-ext (get-ext x)] #f)
[source-ext (setup:stem-source-ext)]) #'(let ([x-ext (get-ext x)]
(append [source-ext (SETUP:STEM-SOURCE-EXT)])
(list (add-ext x source-ext)) ; standard (cons
(if x-ext ; has existing ext, therefore needs escaped version (add-ext x source-ext) ; standard
(append (if x-ext ; has existing ext, therefore needs escaped version
(list (add-ext (escape-last-ext x) source-ext)) (cons
(if (ext-in-poly-targets? x-ext x) ; needs multi + escaped multi (add-ext (escape-last-ext x) source-ext)
(let ([x-multi (add-ext (remove-ext x) (setup:poly-source-ext))]) (if (ext-in-poly-targets? x-ext x) ; needs multi + escaped multi
(list (let ([x-multi (add-ext (remove-ext x) (setup:poly-source-ext))])
(add-ext x-multi (setup:stem-source-ext)) (list
(add-ext (escape-last-ext x-multi) source-ext))) (add-ext x-multi (SETUP:STEM-SOURCE-EXT))
null)) (add-ext (escape-last-ext x-multi) source-ext)))
null)))))) null))
null))))))
(and results (map ->path results))) (and results (map ->path results)))
;; coerce either a source or output file to both ;; coerce either a source or output file to both
(define+provide (->stem-source+output-paths path) (define+provide (->STEM-SOURCE+OUTPUT-PATHS path)
;(pathish? . -> . (values path? path?)) ;(pathish? . -> . (values path? path?))
;; get the real source path if available, otherwise a theoretical path ;; get the real source path if available, otherwise a theoretical path
(values (->complete-path (or (get-stem-source path) (->stem-source-path path))) (values (->complete-path (or (GET-STEM-SOURCE path) (->STEM-SOURCE-PATH path)))
(->complete-path (->output-path path))))))])) (->complete-path (->output-path path))))))]))
(make-source-utility-functions preproc) (define-utility-functions preproc)
(define-utility-functions null)
(define-utility-functions pagetree)
(define-utility-functions markup)
(define-utility-functions markdown)
(define-utility-functions scribble)
(define+provide (->source+output-paths source-or-output-path) (define+provide (->source+output-paths source-or-output-path)
;(complete-path? . -> . (values complete-path? complete-path?)) ;(complete-path? . -> . (values complete-path? complete-path?))
;; file-proc returns two values, but ormap only wants one ;; file-proc returns two values, but ormap only wants one
(define file-proc (ormap (λ (test file-proc) (and (test source-or-output-path) file-proc)) (define tests (list
(list has/is-null-source? has/is-preproc-source? has/is-markup-source? has/is-scribble-source? has/is-markdown-source? ) has/is-null-source?
(list ->null-source+output-paths ->preproc-source+output-paths ->markup-source+output-paths ->scribble-source+output-paths ->markdown-source+output-paths ))) has/is-preproc-source?
has/is-markup-source?
has/is-scribble-source?
has/is-markdown-source?))
(define file-procs (list ->null-source+output-paths
->preproc-source+output-paths
->markup-source+output-paths
->scribble-source+output-paths
->markdown-source+output-paths))
(define file-proc (for/first ([test (in-list tests)]
[file-proc (in-list file-procs)]
#:when (test source-or-output-path))
file-proc))
(file-proc source-or-output-path)) (file-proc source-or-output-path))
(module-test-internal (module-test-internal
(require sugar/coerce) (require sugar/coerce)
(check-equal? (->preproc-source-paths (->path "foo.pp")) (list (->path "foo.pp"))) (check-equal? (->preproc-source-paths (->path "foo.pp")) (list (->path "foo.pp")))
(check-equal? (->preproc-source-paths (->path "foo.html")) (list (->path "foo.html.pp") (->path "foo_html.pp") (check-equal? (->preproc-source-paths (->path "foo.html")) (list (->path "foo.html.pp") (->path "foo_html.pp")
(->path "foo.poly.pp") (->path "foo_poly.pp"))) (->path "foo.poly.pp") (->path "foo_poly.pp")))
(check-equal? (->preproc-source-paths "foo") (list (->path "foo.pp"))) (check-equal? (->preproc-source-paths "foo") (list (->path "foo.pp")))
(check-equal? (->preproc-source-paths 'foo) (list (->path "foo.pp")))) (check-equal? (->preproc-source-paths 'foo) (list (->path "foo.pp")))
(make-source-utility-functions null)
(make-source-utility-functions pagetree)
(make-source-utility-functions markup)
(module-test-internal
(require sugar/coerce)
(check-equal? (->markup-source-paths (->path "foo.pm")) (list (->path "foo.pm"))) (check-equal? (->markup-source-paths (->path "foo.pm")) (list (->path "foo.pm")))
(check-equal? (->markup-source-paths (->path "foo.html")) (list (->path "foo.html.pm") (->path "foo_html.pm") (check-equal? (->markup-source-paths (->path "foo.html")) (list (->path "foo.html.pm") (->path "foo_html.pm")
(->path "foo.poly.pm") (->path "foo_poly.pm"))) (->path "foo.poly.pm") (->path "foo_poly.pm")))
(check-equal? (->markup-source-paths "foo") (list (->path "foo.pm"))) (check-equal? (->markup-source-paths "foo") (list (->path "foo.pm")))
(check-equal? (->markup-source-paths 'foo) (list (->path "foo.pm")))) (check-equal? (->markup-source-paths 'foo) (list (->path "foo.pm")))
(make-source-utility-functions markdown)
(module-test-internal
(require sugar/coerce)
(check-equal? (->markdown-source-paths (->path "foo.pmd")) (list (->path "foo.pmd"))) (check-equal? (->markdown-source-paths (->path "foo.pmd")) (list (->path "foo.pmd")))
(check-equal? (->markdown-source-paths (->path "foo.html")) (list (->path "foo.html.pmd") (->path "foo_html.pmd") (check-equal? (->markdown-source-paths (->path "foo.html")) (list (->path "foo.html.pmd") (->path "foo_html.pmd")
(->path "foo.poly.pmd") (->path "foo_poly.pmd"))) (->path "foo.poly.pmd") (->path "foo_poly.pmd")))
@ -262,7 +260,6 @@
(check-equal? (->markdown-source-paths 'foo) (list (->path "foo.pmd")))) (check-equal? (->markdown-source-paths 'foo) (list (->path "foo.pmd"))))
(make-source-utility-functions scribble)
(define+provide/contract (get-source path) (define+provide/contract (get-source path)
@ -320,19 +317,21 @@
(define+provide (omitted-path? file) (define+provide (omitted-path? file)
(ormap (λ (proc) (proc file)) (list (for/or ([proc (in-list (list
preproc-source? preproc-source?
markup-source? markup-source?
markdown-source? markdown-source?
pagetree-source? pagetree-source?
scribble-source? scribble-source?
null-source? null-source?
racket-source? racket-source?
special-path? special-path?
(setup:omitted-path?) (setup:omitted-path?)
(setup:unpublished-path?)))) ; deprecated name (setup:unpublished-path?)))])
(proc file)))
(define+provide (extra-path? file) (define+provide (extra-path? file)
(ormap (λ (proc) (proc file)) (list (for/or ([proc (in-list (list
(setup:extra-path?) (setup:extra-path?)
(setup:extra-published-path?)))) ; deprecated name (setup:extra-published-path?)))])
(proc file)))

2
pollen/private/ts.rktd
Unescape Escape View File

@ -1 +1 @@
1502138073 1502139238

Write Preview
Loading…
Cancel
Save