gui.ss
#lang scheme/gui

(require "planet-utils.ss")
(require mrlib/hierlist)
(require (only-in mrlib/aligned-pasteboard horizontal-pasteboard% aligned-editor-snip%))
(require embedded-gui)
(require net/sendurl)

(define spacer%
  (class embedded-message%
     (init-field length)
     (super-new [label (make-string length #\space)])))

#;
(define (scrollable% parent)
  (class parent
    ;; (override do-get-graphical-min-size)
    (super-new)
    (define/override (alignment) #f)
    #;
    (define/override (do-get-graphical-min-size) 10)))

(define frame (new frame% [label "Planet Manager"]
                   [width 500]
                   [height 600]))

(define panel1 (new vertical-pane% [parent frame]))

(define package-panel (new hierarchical-list% [parent panel1]))

#;
(define package-panel (new vertical-pane% [parent panel1]
                           [stretchable-height #f]))

(let ([all (get-all-planet-packages)]
      [installed (send package-panel new-list)]
      [uninstalled (send package-panel new-list)])
  (define (update)
    (define (split-packages packages)
      (let ([installed (make-hash)]
            [uninstalled (make-hash)])
        (hash-for-each packages
                       (lambda (category package-list)
                         (let loop ([package-list package-list]
                                    [for-install '()]
                                    [for-uninstall '()])
                           (cond
                             [(null? package-list)
                              (hash-set! installed category for-install)
                              (hash-set! uninstalled category for-uninstall)]
                             [else (if (installed? (car package-list))
                                     (loop (cdr package-list)
                                           (cons (car package-list) for-install)
                                           for-uninstall)
                                     (loop (cdr package-list)
                                           for-install
                                           (cons (car package-list) for-uninstall)))]))))
        (values installed uninstalled)))

    (define (populate-list gui-list name packages button-maker)
      (send (send gui-list get-editor) erase)
      (send (send gui-list get-editor) insert name)
      (hash-for-each packages
                     (lambda (category packages)
                       (when (not (null? packages))
                         (let ([sub-list (send gui-list new-list)])
                           (send sub-list open)
                           (send (send sub-list get-editor) insert category)
                           (for-each (lambda (package)
                                       (define (setup-row place)
                                         (new embedded-message% [parent place]
                                              [label (planet-package-name package)])
                                         (new spacer% [length 5] [parent place])
                                         (button-maker place package))

                                       (let* ([editor (send (send sub-list new-item) get-editor)]
                                              [align (new aligned-pasteboard%)]
                                              [stretch (new editor-snip% [editor align])])
                                         (send editor insert stretch)
                                         (setup-row (new horizontal-alignment% [parent align]))))
                                     packages)
                           (send sub-list close))))))
    (define (install-button place package)
      (new embedded-text-button% [parent place]
           [label "install"]
           [callback (lambda x
                       (begin
                         (printf "Installing ~a\n"
                                 (planet-package-name package))
                         (install-planet-package package)
                         (update)
                         (printf "Done installing\n")))]))
    (define (uninstall-button place package)
      (new embedded-text-button% [parent place]
           [label "documentation"]
           [callback (lambda x
                       (send-url (documentation-url package)))])
      (new spacer% [parent place] [length 5])
      (new embedded-text-button% [parent place]
           [label "uninstall"]
           [callback (lambda x
                       (begin
                         (uninstall-planet-package package)
                         (update)))]))
    (define (cleanup-list hlist)
      (for-each (lambda (item)
                  (send hlist delete-item item))
                (send hlist get-items)))
    (let-values ([(installed-packages uninstalled-packages)
                  (split-packages all)])
      (send package-panel show #f)
      (cleanup-list installed)
      (send installed open)
      (cleanup-list uninstalled)
      (send uninstalled open)
      (populate-list installed "Installed packages" installed-packages uninstall-button)
      (populate-list uninstalled "Uninstalled packages" uninstalled-packages install-button)
      (send installed close)
      (send uninstalled close)
      (send package-panel show #t)))
  (update)

  #;
  (hash-for-each all
                 (lambda (category packages)
                   (define box (new group-box-panel%
                                    [label category]
                                    [parent package-panel]
                                    ))

                   (define nothing (new frame% [label "nothing"]))
                   #;
                   (define top (new (scrollable% vertical-pane%) [parent nothing]
                                    ))

                   (new list-box% [label "stuff"] [parent box]
                        [choices (map (lambda (x) (planet-package-name x))
                                      packages)])
                   #;
                   (for-each (lambda (package)
                               (new button% [parent box] [label "check"])
                               #;
                               (new check-box% [parent box] [label (planet-package-name package)]) )
                             packages))))

(send frame show #t)