#lang scheme/base
(require drscheme/tool
         planet/util
         mred
         mrlib/switchable-button
         mrlib/path-dialog
         mzlib/unit
         scheme/class)
(provide tool@)
(define tool@
  (unit
    (import drscheme:tool^)
    (export drscheme:tool-exports^)
    (define (phase1) (void))
    (define (phase2) (void))
    
    (define icon "icon.png")
    (define pack-icon-sm "icon.png")
    (define home-dir (find-system-path 'home-dir))
    (define planet-package-file (string->path "planet-package.plt"))
    (define (pack this-dir to-here)
      (let* ((result (make-planet-archive this-dir to-here)))
        (display result) (newline)
        ))
    
    (define (pack-unit-frame-mixin super%)
      (class super%
        (inherit get-button-panel)
        
        
        (define  pack-callback
          (lambda args (let* ((this-tab (send this get-current-tab))
                              (this-tab-dir (send this-tab get-directory))
                              (planet-package-name (let-values (((base name dir?) (split-path this-tab-dir))) (path->string name)))
                              )
                         (display planet-package-name)(newline)
                         (pack this-tab-dir (build-path home-dir (string->path (string-append planet-package-name ".plt")))))))
        
        (define/override (file-menu:between-save-as-and-print file-menu)
          (make-object separator-menu-item% file-menu)
          (new menu-item%  
               [label "Pack"]
               [parent file-menu]
               (callback pack-callback))
          (make-object separator-menu-item% file-menu)
          )
        
        (super-new)
        
        (inherit register-toolbar-button)
        
        (define icon-bitmap (make-object bitmap% pack-icon-sm 'png/mask))
        
        (define pack-button
          (new switchable-button% 
               (label "Pack")
               (parent (make-object vertical-pane% (get-button-panel))) 
               (callback pack-callback)
               [bitmap icon-bitmap]
               ))
        (register-toolbar-button pack-button)
        
        (send (get-button-panel) change-children
              (lambda (_)
                (cons (send pack-button get-parent)
                      (remq (send pack-button get-parent) _))))
        
        ))
    (drscheme:get/extend:extend-unit-frame pack-unit-frame-mixin)
    ))