#lang scheme/gui

;; ##################################################################################
;; # ============================================================================== #
;; # MrEd Designer - toolbox-frame.ss                                               #
;; # http://mreddesigner.lozi.org                                                   #
;; # Copyright (C) Lozi Jean-Pierre, 2004 - mailto:[email protected]             #
;; # Copyright (C) Peter Ivanyi, 2007                                               #
;; # Copyright (C) Laurent Orseau, 2010                                             #
;; # ============================================================================== #
;; #                                                                                #
;; # This program is free software; you can redistribute it and/or                  #
;; # modify it under the terms of the GNU General Public License                    #
;; # as published by the Free Software Foundation; either version 2                 #
;; # of the License, or (at your option) any later version.                         #
;; #                                                                                #
;; # This program is distributed in the hope that it will be useful,                #
;; # but WITHOUT ANY WARRANTY; without even the implied warranty of                 #
;; # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                  #
;; # GNU General Public License for more details.                                   #
;; #                                                                                #
;; # You should have received a copy of the GNU General Public License              #
;; # along with this program; if not, write to the Free Software                    #
;; # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.    #
;; #                                                                                #
;; ##################################################################################


(require "mred-plugin.ss"
         "plugin.ss"
         "mreddesigner-misc.ss"
         "mreddesigner-help.ss"
         "tooltip.ss"
         "templates.ss"
         )

(define/provide toolbox-frame #f)
(define toolbox-frame-vertical-pane #f)
(define toolbox-plugin-button-callback #f)
(define lb-templates #f)

(define toolbox-frame%
  (class frame%
    (init-field on-close-callback)
    (super-new)
    
    (define closing? #f)
    (define/augment (on-close)
      (unless closing?
        (set! closing? #t)
        (on-close-callback)))
    ))

(define/provide (make-toolbox-frame 
                 ; we could use global parameters instead!
                 ; that would avoid a lot of id rewrite!
                 #:exit-application-callback exit-application-callback
                 #:plugin-button-callback    plugin-button-callback 
                 #:generate-code-callback    generate-code-callback
                 #:generate-code-to-console-callback generate-code-to-console-callback
                 #:new-project-callback      new-project-callback
                 #:load-project-callback     load-project-callback
                 #:save-project-callback     save-project-callback
                 #:close-project-callback    close-project-callback
                 #:add-template-callback     add-template-callback
                 #:save-template-callback    save-template-callback
                 #:replace-template-callback replace-template-callback
                 #:delete-template-callback  delete-template-callback
                 #:show-properties-callback  show-properties-callback
                 #:show-hierarchy-callback   show-hierarchy-callback
                 #:cut-callback   cut-callback
                 #:copy-callback  copy-callback
                 #:paste-callback paste-callback
                 [parent #f])
  (set! toolbox-plugin-button-callback
        plugin-button-callback)
  (set! toolbox-frame
        (new toolbox-frame% 
             [label application-name];"Toolbox"]
             [min-width 200]
             [parent parent]
             [x 5]
             [y 5]
             [on-close-callback exit-application-callback]
             ))
  
  (let* ([menu (new menu-bar% [parent toolbox-frame])]
         [make-menu (λ(label [help-str #f]) 
                        (new menu% [parent menu] [label label] 
                             [help-string help-str]))]
         [menu-file     (make-menu "File")]
         [menu-edit     (make-menu "Edit")]
         [menu-windows  (make-menu "Windows")]
         [menu-help     (make-menu "Help")]
         [current-menu (make-parameter menu-file)]
         [make-menu-item (λ (label shortcut callback)
                           (new menu-item% [parent (current-menu)]
                                [label label]
                                [shortcut shortcut]
                                [callback (λ _ (callback))]))]
         [make-separator (λ()(new separator-menu-item%
                                  [parent (current-menu)]))]
         )
    (current-menu menu-file)
    (make-menu-item "&New Project"          #\N  new-project-callback)
    (make-menu-item "&Open Project..."      #\O  load-project-callback)
    (make-menu-item "&Save Project"         #\S  save-project-callback)
    (make-menu-item "S&ave Project as..."   'f12 (λ _ (save-project-callback #t)))
    (make-separator)
    (make-menu-item "&Generate Scheme File..." 'f5  generate-code-callback)
    (make-separator)
    (make-menu-item "&Close Project"        #\W  close-project-callback)
    (make-separator)
    (make-menu-item "E&xit"                 #\Q  exit-application-callback)
    
    (current-menu menu-edit)
    ; insert template from a file
    ;(make-menu-item "&Insert Template..."       #f   load-template)
    ; save template to a user-selected file
    ;(make-menu-item "&Save Template as File..." #f   save-template-as)
    ;(make-separator)
    (make-menu-item "C&ut"                  #\X  cut-callback)
    (make-menu-item "&Copy"                 #\C  copy-callback)
    (make-menu-item "&Paste"                #\V  paste-callback)
    
    (current-menu menu-windows)
    (make-menu-item "Show/Hide &Properties" #f   show-properties-callback)
    (make-menu-item "Show/Hide &Hierarchy"  #f   show-hierarchy-callback)
    
    (current-menu menu-help)
    (make-menu-item "&Online Help"            'f1  help-online-help)
    (make-menu-item "&PLT MrEd Help"          #f   help-mred-help)
    (make-menu-item "&About MrEd Designer..." #f   help-about-dialog)
    )
  
  
  (set! toolbox-frame-vertical-pane
        (new vertical-pane% 
             [parent toolbox-frame] 
             [alignment '(right top)] 
             [border 3]))
  ; Add the plugin buttons:
  (toolbox-frame-make-plugin-buttons)

  ;; Templates:
  (let* ([gb (new group-box-panel% 
                  [label "Templates"]
                  [parent toolbox-frame-vertical-pane])]
         [hp  (new horizontal-panel% [parent gb]
                   [alignment '(center center)]
                   )]
         [hp2 (new horizontal-panel% [parent gb]
                   [alignment '(center center)]
                   [stretchable-width #t]
                   )]
         [hp3 (new horizontal-panel% [parent gb]
                   [alignment '(center center)]
                   [stretchable-width #t]
                   )]
         )
    ; the list of templates
    (set! lb-templates
          (new choice%
               [parent hp]
               [label #f]
               [min-width 250]
               [stretchable-width #t]
               [choices '()]))
    (toolbox-update-template-choices)
    ; a button to add a template.
    ; The callback is applied to the file of the selected template.
    (new button%
         [parent hp]
         [label "Insert"]
         [callback (λ _ (add-template-callback (get-selected-template)))]
         )
    (new button%
         [parent hp2]
         [label "Save"]
         [callback (λ _ (save-template-callback 
                         (get-text-from-user "Saving Template ..." 
                                             "Enter a name for the new template:")))]
         )
    (new button%
         [parent hp2]
         [label "Replace"]
         [callback (λ _ (when (eq? 'yes (message-box "Replace?"
                                                     "Are you sure you want to replace the current template?"
                                                     #f '(yes-no)))
                          (replace-template-callback (get-selected-template))))]
         )
    (new button% 
         [parent hp2]
         [label "Delete"]
         [callback (λ _ (when (eq? 'yes (message-box "Delete?"
                                                     "Are you sure you want to delete the current template?"
                                                     #f '(yes-no)))
                          (delete-template-callback (get-selected-template))))]
         )
    ; rename also !
    )

  ; Project:
  (let* ([gbp (new group-box-panel% [parent toolbox-frame-vertical-pane]
                   [label "Generate code..."])]
         [hp (new horizontal-panel% [parent gbp]
                  [alignment '(center center)]
                  )]
         )
    (new button%
         [label "To console"]
         [parent hp]
         [min-width 110]
         [callback (λ _ (generate-code-to-console-callback))])
    (new button%
         [label "To <projet-id>.ss"]
         [parent hp]
         [min-width 110]
         [callback (λ _ (generate-code-callback #:ask #f))])
    )
    
  (update-toolbox-frame #f) ; ??
  )

(define/provide (show-toolbox-frame)
  (send toolbox-frame show #t))

;; Returns the template file that is selected in the list-box (or choice%)
(define (get-selected-template)
  (let ([sel (send lb-templates get-selection)])
    (and sel (car (list-ref template-dict sel)))))

;; Updates the list of templates
(define/provide (toolbox-update-template-choices)
  (send lb-templates clear)
  ; add the actual templates with the filenames
  (dict-for-each template-dict
                 (λ(k v)(if v 
                            (send lb-templates append v)
                            (printf "Warning: File ~a has a wrong format!\n" k)
                            )))
  (send lb-templates refresh)
  )


; Holds all the plugin panels
(define plugin-panels (make-hash))

(define (new-plugin-panel label)
  (let ([gbp (new group-box-panel% 
                  (label label) 
                  (parent toolbox-frame-vertical-pane))])
    (new horizontal-pane% 
       (parent gbp))))

;; Returns the button panel to which the plugin belongs.
(define (get-button-panel plugin panel-name)
  (hash-ref! plugin-panels panel-name 
             ; if none found, add a new one
             (λ()(new-plugin-panel panel-name))))


(define (add-plugin-button plugin)
  (let ([button-group (send plugin get-button-group)])
    (when button-group
      (let ([pl-panel (get-button-panel plugin button-group)])
        (new tooltip-button%
             [label (make-object bitmap% 
                      (build-path widget-plugins-path
                                  (send plugin get-dir-name) 
                                  widget-icons-dir "24x24.png")
                      'png 
                      (send the-color-database find-color "white"))]
             [tooltip-text (send plugin get-tooltip)]
             [parent pl-panel]
             [style '(border)]
             [callback (λ(b e)(toolbox-plugin-button-callback plugin))]
             )))))

;; We fill it
(define plugins-buttons '())
(define (toolbox-frame-make-plugin-buttons)
  (set! plugins-buttons
        (map (λ(p)(cons p (add-plugin-button p)))
             (get-widget-plugins))))


(define/provide (update-toolbox-frame mid)
  (dict-for-each plugins-buttons
                 (λ(p b)
                   (when (send p get-button-group) ; is there a button ?
                     (send b enable (send p can-instanciate? mid))))
                 ))