(module
 ugarit-vfs
 (                                      ; TODO: These two will be useful in future
                                        ;verify-directory!
                                        ;verify-object!

  fold-history** ;; exposed for unit testing
  fold-history   ;; exposed for unit testing

  fold-vault-node
  traverse-vault-node
  traverse-vault-path

  archive-entry->dirent)

 (import scheme)
 (import chicken)
 (use ugarit-core)
 (use ugarit-streams)
 (use ugarit-files)
 (use ugarit-snapshot)
 (use ugarit-archive)
 (use srfi-1)
 (use data-structures)
 (use matchable)
 (use miscmacros)
 (use extras)
 (use ports)
 (use posix)

 (define-record-type thread
   (make-thread key props suffix)
   thread?
   (key thread-key)
   (props thread-props) ; props of CURRENT key, cached
   (suffix thread-suffix (setter thread-suffix)))

 (define-record-printer (thread t out)
   (fprintf out "#<thread ~S ~S ~S>"
            (thread-key t)
            (thread-suffix t)
            (thread-props t)))

 (define (get-mtime props)
   (let ((mtime (assq 'mtime props)))
     (if mtime
         (cdr mtime)
         0)))

 (define (get-name props thread make-new-suffix!)
   (string-append
    (epochtime->string (get-mtime props))
    (thread-suffix thread)))

 (define get-sortkey get-mtime)

 (define (choose-next-thread* threads best-so-far)
   (cond
    ((null? threads) best-so-far)
    ((> (get-sortkey (thread-props (car threads)))
        (get-sortkey (thread-props best-so-far)))
     (choose-next-thread* (cdr threads) (car threads)))
    (else
     (choose-next-thread* (cdr threads) best-so-far))))

 (define (choose-next-thread threads)
   (if (pair? threads)
    (choose-next-thread* (cdr threads) (car threads))
    #f))

 (define (merge-thread threads new-thread)
   (cond
    ((null? threads)
     (list new-thread))

    ((equal? (thread-key (car threads))
             (thread-key new-thread))
     (cons
      (make-thread
       (thread-key new-thread)
       (thread-props new-thread)
       #f)
      (cdr threads)))

    (else
     (cons
      (car threads)
      (merge-thread (cdr threads)
                     new-thread)))))

 (define (merge-threads old-threads new-threads)
   (cond
    ((null? new-threads)
     old-threads)
    (else
     (let ((merged-one
            (merge-thread old-threads (car new-threads))))

       (merge-threads
        merged-one
        (cdr new-threads))))))

 ;; A history is a DAG, where each node has properties and a list of parents.
 ;; The properties contain an mtime, which the nodes must be ordered by
 ;; when we "linearize" the graph by folding over it.
 ;; We do this by running a kind of merge algorithm over one or more
 ;; parallel "threads" we are exploring through the DAG, picking the latest
 ;; node at the head of a thread, and replacing that node with its parent(s).
 ;; When we encounter forks in the history chain, we end up with the parent of
 ;; a node we replace already being at the head of another thread - so we
 ;; merge them and make a new thread out of the two of them.
 (define (fold-history* get-parents get-props
                        threads kons knil make-new-suffix!)

   #|find next thread to advance and place it in "t"
      and update threads into "new-threads".

      "update threads" involves removing the next thread
      and replacing it with its parent(s), and then merging any
      duplications caused by that... |#

      (let ((t (choose-next-thread threads)))
        (if
         (not t)
         knil ;; No threads left, so finish.
         (begin
           ;; Not got a suffix yet? Assign one in time
           ;; for it to be output, and for the suffix to
           ;; be passed on to its parents!
           (unless (thread-suffix t)
                   (set! (thread-suffix t) (make-new-suffix!)))

           (let* ((other-threads (delete! t threads))
                 (parent-keys (get-parents (thread-key t)))
                 (t-parents
                  (if (>= (length parent-keys) 2)
                      ;; 2 or more parents, give suffixes
                      (map
                       (lambda (parent-key)
                         (make-thread parent-key
                                      (get-props parent-key)
                                      #f))
                       parent-keys)
                      ;; 0 or 1 parents, no need for new suffixes;
                      ;; inherit from t.
                      (map
                       (lambda (parent-key)
                         (make-thread parent-key
                                      (get-props parent-key)
                                      (thread-suffix t)))
                       parent-keys)))

                 (new-threads (merge-threads
                               other-threads
                               t-parents)))

             (when (= 1 (length new-threads))
                   ;; Down to a single thread?
                   ;; No need for a suffix any more...
                   (set! (thread-suffix (car new-threads)) ""))

             (let ((next-knil
                   (kons (thread-key t)
                         (get-name (thread-props t) t make-new-suffix!)
                         (thread-props t)
                         knil)))
              (fold-history* get-parents get-props
                             new-threads
                             kons next-knil make-new-suffix!)))))))

(define (fold-history** get-parents get-props
                        root kons knil)
  (let ((*suffix-counter* 0))
   (fold-history* get-parents get-props
                  (list (make-thread root (get-props root) ""))
                  kons knil
                  (lambda ()
                    (inc! *suffix-counter*)
                    (sprintf "-~a" *suffix-counter*)))))

 (define (fold-history vault tag-name key type kons knil)
   (receive
    (update! get-parents get-props)
    (case type
      ((snapshot) (values update-snapshot-cache-for-tag!
                          (lambda (key)
                            (get-snapshot-parents vault tag-name key))
                          (lambda (key)
                            (get-snapshot-props vault tag-name key))))
      ((archive) (values update-archive-cache-for-tag!
                         (lambda (key)
                           (get-import-parents vault tag-name key))
                         (lambda (key)
                           (get-import-props vault tag-name key))))
      (else
       (error 'fold-history "Unknown history type" type)))

    (update! vault tag-name)

    (fold-history** get-parents get-props
                    key
                    kons knil)))

 ;; BRING IT ALL TOGETHER

(define (make-archive-object-name object-key object-props)
  (string-append
   object-key
   ":"
   (let* ((ae (make-archive-entry object-key #t object-props))
          (filenames (archive-entry-property ae 'filename))
          (names (archive-entry-property ae 'dc:title)))
     (cond
      ((not (null? filenames))
       (car filenames))
      ((not (null? names))
       (string-append (car names) (archive-entry-guessed-extension ae)))
      (else
       (archive-entry-guessed-extension ae))))))

 (define (archive-details->dirent type key props)
   (case type
     ((f fi) (make-dirent #f
                          (make-archive-object-name
                           key props)
                          'file
                          (cons
                           (cons 'contents key)
                           (cons
                            (cons 'mode
                                  perm/irusr)
                            props))))
     ((d di) (make-dirent key
                          (make-archive-object-name
                           key props)
                          'dir
                          (cons
                           (cons 'mode (+ perm/irusr perm/ixusr))
                           props)))
     (else (error 'archive-entry->dirent
                  "Unknown object type ~a" type))))

 (define (archive-entry->dirent vault ae)
   (archive-details->dirent
    (vault-exists? vault (archive-entry-key ae))
    (archive-entry-key ae)
    (archive-entry-alist ae)))

(define (make-inline-dirent name sexpr)
      (make-dirent
       #f
       name
       'inline
       `((text . ,(with-output-to-string
                    (lambda () (pp sexpr))))
         (mode . ,perm/irusr))))

(define (make-log-dirent log)
  (if (string? log)
      (make-dirent
       #f
       "log.sexpr"
       'file
       `((contents . ,log)
         (mode . ,perm/irusr)))
      (make-inline-dirent "log.sexpr" log)))

(define (make-props-dirent props)
  (make-inline-dirent "properties.sexpr" props))

(define (fold-vault-block-node vault directory-key kons knil)
  (let ((type (vault-exists? vault directory-key)))
    (case type
      ((snapshot) ; List snapshot contents
       (let* ((snapshot (read-sexpr vault directory-key 'snapshot))
              (contents-key (cdr (assq 'contents snapshot))))
         (kons (make-dirent
                contents-key
                "contents"
                'dir
                snapshot)
               (kons
                (make-props-dirent snapshot)
                (let ((log (assq 'log snapshot)))
                  (if log
                      (kons
                       (make-log-dirent (cdr log))
                       knil)
                      knil))))))
      ((archive) ; List import contents
       (let* ((import (read-sexpr vault directory-key 'archive))
              (contents-key (cdr (assq 'contents import))))
         (kons (make-dirent
                contents-key
                "manifest"
                'import-manifest
                import)
               (kons
                (make-props-dirent import)
                (let ((log (assq 'log import)))
                  (if log
                      (kons
                       (make-log-dirent (cdr log))
                       knil)
                      knil))))))

      ((a ai)
       (fold-sexpr-stream vault directory-key 'a 'ai
                          (lambda (entry-sexpr acc)
                            (let* ((object-key (car entry-sexpr))
                                   (object-props (cdr entry-sexpr))
                                   (block-type (vault-exists? vault object-key)))
                              (kons
                               (archive-details->dirent
                                block-type object-key object-props)
                               acc)))
                          knil)
       )
      ((d di)                              ; List directory contents
       (fold-sexpr-stream vault directory-key 'd 'di
                          (lambda (dirent-sexpr acc)
                            (kons (make-dirent-from-sexpr dirent-sexpr) acc))
                          knil))
      ((#f)
       (signal (make-property-condition
                'exn
                'location 'fold-vault-node
                'key directory-key
                'message (sprintf
                          "Could not examine the node with key ~S as it does not exist" directory-key))))
      (else
       (signal (make-property-condition
                'exn
                'location 'fold-vault-node
                'key directory-key
                'message (sprintf
                          "Could not examine the node with key ~S of type ~A" directory-key type)))))))

(define (fold-vault-tag-node vault directory-key current current-contents kons knil)
  (case (tag-type current)
    ((snapshot)
     (fold-history vault (tag-name current) (tag-key current) 'snapshot
                   (lambda (key name snapshot acc)
                     (kons
                      (make-dirent
                       key
                       name
                       'snapshot
                       snapshot)
                      acc))
                   (kons
                    (make-dirent (tag-key current) "current" 'snapshot current-contents)
                    knil)))

    ((archive)
     (kons
      (make-dirent `(archive-history . ,(tag-name current))
                   "history"
                   'archive-history
                   '())
      ;; TODO [9c3ac71f94]: Add property explorer
      ;; TODO [fff691ada2]: Add custom views
      knil))

    (else
       (signal (make-property-condition
                'exn
                'location 'fold-vault-node
                'key directory-key
                'message (sprintf
                          "Could not examine tag ~A of type ~A" directory-key (tag-type current)))))))

(define (fold-vault-archive-history vault directory-key current current-contents kons knil)
  (case (tag-type current)
    ((archive)
     (fold-history vault (tag-name current) (tag-key current) 'archive
                   (lambda (key name import acc)
                     (kons
                      (make-dirent
                       key
                       name
                       'import
                       import)
                      acc))
                   knil))

    (else
       (signal (make-property-condition
                'exn
                'location 'fold-vault-node
                'key directory-key
                'message (sprintf
                          "Could not examine tag ~A of type ~A" directory-key (tag-type current)))))))

;; If given '() as the directory-key, makes a list of all tags
;; If given '(tag . "tag-name"), shows contents of that tag
;; If given '(archive-history . "tag-name"), make a list of imports of that tag
;; If given a key, if that key points to a snapshot, return a directory listing the root.
;; If given a key, if that key points to a directory, makes a list of the contents of that directory
;; Either way, the list of results are folded into the provided kons and knil functions
;; kons is called with two arguments: a dirent object, and the accumulator.
 (define (fold-vault-node vault directory-key kons knil)
   (cond
    ((null? directory-key)
     ;; Root node: List tags
     ;; IDEA: Add vault configuration as a properties.sexpr?
     (fold (lambda (tag acc)
             (kons
              (let ((tag-body (vault-tag vault tag)))
                  (make-dirent
                   (cons 'tag tag)
                   tag
                   'tag
                   (list
                    (cons 'current (tag-key tag-body))
                    (cons 'type (tag-type tag-body))
                    (cons 'locked (vault-tag-locked? vault tag)))))
              acc))
           knil (vault-all-tags vault)))

    ((and (pair? directory-key) (eq? (car directory-key) 'tag))
     ;; List a tag's contents
     (let* ((tag (cdr directory-key))
            (current (vault-tag vault tag))
            (current-contents (read-sexpr vault (tag-key current) (tag-type current))))
       (fold-vault-tag-node vault directory-key current current-contents kons knil)))

    ((and (pair? directory-key) (eq? (car directory-key) 'archive-history))
     ;; List an archive tag's history
     (let* ((tag (cdr directory-key))
            (current (vault-tag vault tag))
            (current-contents (read-sexpr vault (tag-key current) (tag-type current))))
       (fold-vault-archive-history vault directory-key current current-contents kons knil)))

    ((string? directory-key)
     (fold-vault-block-node vault directory-key kons knil))

    (else
     (signal (make-property-condition
              'exn
              'location 'fold-vault-node
              'key directory-key
              'message (sprintf
                        "Could not examine the node with identifier ~S" directory-key))))))

; Returns  the fold-vault-node directory entry  corresponding to  the
; given name, as a dirent object.
; Returns #f if the name cannot be found.
(define (traverse-vault-node vault directory-key name)
  (let/cc return
          (fold-vault-node vault directory-key
                           (lambda (dirent acc)
                             (if (string=? (dirent-name dirent) name)
                                 (return dirent)
                                 acc))
                           #f)))


; Traverses a path (given as a list of strings) in a vault.
; Returns a dirent on success, but raises a signal on failure.
(define (traverse-vault-path vault path #!optional (root-path '()))
  (match path
         (()
          (if (null? root-path)
              (make-dirent '() "/" 'root '())
              (car root-path)))

         (("." . rest)
          (traverse-vault-path vault rest root-path))

         ((".." . rest)
          (if (null? root-path)
              (signal (make-property-condition
                       'exn
                       'location 'traverse-vault-path
                       'message "You can't go up from the root!"))
              (traverse-vault-path vault rest (cdr root-path))))

         ((name . rest)
          (let ((dirent (traverse-vault-node
                         vault
                         (if (null? root-path) '() (dirent-subnode-key (car root-path)))
                         name)))
            (if dirent
             (traverse-vault-path vault rest (cons dirent root-path))
                           (signal (make-property-condition
                       'exn
                       'location 'traverse-vault-path
                       'message (sprintf  "Object not found: ~A" name))))))))


)