You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
329 lines
14 KiB
Racket
329 lines
14 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base racket/syntax))
|
|
(require racket/path racket/match)
|
|
(require "../setup.rkt" sugar/define sugar/file sugar/coerce sugar/test)
|
|
|
|
|
|
;; because it comes up all the time
|
|
(define+provide (dirname path)
|
|
;(coerce/path? . -> . path?)
|
|
(define-values (dir name dir?) (split-path path))
|
|
dir)
|
|
|
|
|
|
(define+provide (find-upward-from starting-path filename-to-find
|
|
[exists-proc file-exists?])
|
|
;; use exists-proc to permit less strict matching.
|
|
;; for instance, maybe it's ok to find the source for the path.
|
|
;((coerce/path? coerce/path?)((path? . -> . any/c)) . ->* . (or/c #f path?))
|
|
(parameterize ([current-directory (dirname (->complete-path starting-path))])
|
|
(let loop ([dir (current-directory)][path filename-to-find])
|
|
(and dir ; dir is #f when it hits the top of the filesystem
|
|
(match (simple-form-path path)
|
|
[(? exists-proc sfp) sfp]
|
|
[_ (loop (dirname dir) (build-path 'up path))])))))
|
|
|
|
|
|
;; for files like svg that are not source in pollen terms,
|
|
;; but have a textual representation separate from their display.
|
|
(define+provide (sourceish? x)
|
|
;(any/c . -> . coerce/boolean?)
|
|
(define sourceish-extensions '("svg"))
|
|
(for/or ([ext (in-list sourceish-extensions)])
|
|
(equal? (get-ext x) ext)))
|
|
|
|
(module-test-external
|
|
(check-true (sourceish? "foo.svg"))
|
|
(check-false (sourceish? "foo.gif")))
|
|
|
|
|
|
;; compare directories by their exploded path elements,
|
|
;; not by equal?, which will give wrong result if no slash on the end
|
|
(define+provide (directories-equal? dirx diry)
|
|
;(coerce/path? coerce/path? . -> . coerce/boolean?)
|
|
(equal? (explode-path dirx) (explode-path diry)))
|
|
|
|
(module-test-external
|
|
(check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/"))
|
|
(check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo")))
|
|
|
|
|
|
(define (paths? x) (and (list? x) (andmap path? x)))
|
|
(define (complete-paths? x) (and (list? x) (andmap complete-path? x)))
|
|
|
|
|
|
(define+provide (path-visible? path)
|
|
(not (regexp-match #rx"^\\." (path->string path))))
|
|
|
|
|
|
(define+provide (escape-last-ext x [escape-char pollen-extension-escape-char])
|
|
;((pathish?) (char?) . ->* . coerce/path?)
|
|
;; if x has a file extension, reattach it with the escape char
|
|
(define current-ext (get-ext x))
|
|
(->path
|
|
(if current-ext
|
|
(format "~a~a~a" (->string (remove-ext x)) escape-char current-ext)
|
|
x)))
|
|
|
|
(module-test-external
|
|
(require sugar/coerce)
|
|
(check-equal? (escape-last-ext "foo") (->path "foo"))
|
|
(check-equal? (escape-last-ext "foo.html") (->path "foo_html"))
|
|
(check-equal? (escape-last-ext "foo.html" #\$) (->path "foo$html"))
|
|
(check-equal? (escape-last-ext "foo_bar.html") (->path "foo_bar_html")))
|
|
|
|
(define second cadr)
|
|
(define third caddr)
|
|
(define (last x) (car (reverse x)))
|
|
(define+provide (unescape-ext x [escape-char pollen-extension-escape-char])
|
|
;((coerce/string?) (char?) . ->* . coerce/path?)
|
|
;; if x has an escaped extension, unescape it.
|
|
(define-values (base _ dir?) (split-path x))
|
|
(->path
|
|
(cond
|
|
[dir? x]
|
|
;; if x has a standard extension, it can't also have an escapable extension, so we're done.
|
|
;; saves us the trouble of handling this case in the regexp below,
|
|
;; which otherwise would catch things like foo_bar.html (reasoning that _bar.html is all an extension)
|
|
[(get-ext x) x]
|
|
[else
|
|
(define x-parts (explode-path x))
|
|
(define filename (last x-parts))
|
|
(define escaped-extension-pat (pregexp (format "(.*)[~a](\\S+)$" escape-char)))
|
|
(define results (regexp-match escaped-extension-pat (->string filename)))
|
|
(if results
|
|
(let* ([filename-without-ext (second results)]
|
|
[ext (third results)]
|
|
[new-filename (add-ext filename-without-ext ext)])
|
|
(if (eq? base 'relative)
|
|
new-filename
|
|
(build-path base new-filename)))
|
|
x)])))
|
|
|
|
|
|
(module-test-external
|
|
(require sugar/coerce)
|
|
(check-equal? (unescape-ext "foo") (->path "foo"))
|
|
(check-equal? (unescape-ext "foo_") (->path "foo_"))
|
|
(check-equal? (unescape-ext "foo_#$%") (->path "foo.#$%"))
|
|
(check-equal? (unescape-ext "foo.html") (->path "foo.html"))
|
|
(check-equal? (unescape-ext "foo_html") (->path "foo.html"))
|
|
(check-equal? (unescape-ext "foo_dir/bar") (->path "foo_dir/bar"))
|
|
(check-equal? (unescape-ext "foo_dir/bar.html") (->path "foo_dir/bar.html"))
|
|
(check-equal? (unescape-ext "foo_dir/bar_html") (->path "foo_dir/bar.html"))
|
|
(check-equal? (unescape-ext "foo$html" #\$) (->path "foo.html"))
|
|
(check-equal? (unescape-ext "foo_bar__html") (->path "foo_bar_.html"))
|
|
(check-equal? (unescape-ext "foo_bar.html") (->path "foo_bar.html"))
|
|
(check-equal? (unescape-ext (escape-last-ext "foo_bar.html")) (->path "foo_bar.html"))
|
|
(check-equal? (unescape-ext "foo$bar$$html" #\$) (->path "foo$bar$.html")))
|
|
|
|
|
|
(define+provide (ext-in-poly-targets? ext [x #f])
|
|
(member (->symbol ext) (apply setup:poly-targets (if x (list x) null))))
|
|
|
|
(module-test-external
|
|
(check-equal? (ext-in-poly-targets? 'html) '(html))
|
|
(check-equal? (ext-in-poly-targets? 'missing) #f))
|
|
|
|
|
|
(define+provide (has-poly-ext? x)
|
|
(equal? (get-ext x) (->string pollen-poly-source-ext)))
|
|
|
|
(module-test-external
|
|
(check-true (has-poly-ext? "foo.poly"))
|
|
(check-false (has-poly-ext? "foo.wrong")))
|
|
|
|
|
|
(define+provide (has-inner-poly-ext? x)
|
|
(and (get-ext x) (has-poly-ext? (unescape-ext (remove-ext x)))))
|
|
|
|
(module-test-external
|
|
(check-true (has-inner-poly-ext? "foo.poly.pm"))
|
|
(check-true (has-inner-poly-ext? "foo_poly.pp"))
|
|
(check-false (has-inner-poly-ext? "foo.poly"))
|
|
(check-false (has-inner-poly-ext? "foo.wrong.pm")))
|
|
|
|
(define-syntax (define-utility-functions stx)
|
|
(syntax-case stx ()
|
|
[(_ STEM)
|
|
(with-syntax ([STEM-SOURCE-EXT (format-id stx "pollen-~a-source-ext" #'STEM)]
|
|
[STEM-SOURCE? (format-id stx "~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)]
|
|
[->STEM-SOURCE-PATH (format-id stx "->~a-source-path" #'STEM)]
|
|
[->STEM-SOURCE-PATHS (format-id stx "->~a-source-paths" #'STEM)]
|
|
[->STEM-SOURCE+OUTPUT-PATHS (format-id stx "->~a-source+output-paths" #'STEM)])
|
|
#`(begin
|
|
;; does file have particular extension
|
|
(define+provide (STEM-SOURCE? x)
|
|
#;(any/c . -> . boolean?)
|
|
(and (pathish? x) (has-ext? (->path x) STEM-SOURCE-EXT) #true))
|
|
|
|
;; non-theoretical: want the first possible source that exists in the filesystem
|
|
(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))
|
|
sp))
|
|
|
|
;; 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)
|
|
(->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 (->STEM-SOURCE-PATH x)
|
|
#;(pathish? . -> . (or/c #f path?))
|
|
(define paths (->STEM-SOURCE-PATHS x))
|
|
(and paths (car paths)))
|
|
|
|
;; get all possible source paths (does not check filesystem)
|
|
(define (->STEM-SOURCE-PATHS x)
|
|
(define results
|
|
(if (STEM-SOURCE? x)
|
|
(list x) ; already has the source extension
|
|
#,(if (eq? (syntax->datum #'STEM) 'scribble)
|
|
#'(if (x . has-ext? . 'html) ; different logic for scribble sources
|
|
(list (add-ext (remove-ext* x) STEM-SOURCE-EXT))
|
|
#false)
|
|
#'(let ([x-ext (get-ext x)]
|
|
[source-ext STEM-SOURCE-EXT])
|
|
(cons
|
|
(add-ext x source-ext) ; standard
|
|
(if x-ext ; has existing ext, therefore needs escaped version
|
|
(cons
|
|
(add-ext (escape-last-ext x) source-ext)
|
|
(if (ext-in-poly-targets? x-ext x) ; needs multi + escaped multi
|
|
(let ([x-multi (add-ext (remove-ext x) pollen-poly-source-ext)])
|
|
(list
|
|
(add-ext x-multi STEM-SOURCE-EXT)
|
|
(add-ext (escape-last-ext x-multi) source-ext)))
|
|
null))
|
|
null))))))
|
|
(and results (map ->path results)))
|
|
|
|
;; coerce either a source or output file to both
|
|
(define+provide (->STEM-SOURCE+OUTPUT-PATHS path)
|
|
;(pathish? . -> . (values path? path?))
|
|
;; get the real source path if available, otherwise a theoretical path
|
|
(values (->complete-path (or (GET-STEM-SOURCE path) (->STEM-SOURCE-PATH path)))
|
|
(->complete-path (->output-path path))))))]))
|
|
|
|
(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)
|
|
;(complete-path? . -> . (values complete-path? complete-path?))
|
|
;; file-proc returns two values, but ormap only wants one
|
|
(define file-proc
|
|
(match source-or-output-path
|
|
;; resolve these in alphabetical order, because project server gives priority to alphabetic order
|
|
[(? has/is-null-source?) ->null-source+output-paths] ; .p
|
|
[(? has/is-markup-source?) ->markup-source+output-paths] ; .pm
|
|
[(? has/is-markdown-source?) ->markdown-source+output-paths] ; .pmd
|
|
[(? has/is-preproc-source?) ->preproc-source+output-paths] ; .pp
|
|
[(? has/is-scribble-source?) ->scribble-source+output-paths] ; . scrbl
|
|
[_ (λ (x) (values #false #false))]))
|
|
(file-proc source-or-output-path))
|
|
|
|
|
|
(module-test-internal
|
|
(require sugar/coerce)
|
|
(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")
|
|
(->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? (->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")
|
|
(->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? (->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")
|
|
(->path "foo.poly.pmd") (->path "foo_poly.pmd")))
|
|
(check-equal? (->markdown-source-paths "foo") (list (->path "foo.pmd")))
|
|
(check-equal? (->markdown-source-paths 'foo) (list (->path "foo.pmd"))))
|
|
|
|
(define+provide (get-source pathish)
|
|
(define p (->path pathish))
|
|
(for/or ([proc (in-list (list get-markup-source get-markdown-source get-preproc-source get-null-source get-scribble-source))])
|
|
(proc p)))
|
|
|
|
;; for backward compatibility
|
|
(define+provide ->source-path get-source)
|
|
|
|
(define+provide (->output-path pathish)
|
|
(define p (->path pathish))
|
|
(->path
|
|
(cond
|
|
[(or (markup-source? p) (preproc-source? p) (null-source? p) (markdown-source? p))
|
|
(define output-path (unescape-ext (remove-ext p)))
|
|
(if (has-poly-ext? output-path)
|
|
(add-ext (remove-ext output-path) (or (current-poly-target) (car (setup:poly-targets))))
|
|
output-path)]
|
|
[(scribble-source? p) (add-ext (remove-ext p) 'html)]
|
|
[else p])))
|
|
|
|
|
|
(define+provide (project-files-with-ext ext)
|
|
;(coerce/symbol? . -> . complete-paths?)
|
|
(map ->complete-path (filter (λ (i) (has-ext? i (->symbol ext))) (directory-list (current-project-root)))))
|
|
|
|
|
|
(define (racket-source? x)
|
|
(->boolean (and (pathish? x) (has-ext? (->path x) 'rkt))))
|
|
|
|
|
|
;; to identify unsaved sources in DrRacket
|
|
(define (unsaved-source? path-string)
|
|
((substring (->string path-string) 0 7) . equal? . "unsaved"))
|
|
|
|
|
|
(define (ends-with? str ender)
|
|
(define pat (regexp (format "~a$" ender)))
|
|
(and (regexp-match pat str) #t))
|
|
|
|
|
|
(define+provide (special-path? path)
|
|
(define special-paths (append default-cache-names '("compiled" ".git" ".gitignore" ".hg" ".svn" "CVS" "Makefile" ".DS_Store")))
|
|
(and (member (path->string (last (explode-path path))) special-paths) #t))
|
|
|
|
(module-test-internal
|
|
(require sugar/coerce)
|
|
(check-true (special-path? (string->path "foo/pollen-cache")))
|
|
(check-false (special-path? (string->path "foo/bar-pollen-cache")))
|
|
(check-true (special-path? (string->path "compiled")))
|
|
(check-true (special-path? (string->path "foo/compiled")))
|
|
(check-false (special-path? (string->path "foo/rcompiled")))
|
|
(check-true (special-path? (string->path ".git")))
|
|
(check-true (special-path? (string->path "foo/.git")))
|
|
(check-false (special-path? (string->path "foo/robot.git"))))
|
|
|
|
|
|
(define+provide (omitted-path? file)
|
|
(for/or ([proc (in-list (list
|
|
preproc-source?
|
|
markup-source?
|
|
markdown-source?
|
|
pagetree-source?
|
|
scribble-source?
|
|
null-source?
|
|
racket-source?
|
|
special-path?
|
|
(setup:omitted-path?)
|
|
(setup:unpublished-path?)))])
|
|
(proc file)))
|
|
|
|
(define+provide (extra-path? file)
|
|
(for/or ([proc (in-list (list
|
|
(setup:extra-path?)
|
|
(setup:extra-published-path?)))])
|
|
(proc file))) |