(module file mzscheme
  (require (lib "contract.ss"))
  (require (lib "etc.ss"))
  (require (lib "file.ss"))
  (require (lib "list.ss" "srfi" "1"))

  ;; A relative-path is a path for which relative-path? is #t.

  ;; relative-path/c : contract
  (define relative-path/c
    (and/c (union path? string?) relative-path?))

  ;; A relative-file-path is a path for which relative-path? and file-exists?
  ;; are both #t.

  ;; relative-file-path/c : contract
  (define relative-file-path/c
    (and/c relative-path/c file-exists?))

  ;; A relative-directory-path is a path for which relative-path? and
  ;; directory-exists? are both #t.

  ;; relative-directory-path/c : contract
  (define relative-directory-path/c
    (and/c relative-path/c directory-exists?))

  ;; path->relative-path : (union string path) [(union string path)] -> relative-path
  ;; converts a path to a relative path
  (define path->relative-path
    (opt-lambda (path [relative-to (current-directory)])
      (let-values ([(base name must-be-dir?) (split-path path)])
        (let loop ([base base] [name name] [rest (list name)])
          (if (path=? base relative-to)
              (apply build-path rest)
              (let-values ([(base name must-be-dir?) (split-path base)])
                (loop base name (cons name rest))))))))

  ;; explode-relative-path : relative-path -> (listof path)
  ;; computes the list of directories in a relative path
  (define (explode-relative-path path)
    (let loop ([path path] [rest '()])
      (let-values ([(base name dir?) (split-path path)])
        (cond
          [(eq? base 'relative) (cons name rest)]
          [(or (not (path? name)) (not path))
           (raise-type-error 'explode-relative-path
                             "relative-path in normal form"
                             path)]
          [else (loop base (cons name rest))]))))

  ;; TODO: make this work with complete paths, too?

  ;; TODO: is the directory-exists? test appropriate here? I'm thinking no...

  ;; collect-subdirectories : relative-path -> (listof relative-path)
  (define (collect-subdirectories path)
    (fold (lambda (dir dirs)
            (let ([fst (if (null? dirs)
                           dir
                           (build-path (car dirs) dir))])
              (if (directory-exists? fst)
                  (cons fst dirs)
                  dirs)))
          null
          (explode-relative-path path)))

  ;; path=?/2 : path path -> boolean
  (define (path=?/2 path1 path2)
    (or (and (not path1) (not path2))
        (let-values ([(base1 name1 dir1?) (split-path path1)]
                     [(base2 name2 dir2?) (split-path path2)])
          (and (or (and (symbol? name1) (symbol? name2) (eq? name1 name2))
                   (and (path? name1) (path? name2)
                        (bytes=? (path->bytes name1) (path->bytes name2))))
               (path=?/2 base1 base2)))))

  ;; path=? : path path ... -> boolean
  ;; determines whether two paths contain exactly the same elements
  (define (path=? path1 path2 . paths)
    (andmap (lambda (path2)
              (path=?/2 path1 path2))
            (cons path2 paths)))

  ;; path-normalized=? : path path ... -> boolean
  ;; determines whether two paths refer to the same normalized path
  (define (path-normalized=? path1 path2 . paths)
    (apply bytes=? (map (compose path->bytes normalize-path)
                        (cons path1 (cons path2 paths)))))

  ;; TODO: can we make these contracts a little more precise? -- namely, the
  ;;       relative-paths must be in normal form (no ../ or ./, for example)

  (provide/contract
   [relative-path/c contract?]
   [relative-file-path/c contract?]
   [relative-directory-path/c contract?]
   [path->relative-path (((union string? path?))
                         ((union string? path?))
                         . opt-> .
                         relative-path/c)]
   [explode-relative-path (relative-path/c . -> . (listof path?))]
   [collect-subdirectories (relative-path/c . -> . (listof relative-path/c))]
   [path=? ((path? path?) (listof path?) . ->* . (boolean?))]
   [path-normalized=? ((path? path?) (listof path?) . ->* . (boolean?))]
  ))