#lang scheme/base

(require (lib "pretty.ss")
         (lib "match.ss")
         (lib "process.ss") ;; system
         )
(provide
 read-byte-timeout
 with-output-to-file/safe
 with-output-to-string
 write-tree
 file-in-path
 resolve-path-list
 )


;; GENERIC PORT IO

;; TODO: abstract this in a 'lazy-open' library.

;; False if timeout. Input ports are synchronizable events in plt
;; scheme. This predicate guarantees read-byte will not block.
(define (port-ready? timeout port)
  (sync/timeout timeout port))


;; Read a byte from port with timeout in seconds.
(define (read-byte-timeout port timeout)
  (let again ()
    (if (port-ready? timeout port)
        (read-byte port)
        (begin
          (error 'time-out "~a" timeout)
          ))))

;; Darcs-friendly saving of data file. Using the pretty printer
;; seems to be friendly enough.
(define (write-tree . args)
  (apply pretty-print args))


;; Lookup a file in a search path.
(define (file-in-path path filename)
  (let next ((p path))
    (if (null? p)
        (error 'file-not-in-path "~a ~a" filename path)
        (let ((full (format "~a/~a" (car p) filename)))
          (if (file-exists? full)
              full
              (next (cdr p)))))))

;; Remove a file if it exists.
(define (delete-if-exists file)
  (when (file-exists? file) (delete-file file)))

;; Save to a file, but do it safely. 
(define (with-output-to-file/safe file thunk)
  (let ((file.bak (string-append file "~"))
        (file.tmp (string-append file ".bak")))

    ;; In case thunk fails, first write to a temp file.
    (delete-if-exists    file.tmp)
    (let ((value
           (with-output-to-file
               file.tmp thunk)))

      ;; Cycle backups.
      (delete-if-exists    file.bak)
      (when (file-exists? file)
        (rename-file-or-directory file file.bak))
      (rename-file-or-directory file.tmp file)

      value)))


(define (with-output-to-string thunk)
  (let ((p (open-output-string)))
    (parameterize ((current-output-port p)) (thunk))
    (close-output-port p)
    (get-output-string p)))


;; By default use the abs-file path (which is constructed using
;; load-relative). If that doesn't exist, find the rel-file in the
;; search path.
(define (resolve-path-list rel-file path-list)
  (if (file-exists? rel-file)
   rel-file 
   (let next ((lst path-list))
     (if (null? lst)
      (error 'file-not-found "~a" rel-file)
      (let ((file (build-path (car lst) rel-file)))
        ;; (printf "path: ~a\n" file)
        (if (file-exists? file) file
            (next (cdr lst))))))))