path.ss
#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE.plt - file, path, and atomic file operation utilities 
;;
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; path.ss - path helpers for simplifying path manipulation
;; yc 9/21/2009 - first version
(require "depend.ss")

(define (normalize-segments segs)
  (define (segment-helper segment rest acc)
    (define (normalize segs acc)
      (cond ((null? segs) 
             (helper rest acc))
            ((equal? (car segs) "")
             (normalize (cdr segs) acc))
            ((equal? (car segs) ".")
             (normalize (cdr segs) acc))
            ((equal? (car segs) "..")
             (normalize (cdr segs) (up-helper acc)))
            (else
             (normalize (cdr segs) (cons (car segs) acc)))))
    (normalize (regexp-split #px"\\/" segment) acc))
  (define (up-helper acc)
    (if (null? acc) (cons 'up acc) (cdr acc)))
  (define (helper rest acc)
    (cond ((null? rest) 
           (reverse acc))
          ((equal? (car rest) 'up)
           (helper (cdr rest) (up-helper acc)))
          ((equal? (car rest) 'same)
           (helper (cdr rest) acc))
          (else ;; this is a string...
           (segment-helper (car rest) (cdr rest) acc))))
  (helper (map (lambda (seg) 
                 (if (path? seg)
                     (path->string seg)
                     seg)) 
               segs) 
          '()))

(define (build-path/s path rest)
  (simplify-path (apply build-path path (normalize-segments rest)) #f))

(define (build-path* path . rest) 
  (build-path/s path rest)) 

(define (relative-abs-path base path) 
  (string-append "/"
                 (regexp-replace* #px"\\\\" (path->string (find-relative-path base path)) "/")))
                 

(define (parent-path (path (current-directory)) . rest)
  (build-path/s path (cons 'up rest)))

(define (ensure-parent-path-exists! path)
  (let ((parent (parent-path path)))
    (cond ((file-exists? parent) 
           (error 'path-exists "path ~a is a file instead of a directory" parent))
          (else
           (make-directory* (parent-path path))
           path))))

(define (this-path . rest)
  (build-path/s (current-directory) rest))

(define (temp-path . rest)
  (build-path/s (find-system-path 'temp-dir) rest))

(define (home-path . rest) 
  (build-path/s (find-system-path 'home-dir) rest))

(define (pref-path . rest)
  (build-path/s (find-system-path 'pref-dir) rest))

(define (doc-path . rest)
  (build-path/s (find-system-path 'doc-dir) rest))

(define (desktop-path . rest)
  (build-path/s (find-system-path 'desk-dir) rest))

(define (sys-path . rest)
  (build-path/s (find-system-path 'sys-dir) rest))

(define (exe-path exe)
  (find-executable-path (+:windows (string-append exe ".exe") exe)))

(define path*-proc/c (->* () 
                          ()
                          #:rest (listof path-string?)
                          path-string?))

(provide/contract 
 (build-path* (->* (path-string?)
                   ()
                   #:rest (listof path-string?)
                   path-string?))
 (parent-path (->* () 
                   (path-string?) 
                   #:rest (listof path-string?)
                   path-string?))
 (ensure-parent-path-exists! (-> path-string? path-string?))
 (relative-abs-path (-> path-string? path-string? path-string?))
 (this-path path*-proc/c)
 (temp-path path*-proc/c)
 (home-path path*-proc/c)
 (pref-path path*-proc/c)
 (doc-path path*-proc/c)
 (desktop-path path*-proc/c)
 (sys-path path*-proc/c)
 (exe-path (-> string? (or/c false/c path-string?)))
 )