#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-menu-bar get-button-panel register-toolbar-button)
        
        ;; requested - force save of all tabs in current frame only
        (define save-tab-files
          (lambda args
            (for-each
             (lambda (tab)
               (let ([editor (send tab get-defs)])
                 (send editor save-file #f (send editor get-file-format) #t)
                 ))
             (send this get-tabs))
            (send this update-shown) 
            ))
        
        ;; 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)
          (get-file "Load Tabs file" #f
                    suggested-starting-path
                    "saved-tabs-file.sp"
                    "sp" 
                    '(enter-packages) 
                    (list (list "Scheme Project Files" "*.sp")
                          (list "Any" "*.*")))
          
          ;          (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)
        ;          )
        
        
        
        
        (super-new)
        
        ; PROJECTS MENU
        
        (define project-menu
          (new menu% [label "Project"] [parent (get-menu-bar)]))
        
        ;(define/override (file-menu:between-save-as-and-print file-menu)
        (make-object separator-menu-item% project-menu)
        (define menu-item-save-tabs (new menu-item%  
                                         [label "Save tabs list"]
                                         [parent project-menu]
                                         [callback save-tabs]))
        (define menu-item-reload-tabs (new menu-item%  
                                           [label "Load tabs from saved list"]
                                           [parent project-menu]
                                           [callback reload-tabs]))
        (make-object separator-menu-item% project-menu)
        (define menu-item-save-tab-files (new menu-item%  
                                           [label "Save Tabs"]
                                           [parent project-menu]
                                           [callback save-tab-files]))
        
        
        
        ; (super file-menu:between-save-as-and-print file-menu)
        ; )
        
        (send this update-shown)  
        
        
        (define project-icon-bitmap (make-object bitmap% project-icon-sm 'png/mask))
        
        ;; I don't like the buttons - there are too many
        
        ;        (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)
    ))