(module file mzscheme
  (provide find-relative-path
	   explode-path
	   normalize-path
	   build-absolute-path
	   build-relative-path
	   filename-extension
	   file-name-from-path
	   path-only
	   delete-directory/files
	   copy-directory/files
	   make-directory*
	   make-temporary-file
	   find-library

	   get-preference
	   put-preferences

	   call-with-input-file*
	   call-with-output-file*

	   fold-files
	   find-files)

  (require "list.ss"
	   "etc.ss")

  (define build-relative-path
    (lambda (p . args)
      (if (relative-path? p)
	  (apply build-path p args)
	  (error 'build-relative-path "base path ~s is absolute" p))))

  (define build-absolute-path
    (lambda (p . args)
      (if (relative-path? p)
	  (error 'build-absolute-path "base path ~s is relative" p)
	  (apply build-path p args))))

  ;; Note that normalize-path does not normalize the case
  (define normalize-path
    (letrec ([resolve-all
	      (lambda (path wrt)
		(let ([orig-path (if (and wrt (not (complete-path? path)))
				     (path->complete-path path wrt)
				     path)])
		  (let loop ([full-path orig-path][seen-paths (list orig-path)])
		    (let ([resolved (resolve-path full-path)])
		      (if (equal? resolved full-path)
			  (do-normalize-path resolved #f)
			  (let ([path (if (relative-path? resolved)
					  (build-path
					   (let-values ([(base name dir?) (split-path full-path)])
					     base)
					   resolved)
					  resolved)])
			    (if (member path seen-paths)
				(error 'normalize-path "circular reference at ~s" path)
				(let ([spath
				       ;; Use simplify-path to get rid of ..s, which can
				       ;;  allow the path to grow indefinitely in a cycle.
				       ;; An exception must mean a cycle of links.
				       (with-handlers ([exn:fail:filesystem?
							(lambda (x)
							  (error 'normalize-path "circular reference at ~s" path))])
					 (simplify-path path))])
				  (loop spath (cons path seen-paths))))))))))]
	     [resolve
	      (lambda (path)
		(if (equal? path (resolve-path path))
		    path
		    (resolve-all path #f)))]
	     [normalize-path
	      (case-lambda 
	       [(orig-path) (do-normalize-path orig-path (current-directory))]
	       [(orig-path wrt) 
		(unless (complete-path? wrt)
		  (raise-type-error 'normalize-path "complete path" wrt))
		(do-normalize-path orig-path wrt)])]
	     [error-not-a-dir
	      (lambda (path)
		(error 'normalize-path 
		       "~s (within the input path) is not a directory or does not exist"
		       path))]
	     [do-normalize-path
	      (lambda (orig-path wrt)
		(let normalize ([path (expand-path orig-path)])
		  (let-values ([(base name dir?) (split-path path)])
		    (cond
		     [(eq? name 'up)
		      (let up ([base (if (eq? base 'relative)
					 wrt
					 (resolve-all base wrt))])
			(if (directory-exists? base)
			    (let-values ([(prev name dir?) (split-path base)])
			      (cond
			       [(not prev) 
				(error 'normalize-path
				       "root has no parent directory: ~s"
				       orig-path)]
			       [else
				(let ([prev
				       (if (eq? prev 'relative)
					   wrt
					   (normalize prev))])
				  (cond
				   [(eq? name 'same) (up prev)]
				   [(eq? name 'up) (up (up prev))]
				   [else prev]))]))
			    (error-not-a-dir base)))]
		     [(eq? name 'same)
		      (cond
		       [(eq? base 'relative) wrt]
		       [else (let ([n (normalize base)])
			       (if (directory-exists? n)
				   n
				   (error-not-a-dir n)))])]
		     [else
		      (cond
		       [(not base) (path->complete-path path)]
		       [else (let* ([base (if (eq? base 'relative)
					      (normalize wrt)
					      (normalize base))]
				    [path (if (directory-exists? base)
					      (build-path base name)
					      (error-not-a-dir base))]
				    [resolved (expand-path (resolve path))])
			       (cond
				[(relative-path? resolved)
				 (normalize (build-path base resolved))]
				[(complete-path? resolved)
				 resolved]
				[else (path->complete-path resolved base)]))])]))))])
      normalize-path))

  ;; Argument must be in normal form
  (define do-explode-path
    (lambda (who orig-path)
      (let loop ([path orig-path][rest '()])
	(let-values ([(base name dir?) (split-path path)])
	  (when (or (and base
			 (not (path? base)))
		    (not (path? name)))
	    (raise-type-error who "path in normal form" orig-path))
	  (if base
	      (loop base (cons name rest))
	      (cons name rest))))))

  (define explode-path
    (lambda (orig-path)
      (unless (path-string? orig-path)
	(raise-type-error 'explode-path "path or string" orig-path))
      (do-explode-path 'explode-path orig-path)))

  ;; Arguments must be in normal form
  (define find-relative-path
    (lambda (directory filename)
      (let ([dir (do-explode-path 'find-relative-path directory)]
	    [file (do-explode-path 'find-relative-path filename)])
	(if (equal? (car dir) (car file))
	    (let loop ([dir (cdr dir)]
		       [file (cdr file)])
	      (cond
	       [(null? dir) (if (null? file) filename (apply build-path file))]
	       [(null? file) (apply build-path (map (lambda (x) 'up) dir))]
	       [(equal? (car dir) (car file))
		(loop (cdr dir) (cdr file))]
	       [else
		(apply build-path 
		       (append (map (lambda (x) 'up) dir)
			       file))]))
	    filename))))

  (define file-name-from-path
    (lambda (name)
      (unless (path-string? name)
	(raise-type-error 'file-name-from-path "path or string" name))
      (let-values ([(base file dir?) (split-path name)])
	(if (and (not dir?) (path? file))
	    file
	    #f))))

  (define path-only
    (lambda (name)
      (unless (path-string? name)
	(raise-type-error 'path-only "path or string" name))
      (let-values ([(base file dir?) (split-path name)])
	(cond
	 [dir? name]
	 [(path? base) base]
	 [else #f]))))

  ;; name can be any string; we just look for a dot
  (define filename-extension
    (lambda (name)
      (unless (path-string? name)
	(raise-type-error 'filename-extension "path or string" name))
      (let ([name (if (path? name)
		      (path->bytes name)
		      name)])
	(let ([m (regexp-match #rx#"[.]([^.]+)$" name)])
	  (and m
	       (cadr m))))))

  (define (delete-directory/files path)
    (unless (path-string? path)
      (raise-type-error 'delete-directory/files "path or string" path))
    (cond
     [(or (link-exists? path) (file-exists? path))
      (delete-file path)]
     [(directory-exists? path)
      (for-each (lambda (e) (delete-directory/files (build-path path e)))
		(directory-list path))
      (delete-directory path)]
     [else (error 'delete-directory/files
		  "encountered ~a, neither a file nor a directory"
		  path)]))

  (define (copy-directory/files src dest)
    (cond
     [(file-exists? src)
      (copy-file src dest)]
     [(directory-exists? src)
      (make-directory dest)
      (for-each (lambda (e) (copy-directory/files (build-path src e)
						  (build-path dest e)))
		(directory-list src))]
     [else (error 'copy-directory/files
		  "encountered ~a, neither a file nor a directory"
		  src)]))

  (define (make-directory* dir)
    (let-values ([(base name dir?) (split-path dir)])
      (when (and (path? base)
		 (not (directory-exists? base)))
	(make-directory* base))
      (unless (directory-exists? dir)
        (make-directory dir))))

  (define make-temporary-file
    (case-lambda
     [(template copy-from base-dir)
      (with-handlers ([exn:fail:contract?
		       (lambda (x)
			 (raise-type-error 'make-temporary-file
					   "format string for 1 argument"
					   template))])
	(format template void))
      (unless (or (not copy-from) (path-string? copy-from))
	(raise-type-error 'make-temporary-file "path, valid-path string, or #f" copy-from))
      (unless (or (not base-dir) (path-string? base-dir))
	(raise-type-error 'make-temporary-file "path, valid-path, string, or #f" base-dir))
      (let ([tmpdir (find-system-path 'temp-dir)])
	(let loop ([s (current-seconds)][ms (current-milliseconds)])
	  (let ([name (let ([n (format template (format "~a~a" s ms))])
			(cond
			 [base-dir (build-path base-dir n)]
			 [(relative-path? n) (build-path tmpdir n)]
			 [else n]))])
	    (with-handlers ([exn:fail:filesystem:exists? (lambda (x) 
							   ;; try again with a new name
							   (loop (- s (random 10))
								 (+ ms (random 10))))])
	      (if copy-from
		  (copy-file copy-from name)
		  (close-output-port (open-output-file name)))
	      name))))]
     [(template copy-from) (make-temporary-file template copy-from #f)]
     [(template) (make-temporary-file template #f #f)]
     [() (make-temporary-file "mztmp~a" #f #f)]))
  
  (define find-library
    (case-lambda 
     [(name) (find-library name "mzlib")]
     [(name collection . cp)
      (let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
		   (apply collection-path collection cp))])
	(if dir
	    (let ([file (build-path dir name)])
	      (if (file-exists? file)
		  file
		  #f))
	    #f))]))

  (define (with-pref-params thunk)
    (parameterize ((read-case-sensitive #f)
		   (read-square-bracket-as-paren #t)
		   (read-curly-brace-as-paren #t)
		   (read-accept-box #t)
		   (read-accept-compiled #f)
		   (read-accept-bar-quote #t)
		   (read-accept-graph #t)
		   (read-decimal-as-inexact #t)
		   (read-accept-dot #t)
		   (read-accept-quasiquote #t)
		   (read-accept-reader #f)
		   (print-struct #f)
		   (print-graph #t)
		   (print-box #t)
		   (print-vector-length #t)
		   (current-readtable #f))
      (thunk)))


  (define pref-box (make-weak-box #f)) ; non-weak box => need to save
  (define (get-prefs flush? filename)
    (let ([f (and (not flush?)
		  (not filename)
		  (weak-box-value pref-box))])
      (or f
	  (let ([f (let ([v (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
			      (let ([pref-file (or filename
						   (let ([f (find-system-path 'pref-file)])
						     (if (file-exists? f)
							 ;; Using `file-exists?' means there's technically
							 ;; a race condition, but something
							 ;; has gone really wrong if the file disappears.
							 f
							 ;; Error here bails out through above `with-handlers'
							 (build-path (collection-path "defaults")
								     "plt-prefs.ss"))))])
				(with-pref-params
				 (lambda ()
				   (with-input-from-file pref-file
				     read)))))])
		     ;; Make sure file content had the right shape:
		     (if (and (list? v) 
			      (andmap (lambda (x) 
					(and (pair? x) 
					     (pair? (cdr x))
					     (null? (cddr x))))
				      v))
			 v
			 null))])
	    (unless filename
	      (set! pref-box (make-weak-box f)))
	    f))))

  (define get-preference
    (case-lambda 
     [(name fail-thunk refresh-cache? filename)
      (unless (symbol? name)
	(raise-type-error
	 'get-preference
	 "symbol"
	 name))
      (unless (and (procedure? fail-thunk)
		   (procedure-arity-includes? fail-thunk 0))
	(raise-type-error
	 'get-preference
	 "procedure (arity 0)"
	 fail-thunk))
      (let ([f (get-prefs refresh-cache? filename)])
	(let ([m (assq name f)])
	  (if m
	      (cadr m)
	      (fail-thunk))))]
     [(name fail-thunk refresh-cache?) (get-preference name fail-thunk refresh-cache? #f)]
     [(name fail-thunk) (get-preference name fail-thunk #t #f)]
     [(name) (get-preference name (lambda () #f) #t #f)]))

  (define put-preferences
    (case-lambda
     [(names vals lock-there filename)
      (unless (and (list? names)
		   (andmap symbol? names))
	(raise-type-error
	 'put-preferences
	 "list of symbols"
	 names))
      (unless (list? vals)
	(raise-type-error
	 'put-preferences
	 "list"
	 vals))
      (unless (= (length names) (length vals))
	(raise-mismatch-error
	 'put-preferences
	 (format "the size of the name list (~a) does not match the size of the value list (~a): "
		 (length names) (length vals))
	 vals))
      (let-values ([(pref-file lock-file pref-dir)
		    (let ([filename (or filename (find-system-path 'pref-file))])
		      (let-values ([(base name dir?) (split-path filename)])
			(let ([dir (if (symbol? base)
				       (current-directory)
				       base)])
			  (unless (directory-exists? dir)
			    (make-directory* dir))
			  (values filename
				  (build-path dir (bytes->path
						   (bytes-append
						    (if (eq? 'windows (system-type))
							#"_"
							#".")
						    #"LOCK"
						    (path->bytes name))))
				  dir))))])
	(with-handlers ([exn:fail:filesystem:exists?
			 (lambda (x)
			   (lock-there lock-file))])
	  ;; Grab lock:
	  (close-output-port (open-output-file lock-file 'error))
	  (dynamic-wind
	      void
	      (lambda ()
		(let ([f (get-prefs #t filename)])
		  (for-each
		   (lambda (name val)
		     (let ([m (assq name f)])
		       (if m
			   (set-car! (cdr m) val)
			   (set! f (cons (list name val) f)))))
		   names vals)
		  (unless filename
		    (set! pref-box (make-weak-box f)))
		  ;; To write the file, copy the old one to a temporary name
		  ;; (preserves permissions, etc), write to the temp file,
		  ;; then move (atomicly) the temp file to the normal name.
		  (let* ([tmp-file (make-temporary-file
				    "TMPPREF~a"
				    (and (file-exists? pref-file) pref-file)
				    pref-dir)])
		    ;; If something goes wrong, try to delete the temp file.
		    (with-handlers ([exn:fail? (lambda (exn)
						 (with-handlers ([exn:fail:filesystem? void])
						   (delete-file tmp-file))
						 (raise exn))])
		      ;; Write to temp file...
		      (with-output-to-file tmp-file
			(lambda ()
			  (with-pref-params
			   (lambda ()
			     ;; If a pref value turns out to be unreadable, raise
			     ;;  an exception instead of creating a bad pref file.
			     (parameterize ([print-unreadable #f])
			       ;; Poor man's pretty-print: one line per entry.
			       (printf "(~n")
			       (for-each (lambda (a)
					   (if (list? (cadr a))
					       (begin
						 (printf " (~s~n  (~n" (car a))
						 (for-each (lambda (i) (printf "  ~s~n" i)) (cadr a))
						 (printf "  ))~n"))
					       (printf " ~s~n" a)))
					 f)
			       (printf ")~n")))))
			'truncate/replace)
		      (rename-file-or-directory tmp-file pref-file #t)))))
	      (lambda ()
		;; Release lock:
		(delete-file lock-file)))))]
     [(names vals lock-there) 
      (put-preferences names vals lock-there #f)]
     [(names vals) 
      (put-preferences
       names vals 
       (lambda (lock-file) 
	 (error 'put-preferences
		"some other process has the preference-file lock, as indicated by the existence of the lock file: ~e"
		lock-file)))]))

  (define call-with-input-file*
    (lambda (file thunk . flags)
      (let ([p (apply open-input-file file flags)])
	(dynamic-wind
	    void
	    (lambda () (thunk p))
	    (lambda () (close-input-port p))))))	  

  (define call-with-output-file*
    (lambda (file thunk . flags)
      (let ([p (apply open-output-file file flags)])
	(dynamic-wind
	    void
	    (lambda () (thunk p))
	    (lambda () (close-output-port p))))))

  ;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
  (define fold-files
    (opt-lambda (f init [path #f] [follow-links? #t])

      ;; traverse-dir : string[directory] (listof string[file/directory]) -> (listof string[file/directory])
      (define (traverse-dir dir base acc)
	(let loop ([subs (directory-list dir)]
		   [acc acc])
	  (cond
	   [(null? subs) acc]
	   [else (loop (cdr subs)
		       (let ([path (if base
				       (build-path base (car subs))
				       (car subs))])
			 (traverse-file/dir path path acc)))])))

      ;; traverse-file/dir : string[file/directory] (listof string[file/directory]) -> (listof string[file/directory])
      (define (traverse-file/dir file/dir base acc)
	(cond
	 [(and (not follow-links?) (link-exists? file/dir))
	  (f file/dir 'link acc)]
	 [(directory-exists? file/dir)
	  (traverse-dir file/dir base (if base
					  (f file/dir 'dir acc)
					  acc))]
	 [else (f file/dir 'file acc)]))
      
      (traverse-file/dir (or path (current-directory)) 
			 path
			 init)))

  (define find-files 
    (opt-lambda (f [path #f])
      (fold-files (lambda (path kind acc)
		    (if (f path)
			(cons path acc)
			acc))
		  null
		  path))))