;;;; vfs.scm
(module vfs
  (export vfs:current-file-system <vfs:file-system> vfs:handle-operation vfs:open-file
	  vfs:open-input-file
	  vfs:open-output-file vfs:file-exists? vfs:rename-file vfs:delete-file
	  vfs:register-file-system vfs:unregister-file-system
	  <vfs:local-file-system>)


  (import scheme chicken data-structures)
  (use tinyclos srfi-1 regex-case)


  ;;; Global hooks and parameters.

  (declare (hide resolve-prefix))

  (define vfs:current-file-system (make-parameter #f))

  (define vfs:handle-operation (make-generic "vfs:handle-operation"))
  (define vfs:open-file (make-generic "vfs:open-file"))
  (define vfs:open-input-file (make-generic "vfs:open-input-file"))
  (define vfs:open-output-file (make-generic "vfs:open-output-file"))
  (define vfs:file-exists? (make-generic "vfs:file-exists?"))
  (define vfs:rename-file (make-generic "vfs:rename-file"))
  (define vfs:delete-file (make-generic "vfs:delete-file"))

  (set! ##sys#pathname-resolution
	(lambda (name thunk #!optional op #!rest args)
	  (let-values (((prefix path fs) (resolve-prefix name)))
	    (vfs:handle-operation fs op thunk prefix name args) ) ) )

  (define resolve-prefix
    (let ((cfs vfs:current-file-system))
      (lambda (name)
	(regex-case name
		    ("([^:]+)://(.*)" (_ scheme path)
		     (values scheme path 
			     (or (alist-ref scheme *file-systems* string-ci=?)
				 (error "unknown file-system scheme" scheme name) ) ) )
		    (else (values #f name (cfs))) ) ) ) )


  ;;; General file-system superclass.

  (define-class <vfs:file-system> () ())

  (define-method (vfs:handle-operation (fs <vfs:file-system>) op thunk prefix path args)
    (case op
      ((open:) (apply vfs:open-file fs path args))
      ((exists?:) (apply vfs:file-exists? fs path args))
      ((delete:) (apply vfs:delete-file fs path args))
      ((rename:)
       (let-values (((tprefix tpath tfs) (resolve-prefix (car args))))
	 (cond ((not (instance-of? tfs <vfs:file-system>))
		(error 'rename-file "bad argument type - not a file system" tfs))
	       ((not (eq? fs tfs))
		(error 
		 'rename-file 
		 "can not rename file between different file systems" fs tfs path) )
	       (else (vfs:rename-file fs path tpath)) ) ) )
      (else (error "invalid file operation" fs op path args))))

  (define-method (vfs:open-file (fs <vfs:file-system>) name output? modes)
    ;; modes: binary: text: append:
    ((if output? vfs:open-output-file vfs:open-input-file) fs name modes) )

  (define-method (vfs:open-input-file (fs <vfs:file-system>) name modes)
    (error 'vfs:open-input-file "method not implemented" fs) )
  
  (define-method (vfs:open-output-file (fs <vfs:file-system>) name modes)
    (error 'vfs:open-output-file "method not implemented" fs) )
  
  (define-method (vfs:file-exists? (fs <vfs:file-system>) name)
    (error 'vfs:file-exists? "method not implemented" fs) )

  (define-method (vfs:delete-file (fs <vfs:file-system>) name)
    (error 'vfs:delete-file "method not implemented" fs) )

  (define-method (vfs:rename-file (fs <vfs:file-system>) old new)
    (error 'vfs:rename-file "method not implemented" old new) )


;;; URI-Schemes.

  (declare (hide *file-systems*))

  (define *file-systems* '())

  (define (vfs:register-file-system name fs)
    (set! *file-systems*
	  (alist-update! 
	   (->string name)
	   (ensure (cut instance-of? <> <vfs:file-system>) fs) 
	   *file-systems* string-ci=?)) )

  (define (vfs:unregister-file-system name)
    (let ((nameci (->string name)))
      (set! *file-systems*
	    (remove (lambda (a) (string-ci=? (car a) nameci))
		    *file-systems*) ) ) )


  ;;; Local file sytem (default).

  (declare (hide local-file-op))

  (define-class <vfs:local-file-system> (<vfs:file-system>) ())

  (define (local-file-op name thunk)
    (thunk (##sys#expand-home-path name)) )

  (define-method (vfs:handle-operation (fs <vfs:local-file-system>) op thunk prefix path args)
    (local-file-op path thunk) )

  (vfs:current-file-system (make <vfs:local-file-system>))

)