#lang scheme/base
(require drscheme/tool
         mred
         mrlib/switchable-button
         mrlib/path-dialog
         mzlib/unit
         scheme/path
         scheme/class)
(provide tool@)
(define tool@
  (unit
    (import drscheme:tool^)
    (export drscheme:tool-exports^)
    (define (phase1) (void))
    (define (phase2) (void))
    
    (define project-icon "project.png")
    (define project-icon-sm "project-sm.png")
    (define home-dir (find-system-path 'home-dir))
    (define saved-tabs-file (string->path "saved-tabs-file.sp"))
    (define saved-tabs-file-path (build-path home-dir saved-tabs-file))
    
    (define (projects-unit-frame-mixin super%)
      (class super%
        (inherit get-button-panel)
                
        ;; resolve-save-rel : list-of-tab-files-abs-paths save-location-file-abs-path -> list-of-relative-tab-files
        ;; take the chosen location and transform the tab-paths into relative paths (must be strings)
        (define (resolve-save-rel list-of-tab-file-abs-paths save-location-file-abs-path)
          (let ((base (get-base-path save-location-file-abs-path)))
            (map (lambda (tab-file-abs-path)
                   (path->string (find-relative-path base (simple-form-path tab-file-abs-path))))
                 list-of-tab-file-abs-paths)))
        
        ;; resolve-load-rel : save-location-file list-of-relative-tab-file-str -> list-of-tab-files-abs-paths
        ;; read relative-paths supplied from the location file and return absolute paths
        (define (resolve-load-rel save-location-file list-of-relative-tab-file-str)
          (let ((base (get-base-path save-location-file)))
            (map (lambda (relative-tab-file-str)
                   (build-path base (string->path relative-tab-file-str)))
                 list-of-relative-tab-file-str)))
        
        ;; get-save-location :  suggested-starting-path -> selected-dir-pathname
        ;; must [put? #t] warn if file exists
        (define (get-save-location suggested-starting-path)
          (send (new path-dialog% [directory suggested-starting-path]
                     [put? #t] 
                     [filename "saved-tabs-file.sp"]
                     [label "Save current tabs to.."]
                     [message "Save a tabs file"]
                     [filters (list (list "Scheme Project Files" "*.sp")
                                    (list "Any" "*.*"))]
                     )
                run))
        ;; get-load-location : [existing? #t] start-dir -> selected-dir-pathname
        ;; must select an existing file
        (define (get-load-location suggested-starting-path)
          (send (new path-dialog% [directory suggested-starting-path]
                     [existing? #t] 
                     [label "Load Tabs file"]
                     [message "Choose a tabs set file to load..."]
                     [filename "saved-tabs-file.sp"]
                     [filters (list (list "Scheme Project Files" "*.sp;*.scm;*.ss")
                                    (list "Any" "*.*"))]
                     )
                run))
        
        
        ;; save-tabs-to-file : out-file -> void
        (define (save-tabs-to-file out-file)
          (call-with-output-file out-file; saved-tabs-file-path
            (lambda (i) (write (resolve-save-rel (get-tab-files) out-file) i))
            #:exists 'replace
            ))
        
        ;; reload-tab-from-file : in-file -> void
        (define (reload-tab-from-file in-file)
          (for-each (lambda (filename) 
                      (drscheme:unit:open-drscheme-window (path->string filename)))
                    (let* ((rel-pathstr-list (call-with-input-file in-file (lambda (i) (read i))))
                           (abs-file-path-list (resolve-load-rel in-file rel-pathstr-list))
                           (normlized-abs-file-str-list (map simple-form-path abs-file-path-list)))
                      ;(printf "(get-tab-files):~v~n~v~n" (get-tab-files) normlized-abs-file-str-list)
                      (remove* (get-tab-files) normlized-abs-file-str-list))))
        
        ;; each-tab -> list of files
        ;; return the paths for all tabs that have one
        (define (get-tab-files)
          (filter (lambda (filename) filename)
                  (map (lambda (tab) (get-tab-filename tab))
                       (send this get-tabs))))
        
        ;; get-base-path : file -> base-path
        (define (get-base-path file)  ;; call conditionally on a (file-exists? path)
          (let-values (((base-path name dir?) (split-path file)))
            base-path))
        
        ;; get-tab-filename a-drscheme:unit:tab? -> (or/c path-string? false/c)
        ;; return #f if tab has no filename
        (define (get-tab-filename tab)
          (send (send tab get-defs) get-filename))
        
        ;; save-tabs thunk; save the current tabs to a file selected by the user
        (define save-tabs
          (lambda args 
            (let* ((this-tab (send this get-current-tab))
                   (file (get-tab-filename this-tab))
                   (save-location (if file ;#f if no file
                                      (get-save-location (get-base-path file))
                                      (get-save-location home-dir))))
              (when save-location (save-tabs-to-file save-location)))))
        
        ;; reload tabs thunk
        ;; add tabs in user-selected file to the editor (without duplicating tabs);
        ;; start looking in the current tab directory if their is one.
        ;        if the current tab does not have a directory (unsaved) then use
        ;        - the last save directory and filename as a starting point
        ;        - home directory?
        ;        - a dev-home directory?
        
        (define reload-tabs
          (lambda args 
            (let* ((this-tab (send this get-current-tab))
                   (file (get-tab-filename this-tab))
                   (load-location (if file ;#f if no file
                                      (get-load-location (get-base-path file))
                                      (get-load-location home-dir)
                                      )))
              (when load-location (reload-tab-from-file load-location)))))
        ;
        ;        (define/override (add-show-menu-items show-menu)
        ;          (super add-show-menu-items show-menu)
        ;          (make-object separator-menu-item% show-menu)
        ;          (new menu-item% 
        ;               [label "Save Tabs"]
        ;               [parent show-menu]
        ;               [callback 
        ;               
        ;                (lambda (i e) (let* ((this-tab (send this get-current-tab))
        ;                                     (this-tab-dir (send this-tab get-directory)))
        ;                                (if this-tab-dir (load (get-tab-files) this-tab-dir) (load (get-tab-files) home-dir))))])
        ;          (make-object separator-menu-item% show-menu)
        ;          )
        
        
        (define/override (file-menu:between-save-as-and-print file-menu)
          (make-object separator-menu-item% file-menu)
          (new menu-item%  
               [label "Save Tabs"]
               [parent file-menu]
               [callback save-tabs])
          (new menu-item%  
               [label "Reload Tabs"]
               [parent file-menu]
               [callback reload-tabs])
          (make-object separator-menu-item% file-menu)
          
          (super file-menu:between-save-as-and-print file-menu)
          )
        
        (super-new)
        
        (send this update-shown)  
        
        (inherit register-toolbar-button)
        
        (define project-icon-bitmap (make-object bitmap% project-icon-sm 'png/mask))
        
        (define save-project-button
          (new switchable-button% 
               (label "Save Tabs")
               (parent (make-object vertical-pane% (get-button-panel))) 
               (callback save-tabs)
               [bitmap project-icon-bitmap]
               ))
        (register-toolbar-button save-project-button)
        
        (send (get-button-panel) change-children
              (lambda (_)
                (cons (send save-project-button get-parent)
                      (remq (send save-project-button get-parent) _))))
        
        (define load-project-button
          (new switchable-button% 
               (label "Reload Tabs")
               (parent (make-object vertical-pane% (get-button-panel)))
               (callback reload-tabs)
               [bitmap project-icon-bitmap]
               ))
        (register-toolbar-button load-project-button)
        
        (send (get-button-panel) change-children
              (lambda (_)
                (cons (send load-project-button get-parent)
                      (remq (send load-project-button get-parent) _))))
        ))
    (drscheme:get/extend:extend-unit-frame projects-unit-frame-mixin)
    ))