#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
(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)