#lang scheme/base

(require (planet chongkai/sml/ml-package)
         scheme/match
         scheme/file
         (only-in srfi/1 lset<=)
         (only-in (planet chongkai/sml/ml-primitives)
                  define-ml-datatype
                  SOME? SOME SOME-content
                  NONE? NONE
                  LESS? LESS
                  EQUAL? EQUAL
                  GREATER? GREATER)
         "OS-struct.ss"
         (for-syntax scheme/base))

(provide FileSys-struct)

(open-package OS-struct)

(define-package FileSys-struct
  (openDir readDir rewindDir closeDir chDir getDir mkDir rmDir
           isDir isLink #;readLink fullPath #;realPath
           modTime fileSize setTime remove rename
           access_mode-type
           A_READ-datatype A_READ A_READ?
           A_WRITE-datatype A_WRITE A_WRITE?
           A_EXEC-datatype A_EXEC A_EXEC?
           access tmpName fileId hash compare)
  
  (define-struct dirstream ((s #:mutable) (l #:mutable)))
  
  (define (path-exist? path)
    (or (file-exists? path)
        (link-exists? path)
        (directory-exists? path)))
  
  (define (openDir s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (make-dirstream s (directory-list s)))))
  
  (define (readDir dir)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (let ((l (dirstream-l dir)))
         (cond ((null? l)
                NONE)
               (else
                (set-dirstream-l! dir (cdr l))
                (SOME (path->string (car l)))))))))
  
  (define (rewindDir dir)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (set-dirstream-l! dir
                         (directory-list
                          (dirstream-s dir))))))
  
  (define (closeDir dir)
    (set-dirstream-s! dir #f)
    (set-dirstream-l! dir #f))
  
  (define (chDir s)
    (if (path-exist? s)
        (current-directory s)
        (raise ((SysErr (vector-immutable "path doesn't exist" NONE))
                (current-continuation-marks)))))
  (define (getDir v)
    (path->string (current-directory)))
  
  (define (mkDir s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (make-directory s))))
  
  (define (rmDir s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (delete-directory s))))
  
  (define (isDir s)
    (if (path-exist? s)
        (call-with-exception-handler
         (lambda (x)
           (if (exn:break? x)
               x
               ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
         (lambda () (directory-exists? s)))
        (raise ((SysErr (vector-immutable "path doesn't exist" NONE))
                (current-continuation-marks)))))
  
  (define (isLink s)
    (if (path-exist? s)
        (link-exists?)
        (raise ((SysErr (vector-immutable "path doesn't exist" NONE))
                (current-continuation-marks)))))
  
  ;no way to readLink in PLT
  ;(define (readLink s) ...
  
  (define (fullPath s)
    (let ((r (path->string (simplify-path (path->complete-path s)))))
      (if (path-exist? r)
          r
          (raise ((SysErr (vector-immutable "path doesn't exist" NONE))
                  (current-continuation-marks))))))
  
  ;ML type time.time, is (current-seconds) in PLT Scheme
  (define (modTime s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (file-or-directory-modify-seconds s))))
  
  (define (fileSize s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (file-size s))))
  
  (define setTime
    (match-lambda
      ((vector s (? NONE?))
       (call-with-exception-handler
        (lambda (x)
          (if (exn:break? x)
              x
              ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
        (lambda ()
          (file-or-directory-modify-seconds s (current-seconds)))))
      ((vector s (? SOME? (app SOME-content t)))
       (call-with-exception-handler
        (lambda (x)
          (if (exn:break? x)
              x
              ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
        (lambda ()
          (file-or-directory-modify-seconds s t))))))
  
  (define (remove s)
    (call-with-exception-handler
     (lambda (x)
       (if (exn:break? x)
           x
           ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
     (lambda ()
       (delete-file s))))
  
  (define rename
    (match-lambda
      ((list-no-order (list 'old old)
                      (list 'new new))
       (call-with-exception-handler
        (lambda (x)
          (if (exn:break? x)
              x
              ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
        (lambda ()
          (rename-file-or-directory old new #t))))))
  
  (define-syntax access_mode-type
    (list #'A_READ-datatype
          #'A_WRITE-datatype
          #'A_EXEC-datatype))          
  (define-ml-datatype A_READ #f)
  (define-ml-datatype A_WRITE #f)
  (define-ml-datatype A_EXEC #f)
  
  (define access_mode->symbol
    (match-lambda
      ((? A_READ?)
       'read)
      ((? A_WRITE?)
       'write)
      ((? A_EXEC?)
       'execute)))     
  
  (define access
    (match-lambda
      ((vector s accs)
       (call-with-exception-handler
        (lambda (x)
          (if (exn:break? x)
              x
              ((SysErr (vector-immutable (exn-message x) NONE)) (current-continuation-marks))))
        (lambda ()
          (if (null? accs)
              (path-exist? s)
              (lset<= eq?
                      (map access_mode->symbol accs)
                      (file-or-directory-permissions s))))))))
  
  (define (tmpName d)
    (path->string (make-temporary-file)))
  
  ;use Scheme path as ML eqtype file_id
  
  (define fileId string->path)
  
  (define hash equal-hash-code)
  
  (define compare
    (match-lambda
      ((vector fid1 fid2)
       (let ((v1 (hash fid1))
             (v2 (hash fid2)))
         (cond ((< v1 v2)
                LESS)
               ((= v1 v2)
                EQUAL)
               (else
                GREATER)))))))