
(module autosave mzscheme
  (require (lib "unitsig.ss")
	   (lib "class.ss")
           (lib "file.ss")
	   "sig.ss"
	   "../gui-utils.ss"
	   (lib "mred-sig.ss" "mred")
           (lib "mred.ss" "mred") ;; remove this!
           (lib "list.ss")
           (lib "string-constant.ss" "string-constants"))

  (provide autosave@)
  
  (define autosave@
    (unit/sig framework:autosave^
      (import mred^
	      [exit : framework:exit^]
	      [preferences : framework:preferences^]
              [frame : framework:frame^]
              [scheme : framework:scheme^]
              [editor : framework:editor^]
              [text : framework:text^]
              [finder : framework:finder^]
              [group : framework:group^])
      
      (define autosavable<%>
	(interface ()
	  do-autosave))

      (define objects null)
      
      (define autosave-toc-filename
        (build-path (find-system-path 'pref-dir)
                    (case (system-type)
                      [(unix) ".plt-autosave-toc"]
                      [else "PLT-autosave-toc"])))
      
      (define autosave-toc-save-filename
        (build-path (find-system-path 'pref-dir)
                    (case (system-type)
                      [(unix) ".plt-autosave-toc-save"]
                      [else "PLT-autosave-toc-save"])))

      (define autosave-timer%
	(class timer%
	  (inherit start)
          (field [last-name-mapping #f])
	  (define/override (notify)
            (when (preferences:get 'framework:autosaving-on?)
              (let-values ([(new-objects new-name-mapping) (rebuild-object-list)])
                (set! objects new-objects)
                (unless (equal? last-name-mapping new-name-mapping)
                  (set! last-name-mapping new-name-mapping)
                  (when (file-exists? autosave-toc-save-filename)
                    (delete-file autosave-toc-save-filename))
                  (when (file-exists? autosave-toc-filename)
                    (copy-file autosave-toc-filename autosave-toc-save-filename))
                  (call-with-output-file autosave-toc-filename
                    (λ (port)
                      (write new-name-mapping port))
                    'truncate
                    'text))))
            (let ([seconds (preferences:get 'framework:autosave-delay)])
              (start (* 1000 seconds) #t)))
          (super-new)
          (let ([seconds (preferences:get 'framework:autosave-delay)])
            (start (* 1000 seconds) #t))))

      ;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>)))
      ;;                                  (listof (list (union #f string[filename]) string[filename]))
      (define (rebuild-object-list)
        (let loop ([orig-objects objects]
                   [name-mapping null]
                   [new-objects null])
          (if (null? orig-objects)
              (values new-objects name-mapping)
              (let* ([object-wb (car orig-objects)]
                     [object (weak-box-value object-wb)])
                (if object
                    (let* ([new-filename (send object do-autosave)]
                           [tmp-box (box #f)]
                           [filename (send object get-filename tmp-box)])
                      (loop (cdr orig-objects)
                            (if new-filename
                                (cons (list (and (not (unbox tmp-box)) filename)
                                            new-filename)
                                      name-mapping)
                                name-mapping)
                            (cons object-wb new-objects)))
                    (loop (cdr orig-objects)
                          name-mapping
                          new-objects))))))
      
      (define timer #f)

      (define (register b)
        (unless timer
          (set! timer (make-object autosave-timer%)))
        (set! objects
              (let loop ([objects objects])
                (cond
                  [(null? objects) (list (make-weak-box b))]
                  [else (let ([weak-box (car objects)])
                          (if (weak-box-value weak-box)
                              (cons weak-box (loop (cdr objects)))
                              (loop (cdr objects))))]))))
      
      ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>))
      ;; opens a frame that lists the autosave files that have changed.
      (define (restore-autosave-files/gui)

        ;; main : -> void
        ;; start everything going
        (define (main)
          (when (file-exists? autosave-toc-filename)
	    ;; Load table from file, and check that the file was not corrupted
            (let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)])
				     (call-with-input-file autosave-toc-filename read))]
				[path? (λ (x)
					 (and (string? x)
					      (absolute-path? x)))])
			    (if (and (list? v)
				     (andmap (λ (i)
					       (and (list? i) 
						    (= 2 (length i))
						    (or (not (car i))
							(path? (car i)))
						    (path? (cadr i))))
					     v))
				v
				null))]
                   ;; assume that the autosave file was deleted due to the file being saved
                   [filtered-table
                    (filter (λ (x) (file-exists? (cadr x))) table)])
              (unless (null? filtered-table)
                (let* ([f (new final-frame%
                               (label (string-constant recover-autosave-files-frame-title)))]
                       [t (new text% (auto-wrap #t))]
                       [ec (new editor-canvas%
                             (parent (send f get-area-container))
                             (editor t)
                             (line-count 2)
                             (style '(no-hscroll)))]
                       [hp (make-object horizontal-panel% (send f get-area-container))]
                       [vp (make-object vertical-panel% hp)])
		  (send vp set-alignment 'right 'center)
                  (make-object grow-box-spacer-pane% hp)
                  (send t insert (string-constant autosave-explanation))
                  (send t hide-caret #t)
                  (send t set-position 0 0)
                  (send t lock #t)
                  
                  (for-each (add-table-line vp f) filtered-table)
		  (make-object button%
		    (string-constant autosave-done)
		    vp
		    (λ (x y)
		      (when (send f can-close?)
			(send f on-close)
			(send f show #f))))
                  (send f show #t)
                  (yield done-semaphore)
                  (void))))))
        
        (define done-semaphore (make-semaphore 0))
        
        (define final-frame%
          (class frame:basic%
            (define/augment (can-close?) #t)
            (define/augment (on-close)
              (inner (void) on-close)
              (send (group:get-the-frame-group)
                    remove-frame
                    this)
              (semaphore-post done-semaphore))
            (super-new)))
        
        ;; add-table-line : (is-a? area-container<%>)  (union #f (is-a?/c top-level-window<%>))
        ;;               -> (list (union #f string[filename]) string[filename-file-exists?])
        ;;               -> void
        ;; adds in a line to the overview table showing this pair of files.
        (define (add-table-line area-container parent)
          (λ (table-entry)
            (letrec ([orig-file (car table-entry)]
		     [backup-file (cadr table-entry)]
		     [hp (new horizontal-panel%
			   (parent area-container)
			   (style '(border))
			   (stretchable-height #f))]
		     [vp (new vertical-panel%
			   (parent hp))]
		     [msg1-panel (new horizontal-panel%
				   (parent vp))]
		     [msg1-label (new message%
				   (parent msg1-panel)
				   (label (string-constant autosave-original-label:)))]
		     [msg1 (new message%
			     (label (or orig-file (string-constant autosave-unknown-filename)))
			     (stretchable-width #t)
			     (parent msg1-panel))]
		     [msg2-panel (new horizontal-panel%
				   (parent vp))]
		     [msg2-label (new message%
				   (parent msg2-panel)
				   (label (string-constant autosave-autosave-label:)))]
		     [msg2 (new message%
			     (label backup-file)
			     (stretchable-width #t)
			     (parent msg2-panel))]
		     [details
		      (make-object button% (string-constant autosave-details) hp
				   (λ (x y)
				     (show-files table-entry)))]
		     [delete
		      (make-object button%
			(string-constant autosave-delete-button)
			hp
			(λ (delete y)
			  (when (delete-autosave table-entry)
			    (disable-line)
			    (send msg2 set-label (string-constant autosave-deleted)))))]
		     [recover
		      (make-object button%
			(string-constant autosave-recover)
			hp
			(λ (recover y)
			  (let ([filename-result (recover-file parent table-entry)])
			    (when filename-result
			      (disable-line)
			      (send msg2 set-label (string-constant autosave-recovered!))
			      (send msg1 set-label filename-result)))))]
		     [disable-line
		      (λ ()
			(send recover enable #f)
			(send details enable #f)
			(send delete enable #f))])
              (let ([w (max (send msg1-label get-width) (send msg2-label get-width))])
                (send msg1-label min-width w)
                (send msg2-label min-width w))
              (void))))
        
	;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean
	;; result indicates if delete occurred
	(define (delete-autosave table-entry)
	  (let ([autosave-file (cadr table-entry)])
	    (and (gui-utils:get-choice
		  (format (string-constant are-you-sure-delete?)
			  autosave-file)
		  (string-constant autosave-delete-title)
		  (string-constant cancel)
		  (string-constant warning)
		  #f)
		 (with-handlers ([exn:fail?
				  (λ (exn)
				    (message-box
				     (string-constant warning)
				     (format (string-constant autosave-error-deleting)
					     autosave-file
					     (if (exn? exn)
						 (format "~a" (exn-message exn))
						 (format "~s" exn))))
				    #f)])
		   (delete-file autosave-file)
		   #t))))

        ;; show-files : (list (union #f string[filename]) string) -> void
        (define (show-files table-entry)
          (let ([file1 (car table-entry)]
                [file2 (cadr table-entry)])
            (define frame (make-object show-files-frame% 
                            (if file1
                                (string-constant autosave-compare-files)
                                (string-constant autosave-show-autosave))
                            #f
                            (if file1 600 300)
                            600))
            (define hp (new horizontal-panel%
                         (parent (send frame get-area-container))))
            (when file1
              (add-file-viewer file1 hp (string-constant autosave-original-label)))
            (add-file-viewer file2 hp (string-constant autosave-autosave-label))
            (send frame show #t)))
        
        ;; add-file-viewer : string[filename] -> void
        (define (add-file-viewer filename parent label)
          (define vp (make-object vertical-panel% parent))
          (define t (make-object show-files-text%))
          (define msg1 (make-object message% label vp))
          (define msg2 (make-object message% filename vp))
          (define ec (make-object editor-canvas% vp t))
          (send t load-file filename)
          (send t hide-caret #t)
          (send t lock #t))
        
        (define show-files-frame% frame:basic%)
        (define show-files-text% text:keymap%)
        
        (main))
        
      ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) 
      ;;                (list (union #f string[filename]) string)
      ;;             -> (union #f string)
      (define (recover-file parent table-entry)
        (let ([orig-name (or (car table-entry)
                             (parameterize ([finder:dialog-parent-parameter parent])
                               (finder:put-file #f #f #f
						(string-constant autosave-restore-to-where?))))])
          (and orig-name
               (let ([autosave-name (cadr table-entry)])
                 (let ([tmp-name (and (file-exists? orig-name)
                                      (make-temporary-file "autosave-repair~a" orig-name))])
                   (when (file-exists? orig-name)
                     (delete-file orig-name))
                   (copy-file autosave-name orig-name)
                   (delete-file autosave-name)
                   (when tmp-name
                     (delete-file tmp-name))
                   orig-name))))))))
