update contracts in file-tools

file-tools.rkt

@@ -3,107 +3,57 @@
 (require (only-in racket/path filename-extension))
 (require "world.rkt" sugar)
 
-(provide (contract-out
-          [sourceish? (any/c . -> . boolean?)]
-          [urlish? (any/c . -> . boolean?)]
-          [pathish? (any/c . -> . boolean?)]
-          [directory-pathish? (any/c . -> . boolean?)]
-          [directories-equal? (pathish? pathish? . -> . boolean?)]
-          [get-enclosing-dir (pathish? . -> . path?)]
-          [has-ext? (pathish? stringish? . -> . boolean?)]
-          [has-binary-ext? (pathish? . -> . boolean?)]
-          [get-ext (pathish? . -> . (or/c string? #f))]
-          [add-ext (pathish? stringish? . -> . path?)] 
-          [remove-ext (pathish? . -> . path?)]
-          [remove-all-ext (pathish? . -> . path?)]
-          [preproc-source? (any/c . -> . boolean?)]
-          [has-preproc-source? (any/c . -> . boolean?)]
-          [has-decoder-source? (any/c . -> . boolean?)]
-          [needs-preproc? (any/c . -> . boolean?)]
-          [needs-template? (any/c . -> . boolean?)]
-          [ptree-source? (any/c . -> . boolean?)]
-          [decoder-source? (any/c . -> . boolean?)]
-          [template-source? (any/c . -> . boolean?)]
-          [project-require-file? (any/c . -> . boolean?)]
-          [->preproc-source-path (pathish? . -> . path?)]
-          [->output-path (pathish? . -> . path?)]
-          [->decoder-source-path (pathish? . -> . path?)]
-          [project-files-with-ext (symbol? . -> . (listof complete-path?))]))
-
-(provide visible? visible-files)
-
 (module+ test (require rackunit))
 
 ;; for files like svg that are not source in pollen terms,
 ;; but have a textual representation separate from their display.
-(define (sourceish? x)
+(define/provide/contract (sourceish? x)
-  (define sourceish-extensions
+  (any/c . -> . coerce/boolean?)
-    (list "svg"))
+  (define sourceish-extensions (list "svg"))
-  (with-handlers ([exn:fail? (λ(e) #f)])
+  (try ((get-ext x) . in? . sourceish-extensions)
-    (->boolean ((get-ext x) . in? . sourceish-extensions))))
+       (except [exn:fail? (λ(e) #f)])))
 
-(module+ test
-  (check-true (sourceish? "foo.svg"))
-  (check-false (sourceish? "foo.gif")))
 
 ;; if something can be successfully coerced to a url,
 ;; it's urlish.
-(define (urlish? x)
+(define/provide/contract (urlish? x)
-  (with-handlers ([exn:fail? (λ(e) #f)])
+  (any/c . -> . coerce/boolean?)
-    (->boolean (->url x))))
+  (try (->url x) (except [exn:fail? (λ(e) #f)])))
 
-(module+ test
-  (check-true (urlish? (->path "/Users/MB/home.html")))
-  (check-true (urlish? "/Users/MB/home.html?foo=bar"))
-  (check-true (urlish? (->symbol "/Users/MB/home"))))
 
 ;; if something can be successfully coerced to a path,
 ;; it's pathish.
-(define (pathish? x)
+(define/provide/contract (pathish? x)
-  (with-handlers ([exn:fail? (λ(e) #f)])
+  (any/c . -> . coerce/boolean?)
-    (->boolean (->path x))))
+  (try (->path x) (except [exn:fail? (λ(e) #f)])))
 
-(module+ test
-  (check-true (pathish? (->path "/Users/MB/home")))
-  (check-true (pathish? "/Users/MB/home"))
-  (check-true (pathish? (->symbol "/Users/MB/home"))))
 
 ;; like pathish, but for directories
 ;; todo: is this contract too restrictive?
 ;; pathish doesn't require the path to exist,
 ;; but this one does.
-(define (directory-pathish? x)
+(define/provide/contract (directory-pathish? x)
-  (->boolean (and (pathish? x) (directory-exists? (->path x)))))
+  (any/c . -> . coerce/boolean?)
-
+  (and (pathish? x) (directory-exists? (->path x))))
-(module+ test
-  (check-true (directory-pathish? "/Users/"))
-  (check-false (directory-pathish? "foobarzooblish")))
-
 
 ;; compare directories by their exploded path elements,
 ;; not by equal?, which will give wrong result if no slash on the end
-(define (directories-equal? dirx diry)
+(define/provide/contract (directories-equal? dirx diry)
-  (equal? (explode-path (->path dirx)) (explode-path (->path diry))))
+  (coerce/path? coerce/path? . -> . coerce/boolean?)
-
+  (equal? (explode-path dirx) (explode-path diry)))
-(module+ test
-  (check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/"))
-  (check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo")))
-
-(define (get-enclosing-dir p) 
-  (simplify-path (build-path (->path p) 'up)))
-
-(module+ test
-  (check-equal? (get-enclosing-dir "/Users/MB/foo.txt") (->path "/Users/MB/"))
-  (check-equal? (get-enclosing-dir "/Users/MB/foo/") (->path "/Users/MB/")))
 
+(define/provide/contract (get-enclosing-dir p)
+  (coerce/path? . -> . path?)
+  (simplify-path (build-path p 'up)))
 
 ;; helper function for ptree
 ;; make paths absolute to test whether files exist,
 ;; then convert back to relative
-(define (visible? path)
+(define/provide/contract (visible? path)
+  (coerce/path? . -> . coerce/boolean?)
   (not ((->string path) . starts-with? . ".")))
 
-(define (visible-files dir)
+(define/provide/contract (visible-files dir)
   (directory-pathish? . -> . (listof path?))
   (filter visible? 
           (map (λ(p) (find-relative-path dir p)) 
@@ -111,206 +61,137 @@
                        (directory-list dir #:build? #t)))))
 
 ;; does path have a certain extension
-(define (has-ext? x ext)
+(define/provide/contract (has-ext? x ext)
-  (define ext-of-path (filename-extension (->path x)))
+  (coerce/path? coerce/symbol? . -> . coerce/boolean?)
-  (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext)))))
+  (define ext-of-path (filename-extension x))
+  (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (symbol->string ext)))))
 
 
 ;; todo: add extensions
 (define binary-extensions
   '(gif jpg jpeg mp3 png zip pdf ico tar ai eps))
 
-(define (has-binary-ext? x)
+(define/provide/contract (has-binary-ext? x)
-  (define path-x (->path x))
+  (coerce/path? . -> . coerce/boolean?)
-  (ormap (λ(ext) (has-ext? path-x ext)) binary-extensions))
+  (ormap (λ(ext) (has-ext? x ext)) binary-extensions))
-
-(module+ test
-  (check-true (has-binary-ext? "foo.MP3"))
-  (check-false (has-binary-ext? "foo.py")))
-
-
-(module+ test
-  (define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
-  (define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path) 
-    (apply values (map ->path foo-path-strings)))
-  ;; test the sample paths before using them for other tests
-  (define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
-  (for-each check-equal? (map ->string foo-paths) foo-path-strings))
-
-
-(module+ test
-  (check-false (has-ext? foo-path 'txt)) 
-  (check-true (foo.txt-path . has-ext? . 'txt))
-  (check-true ((->path "foo.TXT") . has-ext? . 'txt))
-  (check-true (has-ext? foo.bar.txt-path 'txt))
-  (check-false (foo.bar.txt-path . has-ext? . 'doc))) ; wrong extension
 
 
 ;; get file extension as a string, or return #f 
-(define (get-ext x)
+;; (consistent with filename-extension behavior)
-  (let ([fe-result (filename-extension (->path x))])
+(define/provide/contract (get-ext x)
+  (coerce/path? . -> . (or/c string? #f))
+  (let ([fe-result (filename-extension x)])
     (and fe-result (bytes->string/utf-8 fe-result))))
 
-(module+ test
-  (check-equal? (get-ext (->path "foo.txt")) "txt")
-  (check-false (get-ext "foo")))
-
 
 ;; put extension on path
-(define (add-ext x ext)
+;; use local contract here because this function is used within module
-  (->path (string-append (->string x) "." (->string ext))))
+(provide add-ext)
-
+(define/contract (add-ext x ext)
-(module+ test
+  (coerce/string? coerce/string? . -> . coerce/path?)
-  (check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")))
+  (string-append x "." ext))
 
 ;; take one extension off path
-(define (remove-ext x)
+(define/provide/contract (remove-ext x)
+  (coerce/path? . -> . path?)
   ;; pass through hidden files (those starting with a dot)
   (if (x . starts-with? . ".")
       x
-      (path-replace-suffix (->path x) "")))
+      (path-replace-suffix x "")))
-
-(module+ test  
-  (check-equal? (remove-ext foo-path) foo-path)
-  (check-equal? (remove-ext (->path ".foo.txt")) (->path ".foo.txt"))
-  (check-equal? (remove-ext foo.txt-path) foo-path)
-  (check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
-  (check-not-equal? (remove-ext foo.bar.txt-path) foo-path)) ; does not remove all extensions
 
 
 ;; take all extensions off path
-(define (remove-all-ext x)
+(define/provide/contract (remove-all-ext x)
+  (coerce/path? . -> . path?)
   ;; pass through hidden files (those starting with a dot)
   (if (x . starts-with? . ".")
       x
-      (let* ([path (->path x)]
+      (let ([path-with-removed-ext (remove-ext x)])
-             [path-with-removed-ext (remove-ext path)])
+        (if (equal? x path-with-removed-ext)
-        (if (equal? path path-with-removed-ext)
+            x
-            path
             (remove-all-ext path-with-removed-ext)))))
 
-(module+ test  
-  (check-equal? (remove-all-ext foo-path) foo-path)
-  (check-equal? (remove-all-ext foo.txt-path) foo-path)
-  (check-equal? (remove-all-ext (->path ".foo.txt")) (->path ".foo.txt"))
-  (check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext
-  (check-equal? (remove-all-ext foo.bar.txt-path) foo-path))
 
 
 ;; todo: tests for these predicates
 
-
+(define/provide/contract (preproc-source? x)
-(define (preproc-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) (has-ext? (->path x) PREPROC_SOURCE_EXT)))
 
-(module+ test
-  (check-true (preproc-source? "foo.p"))
-  (check-false (preproc-source? "foo.bar"))
-  (check-false (preproc-source? #f)))
 
-(define (has-preproc-source? x)
+(define/provide/contract (has-preproc-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) (file-exists? (->preproc-source-path (->path x)))))
 
-(define (has-decoder-source? x)
+(define/provide/contract (has-decoder-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) (file-exists? (->decoder-source-path (->path x)))))
 
-(define (needs-preproc? x)
+(define/provide/contract (needs-preproc? x)
+  (any/c . -> . coerce/boolean?)
   ; it's a preproc source file, or a file that's the result of a preproc source
   (and (pathish? x) (ormap (λ(proc) (proc (->path x))) (list preproc-source? has-preproc-source?))))
 
-(define (needs-template? x)
+(define/provide/contract (needs-template? x)
+  (any/c . -> . coerce/boolean?)
   ; it's a pollen source file
   ; or a file (e.g., html) that has a pollen source file
   (and (pathish? x) (ormap (λ(proc) (proc (->path x))) (list decoder-source? has-decoder-source?))))
 
 
-(define (ptree-source? x)
+(define/provide/contract (ptree-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) ((->path x) . has-ext? . PTREE_SOURCE_EXT)))
 
-(module+ test
-  (check-true (ptree-source? (format "foo.~a" PTREE_SOURCE_EXT)))
-  (check-false (ptree-source? (format "~a.foo" PTREE_SOURCE_EXT)))
-  (check-false (ptree-source? #f)))
-
 
-
+(define/provide/contract (decoder-source? x)
-(define (decoder-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) (has-ext? x DECODER_SOURCE_EXT)))
 
-(module+ test
-  (check-true (decoder-source? "foo.pd"))
-  (check-false (decoder-source? "foo.p"))
-  (check-false (decoder-source? #f)))
-
 
-(define (template-source? x)
+(define/provide/contract (template-source? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x)
        (let-values ([(dir name ignore) (split-path x)])
          (equal? (get (->string name) 0) TEMPLATE_SOURCE_PREFIX))))
 
-(module+ test
-  (check-true (template-source? "-foo.html"))
-  (check-false (template-source? "foo.html"))
-  (check-false (template-source? #f)))
-
-
 ;; predicate for files that are eligible to be required
 ;; from the project/require directory
 ;; todo: extend this beyond just racket files?
-(define (project-require-file? x)
+(define/provide/contract (project-require-file? x)
+  (any/c . -> . coerce/boolean?)
   (and (pathish? x) (has-ext? x 'rkt)))
 
-(module+ test
-  (check-true (project-require-file? "foo.rkt"))
-  (check-false (project-require-file? "foo.html")))
-
-
-
 
 
 ;; todo: tighten these input contracts
 ;; so that, say, a source-path cannot be input for make-preproc-source-path
-(define (->preproc-source-path x)
+(define/provide/contract (->preproc-source-path x)
-  (->path (if (preproc-source? x)
+  (coerce/path? . -> . coerce/path?)
+  (if (preproc-source? x)
       x
-              (add-ext x PREPROC_SOURCE_EXT))))
+      (add-ext x PREPROC_SOURCE_EXT)))
-
-(module+ test
-  (check-equal? (->preproc-source-path (->path "foo.p")) (->path "foo.p"))
-  (check-equal? (->preproc-source-path (->path "foo.html")) (->path "foo.html.p"))
-  (check-equal? (->preproc-source-path "foo") (->path "foo.p"))
-  (check-equal? (->preproc-source-path 'foo) (->path "foo.p")))
 
-(define (->output-path x)
+(define/provide/contract (->output-path x)
-  (->path 
+  (coerce/path? . -> . coerce/path?)
   (if (or (decoder-source? x) (preproc-source? x))
       (remove-ext x)
-       x)))
+      x))
-
-(module+ test
-  (check-equal? (->output-path (->path "foo.ptree")) (->path "foo.ptree"))
-  (check-equal? (->output-path "foo.html") (->path "foo.html"))
-  (check-equal? (->output-path 'foo.html.p) (->path "foo.html"))
-  (check-equal? (->output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html"))
-  (check-equal? (->output-path "foo.xml.p") (->path "foo.xml"))
-  (check-equal? (->output-path 'foo.barml.p) (->path "foo.barml")))
 
 ;; turns input into corresponding pollen source path
 ;; does not, however, validate that new path exists
 ;; todo: should it? I don't think so, sometimes handy to make the name for later use
 ;; OK to use pollen source as input (comes out the same way)
-(define (->decoder-source-path x)
+(define/provide/contract (->decoder-source-path x)
-  (->path (if (decoder-source? x)
+  (coerce/path? . -> . coerce/path?)
+  (if (decoder-source? x)
       x
-              (add-ext x DECODER_SOURCE_EXT))))
+      (add-ext x DECODER_SOURCE_EXT)))
 
-(module+ test
-  (check-equal? (->decoder-source-path (->path "foo.pd")) (->path "foo.pd"))
-  (check-equal? (->decoder-source-path (->path "foo.html")) (->path "foo.html.pd"))
-  (check-equal? (->decoder-source-path "foo") (->path "foo.pd"))
-  (check-equal? (->decoder-source-path 'foo) (->path "foo.pd")))
 
-(define (project-files-with-ext ext)
+(define/provide/contract (project-files-with-ext ext)
+  (coerce/symbol? . -> . (listof complete-path?))
   (map ->complete-path (filter (λ(i) (has-ext? i ext)) (directory-list PROJECT_ROOT))))
 
 ;; to identify unsaved sources in DrRacket

tests/file-tools-tests.rkt

@@ -0,0 +1,110 @@
+#lang racket/base
+
+(module+ test (require rackunit "../file-tools.rkt" "../world.rkt" sugar))
+
+(module+ test
+  (check-true (sourceish? "foo.svg"))
+  (check-false (sourceish? "foo.gif")))
+
+(module+ test
+  (check-true (urlish? (->path "/Users/MB/home.html")))
+  (check-true (urlish? "/Users/MB/home.html?foo=bar"))
+  (check-true (urlish? (->symbol "/Users/MB/home"))))
+
+(module+ test
+  (check-true (pathish? (->path "/Users/MB/home")))
+  (check-true (pathish? "/Users/MB/home"))
+  (check-true (pathish? (->symbol "/Users/MB/home"))))
+
+
+(module+ test
+  (check-true (directory-pathish? "/Users/"))
+  (check-false (directory-pathish? "foobarzooblish")))
+
+(module+ test
+  (check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/"))
+  (check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo")))
+
+(module+ test
+  (check-equal? (get-enclosing-dir "/Users/MB/foo.txt") (->path "/Users/MB/"))
+  (check-equal? (get-enclosing-dir "/Users/MB/foo/") (->path "/Users/MB/")))
+
+(module+ test
+  (check-true (has-binary-ext? "foo.MP3"))
+  (check-false (has-binary-ext? "foo.py")))
+
+
+(module+ test
+  (define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
+  (define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path) 
+    (apply values (map ->path foo-path-strings)))
+  ;; test the sample paths before using them for other tests
+  (define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
+  (for-each check-equal? (map ->string foo-paths) foo-path-strings))
+
+(module+ test
+  (check-false (has-ext? foo-path 'txt)) 
+  (check-true (foo.txt-path . has-ext? . 'txt))
+  (check-true ((->path "foo.TXT") . has-ext? . 'txt))
+  (check-true (has-ext? foo.bar.txt-path 'txt))
+  (check-false (foo.bar.txt-path . has-ext? . 'doc))) ; wrong extension
+
+
+(module+ test
+  (check-equal? (get-ext (->path "foo.txt")) "txt")
+  (check-false (get-ext "foo")))
+
+(module+ test
+  (check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")))
+(module+ test  
+  (check-equal? (remove-ext foo-path) foo-path)
+  (check-equal? (remove-ext (->path ".foo.txt")) (->path ".foo.txt"))
+  (check-equal? (remove-ext foo.txt-path) foo-path)
+  (check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
+  (check-not-equal? (remove-ext foo.bar.txt-path) foo-path)) ; does not remove all extensions
+
+
+(module+ test  
+  (check-equal? (remove-all-ext foo-path) foo-path)
+  (check-equal? (remove-all-ext foo.txt-path) foo-path)
+  (check-equal? (remove-all-ext (->path ".foo.txt")) (->path ".foo.txt"))
+  (check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext
+  (check-equal? (remove-all-ext foo.bar.txt-path) foo-path))
+(module+ test
+  (check-true (preproc-source? "foo.p"))
+  (check-false (preproc-source? "foo.bar"))
+  (check-false (preproc-source? #f)))
+
+(module+ test
+  (check-true (ptree-source? (format "foo.~a" PTREE_SOURCE_EXT)))
+  (check-false (ptree-source? (format "~a.foo" PTREE_SOURCE_EXT)))
+  (check-false (ptree-source? #f)))
+(module+ test
+  (check-true (decoder-source? "foo.pd"))
+  (check-false (decoder-source? "foo.p"))
+  (check-false (decoder-source? #f)))
+
+(module+ test
+  (check-true (template-source? "-foo.html"))
+  (check-false (template-source? "foo.html"))
+  (check-false (template-source? #f)))
+(module+ test
+  (check-true (project-require-file? "foo.rkt"))
+  (check-false (project-require-file? "foo.html")))
+(module+ test
+  (check-equal? (->preproc-source-path (->path "foo.p")) (->path "foo.p"))
+  (check-equal? (->preproc-source-path (->path "foo.html")) (->path "foo.html.p"))
+  (check-equal? (->preproc-source-path "foo") (->path "foo.p"))
+  (check-equal? (->preproc-source-path 'foo) (->path "foo.p")))
+(module+ test
+  (check-equal? (->output-path (->path "foo.ptree")) (->path "foo.ptree"))
+  (check-equal? (->output-path "foo.html") (->path "foo.html"))
+  (check-equal? (->output-path 'foo.html.p) (->path "foo.html"))
+  (check-equal? (->output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html"))
+  (check-equal? (->output-path "foo.xml.p") (->path "foo.xml"))
+  (check-equal? (->output-path 'foo.barml.p) (->path "foo.barml")))
+(module+ test
+  (check-equal? (->decoder-source-path (->path "foo.pd")) (->path "foo.pd"))
+  (check-equal? (->decoder-source-path (->path "foo.html")) (->path "foo.html.pd"))
+  (check-equal? (->decoder-source-path "foo") (->path "foo.pd"))
+  (check-equal? (->decoder-source-path 'foo) (->path "foo.pd")))