added status information about planets behavior to the bottom of the drscheme window
svn: r13494
This commit is contained in:
Robby Findler
parent
fcce8e3cbf
commit
64e91b8362
|
|
@ -188,7 +188,8 @@ profile todo:
|
|||
(define bug-note% (make-note% "stop-multi.png" (include-bitmap (lib "icons/stop-multi.png") 'png/mask)))
|
||||
(define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif)))
|
||||
(define file-note% (make-note% "stop-22x22.png" (include-bitmap (lib "icons/stop-22x22.png") 'png/mask)))
|
||||
(define planet-note% (make-note% "small-planet.png" (include-bitmap (lib "icons/small-planet.png") 'png/mask)))
|
||||
(define small-planet-bitmap (include-bitmap (lib "icons/small-planet.png") 'png/mask))
|
||||
(define planet-note% (make-note% "small-planet.png" small-planet-bitmap))
|
||||
|
||||
;; display-stats : (syntax -> syntax)
|
||||
;; count the number of syntax expressions & number of with-continuation-marks in an
|
||||
|
|
|
|||
|
|
@ -66,6 +66,8 @@
|
|||
open-and-highlight-in-file
|
||||
get-cm-key
|
||||
|
||||
small-planet-bitmap
|
||||
|
||||
;show-error-and-highlight
|
||||
;print-bug-to-stderr
|
||||
;display-srclocs-in-error
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ TODO
|
|||
;; the dynamic-require below loads this module,
|
||||
;; so we make the dependency explicit here, even
|
||||
;; tho nothing is used from this module.
|
||||
planet/terse-logger)
|
||||
planet/terse-info)
|
||||
|
||||
(provide rep@ with-stacktrace-name)
|
||||
|
||||
|
|
@ -1294,7 +1294,7 @@ TODO
|
|||
(initialize-parameters snip-classes)
|
||||
|
||||
;; register drscheme with the planet-terse-register for this namespace
|
||||
((dynamic-require 'planet/terse-logger 'planet-terse-register)
|
||||
((dynamic-require 'planet/terse-info 'planet-terse-register)
|
||||
(lambda (tag package)
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback (λ () (new-planet-info tag package)))))))))
|
||||
|
|
@ -1463,11 +1463,9 @@ TODO
|
|||
(send frame update-logger-window))))
|
||||
|
||||
(define/private (new-planet-info tag package)
|
||||
(void)
|
||||
#;
|
||||
(let ([frame (get-frame)])
|
||||
(send frame open-status-line 'planet)
|
||||
(send frame update-status-line 'planet (format "~s ~s" tag package))))
|
||||
(when frame
|
||||
(send (send frame get-current-tab) new-planet-status tag package))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ module browser threading seems wrong.
|
|||
mrlib/switchable-button
|
||||
mrlib/cache-image-snip
|
||||
mrlib/include-bitmap
|
||||
|
||||
mrlib/close-icon
|
||||
net/sendurl
|
||||
net/url
|
||||
|
||||
|
|
@ -1327,6 +1327,20 @@ module browser threading seems wrong.
|
|||
(define/public-final (update-log)
|
||||
(send frame show/hide-log log-visible?))
|
||||
|
||||
(define current-planet-status #f)
|
||||
(define/public-final (new-planet-status a b)
|
||||
(set! current-planet-status (cons a b))
|
||||
(update-planet-status))
|
||||
(define/public-final (clear-planet-status)
|
||||
(set! current-planet-status #f)
|
||||
(update-planet-status))
|
||||
(define/public-final (update-planet-status)
|
||||
(send frame show-planet-status
|
||||
(and current-planet-status
|
||||
(car current-planet-status))
|
||||
(and current-planet-status
|
||||
(cdr current-planet-status))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;; should only be called by the tab% object (and the class itself)
|
||||
|
|
@ -1334,7 +1348,8 @@ module browser threading seems wrong.
|
|||
disable-evaluation-in-tab
|
||||
enable-evaluation-in-tab
|
||||
update-toolbar-visibility
|
||||
show/hide-log)
|
||||
show/hide-log
|
||||
show-planet-status)
|
||||
|
||||
(define -frame<%>
|
||||
(interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
|
||||
|
|
@ -1446,8 +1461,13 @@ module browser threading seems wrong.
|
|||
(send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
|
||||
(with-handlers ([exn:fail? void])
|
||||
(send logger-parent-panel set-percentages (list p (- 1 p))))
|
||||
(update-logger-button-label)
|
||||
(end-container-sequence)))
|
||||
|
||||
(define/private (log-shown?)
|
||||
(and logger-gui-tab-panel
|
||||
(member logger-panel (send logger-parent-panel get-children))))
|
||||
|
||||
(define/private (new-logger-text)
|
||||
(set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%)))
|
||||
(send logger-gui-text lock #t))
|
||||
|
|
@ -1474,6 +1494,78 @@ module browser threading seems wrong.
|
|||
(send logger-gui-text lock #t)
|
||||
(send logger-gui-text end-edit-sequence)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; planet status
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define planet-status-parent-panel #f)
|
||||
(define planet-status-panel #f)
|
||||
(define planet-message #f)
|
||||
(define planet-logger-button #f)
|
||||
;; local-member-name
|
||||
(define/public (show-planet-status tag package)
|
||||
(cond
|
||||
[(and (not tag)
|
||||
(not package)
|
||||
(or (not planet-status-parent-panel)
|
||||
(not (member planet-status-panel (send planet-status-parent-panel get-children)))))
|
||||
;; if there is no information and there is no GUI there, don't do anything
|
||||
(void)]
|
||||
[else
|
||||
(when planet-status-panel
|
||||
(unless planet-message
|
||||
(new message%
|
||||
[parent planet-status-panel]
|
||||
[label drscheme:debug:small-planet-bitmap])
|
||||
(set! planet-message (new message% [parent planet-status-panel] [label ""] [stretchable-width #t]))
|
||||
(set! planet-logger-button
|
||||
(new button%
|
||||
[font small-control-font]
|
||||
[parent planet-status-panel]
|
||||
[label (string-constant show-log)]
|
||||
[callback (λ (a b) (send current-tab toggle-log))]))
|
||||
(update-logger-button-label)
|
||||
;; needs to become that little x thingy that is in the search/replace bar
|
||||
(new close-icon%
|
||||
[parent planet-status-panel]
|
||||
[callback (λ ()
|
||||
(send planet-status-parent-panel change-children
|
||||
(λ (l)
|
||||
(remq planet-status-panel l)))
|
||||
(send current-tab clear-planet-status))]))
|
||||
(send planet-message set-label
|
||||
(case tag
|
||||
[(download)
|
||||
(format (string-constant planet-downloading) package)]
|
||||
[(install)
|
||||
(format (string-constant planet-installing) package)]
|
||||
[(finish)
|
||||
(format (string-constant planet-finished) package)]
|
||||
[else
|
||||
(string-constant planet-no-status)]))
|
||||
(send planet-status-parent-panel change-children
|
||||
(λ (l)
|
||||
(if (memq planet-status-panel l)
|
||||
l
|
||||
(append (remq planet-status-panel l) (list planet-status-panel))))))]))
|
||||
|
||||
(define/private (update-logger-button-label)
|
||||
(when planet-logger-button
|
||||
(send planet-logger-button set-label
|
||||
(if (and logger-gui-text
|
||||
(member logger-panel (send logger-parent-panel get-children)))
|
||||
(string-constant hide-log)
|
||||
(string-constant show-log)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; transcript
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; transcript : (union #f string[directory-name])
|
||||
(field [transcript #f]
|
||||
[definitions-transcript-counter 0] ;; number
|
||||
|
|
@ -1572,30 +1664,37 @@ module browser threading seems wrong.
|
|||
(define/override (make-root-area-container cls parent)
|
||||
(let* ([saved-p (preferences:get 'drscheme:module-browser-size-percentage)]
|
||||
[saved-p2 (preferences:get 'drscheme:logging-size-percentage)]
|
||||
[outer-panel (super make-root-area-container
|
||||
(make-two-way-prefs-dragable-panel% panel:horizontal-dragable%
|
||||
'drscheme:module-browser-size-percentage)
|
||||
parent)]
|
||||
[_module-browser-parent-panel
|
||||
(super make-root-area-container
|
||||
(make-two-way-prefs-dragable-panel% panel:horizontal-dragable%
|
||||
'drscheme:module-browser-size-percentage)
|
||||
parent)]
|
||||
[_module-browser-panel (new vertical-panel%
|
||||
(parent outer-panel)
|
||||
(parent _module-browser-parent-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-width #f))]
|
||||
[planet-status-outer-panel (new vertical-panel% [parent _module-browser-parent-panel])]
|
||||
[logger-outer-panel (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable%
|
||||
'drscheme:logging-size-percentage)
|
||||
[parent outer-panel]
|
||||
[stretchable-height #f])]
|
||||
[trans-outer-panel (new vertical-panel% [parent logger-outer-panel] [stretchable-height #f])]
|
||||
[parent planet-status-outer-panel])]
|
||||
[trans-outer-panel (new vertical-panel% [parent logger-outer-panel])]
|
||||
[root (make-object cls trans-outer-panel)])
|
||||
(set! module-browser-parent-panel _module-browser-parent-panel)
|
||||
(set! module-browser-panel _module-browser-panel)
|
||||
(set! module-browser-parent-panel outer-panel)
|
||||
(send outer-panel change-children (λ (l) (remq module-browser-panel l)))
|
||||
(send module-browser-parent-panel change-children (λ (l) (remq module-browser-panel l)))
|
||||
(set! logger-parent-panel logger-outer-panel)
|
||||
(set! logger-panel (new vertical-panel% [parent logger-parent-panel]))
|
||||
(send logger-parent-panel change-children (lambda (x) (remq logger-panel x)))
|
||||
(set! transcript-parent-panel (new horizontal-panel%
|
||||
(parent trans-outer-panel)
|
||||
(stretchable-height #f)))
|
||||
(parent trans-outer-panel)
|
||||
(stretchable-height #f)))
|
||||
(set! transcript-panel (make-object horizontal-panel% transcript-parent-panel))
|
||||
(set! planet-status-parent-panel (new vertical-panel%
|
||||
[parent planet-status-outer-panel]
|
||||
[stretchable-height #f]))
|
||||
(set! planet-status-panel (new horizontal-panel%
|
||||
[parent planet-status-parent-panel]))
|
||||
(send planet-status-parent-panel change-children (λ (l) (remq planet-status-panel l)))
|
||||
(unless (toolbar-shown?)
|
||||
(send transcript-parent-panel change-children (λ (l) '())))
|
||||
(preferences:set 'drscheme:module-browser-size-percentage saved-p)
|
||||
|
|
@ -2596,6 +2695,7 @@ module browser threading seems wrong.
|
|||
(update-running (send current-tab is-running?))
|
||||
(on-tab-change old-tab current-tab)
|
||||
(send tab update-log)
|
||||
(send tab update-planet-status)
|
||||
|
||||
(restore-visible-tab-regions)
|
||||
(for-each (λ (defs-canvas) (send defs-canvas refresh))
|
||||
|
|
|
|||
|
|
@ -602,6 +602,28 @@ context of a package. The others are convenience macros that
|
|||
select out the relevant field, or return @scheme[#f] if the expression
|
||||
appears outside the context of a PLaneT package.}
|
||||
|
||||
@subsection{Terse Status Updates}
|
||||
|
||||
@defmodule[planet/terse-info]
|
||||
|
||||
This module provides access to some PLaneT status information. This
|
||||
module is first loaded by PLaneT in the initial namespace (when
|
||||
PLaneT's resolver is loaded), but PLaneT uses @scheme[dynamic-require] to load
|
||||
this module each time it wants to announce information. Similarly, the
|
||||
state of which procedures are registered (via @scheme[planet-terse-register])
|
||||
is saved in the namespace, making the listening and information producing
|
||||
namespace-specific.
|
||||
|
||||
@defproc[(planet-terse-register [proc (-> (or/c 'download 'install 'finish) string? any/c)]) void?]{
|
||||
Registers @scheme[proc] as a function to be called when
|
||||
@scheme[planet-terse-log] is called. Note that @scheme[proc] is called
|
||||
asynchronously (ie, on some thread other than the one calling @scheme[planet-terse-register]).
|
||||
}
|
||||
|
||||
@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] [msg string?]) void?]{
|
||||
This function is called by PLaneT to announce when things are happening.
|
||||
}
|
||||
|
||||
@section{Developing Packages for PLaneT}
|
||||
|
||||
To put a package on PLaneT, or release an upgrade to an
|
||||
|
|
|
|||
|
|
@ -191,7 +191,9 @@ subdirectory.
|
|||
"config.ss"
|
||||
"private/planet-shared.ss"
|
||||
"private/linkage.ss"
|
||||
"parsereq.ss")
|
||||
"parsereq.ss"
|
||||
|
||||
(prefix x: "terse-info.ss")) ;; just to make the link static; this is actually loaded with dynamic-require
|
||||
|
||||
(provide (rename resolver planet-module-name-resolver)
|
||||
resolve-planet-path
|
||||
|
|
@ -211,7 +213,10 @@ subdirectory.
|
|||
;; this calls the terse logger from the current-namespace,
|
||||
;; not the original one when the planet resolver was loaded.
|
||||
(define (planet-terse-log id str)
|
||||
((dynamic-require 'planet/terse-logger 'planet-terse-log) id str))
|
||||
(let ([planet-terse-log
|
||||
(with-handlers ((exn:fail? void)) ;; if the dynamic-require fails, we just don't log anything
|
||||
(dynamic-require 'planet/terse-info 'planet-terse-log))])
|
||||
(planet-terse-log id str)))
|
||||
|
||||
;; =============================================================================
|
||||
;; DIAMOND PROPERTY STUFF
|
||||
|
|
@ -552,6 +557,7 @@ subdirectory.
|
|||
'install-planet-package)])
|
||||
(ipp path the-dir (list owner (pkg-spec-name pkg)
|
||||
extra-path maj min))))))
|
||||
(planet-terse-log 'finish (pkg-spec->string pkg))
|
||||
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg)
|
||||
maj min the-dir 'normal)))))
|
||||
|
||||
|
|
@ -730,13 +736,19 @@ subdirectory.
|
|||
;; formats the pkg-spec back into a string the way the user typed it in.
|
||||
;; assumes that the pkg-spec comes from the command-line
|
||||
(define (pkg-spec->string pkg)
|
||||
(format "'~a ~a ~a ~a'"
|
||||
(format "~a/~a~a~a"
|
||||
(if (pair? (pkg-spec-path pkg))
|
||||
(car (pkg-spec-path pkg))
|
||||
"<<unknown>>") ;; this shouldn't happen
|
||||
(pkg-spec-name pkg)
|
||||
(pkg-spec-maj pkg)
|
||||
(pkg-spec-minor-lo pkg)))
|
||||
(regexp-replace #rx"\\.plt$" (pkg-spec-name pkg) "")
|
||||
(if (pkg-spec-maj pkg)
|
||||
(format ":~a" (pkg-spec-maj pkg))
|
||||
"")
|
||||
(cond
|
||||
[(and (pkg-spec-maj pkg)
|
||||
(pkg-spec-minor-lo pkg))
|
||||
(format ".~a" (pkg-spec-minor-lo pkg))]
|
||||
[else ""])))
|
||||
|
||||
;; =============================================================================
|
||||
;; MODULE MANAGEMENT
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module terse-logger '#%kernel
|
||||
(module terse-info '#%kernel
|
||||
|
||||
;; This file is dynamically loaded by drscheme in a (possibly)
|
||||
;; empty namespace (ie possibly no scheme/base module yet)
|
||||
|
|
@ -6,8 +6,6 @@
|
|||
"private/planet-shared.ss"
|
||||
"private/linkage.ss"
|
||||
|
||||
"terse-logger.ss"
|
||||
|
||||
"resolver.ss"
|
||||
net/url
|
||||
xml/xml
|
||||
|
|
|
|||
|
|
@ -242,7 +242,7 @@ please adhere to these guidelines:
|
|||
(erase-log-directory-contents "Erase contents of log directory: ~a?")
|
||||
(error-erasing-log-directory "Error erasing log directory contents.\n\n~a\n")
|
||||
|
||||
;; menu items connected to the logger
|
||||
;; menu items connected to the logger -- also in a button in the planet status line in the drs frame
|
||||
(show-log "Show &Log")
|
||||
(hide-log "Hide &Log")
|
||||
(logging-all "All") ;; in the logging window in drscheme, shows all logs simultaneously
|
||||
|
|
@ -1177,7 +1177,7 @@ please adhere to these guidelines:
|
|||
(module-browser-progress "Module Browser: ~a") ;; prefix in the status line
|
||||
(module-browser-compiling-defns "Module Browser: compiling definitions")
|
||||
(module-browser-show-lib-paths/short "Follow lib requires") ;; check box label in show module browser pane in drscheme window.
|
||||
(module-browser-show-planet-paths/short "Follow planet requires") ;; check box label in show module browser pane in drscheme window.
|
||||
(module-browser-show-planet-paths/short "Follow PLaneT requires") ;; check box label in show module browser pane in drscheme window.
|
||||
(module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window.
|
||||
(module-browser-only-in-plt-and-module-langs
|
||||
"The module browser is only available for programs in the PLT languages and in the module language (and only for programs that have modules in them).")
|
||||
|
|
@ -1435,6 +1435,11 @@ please adhere to these guidelines:
|
|||
(bug-track-forget "Forget")
|
||||
(bug-track-forget-all "Forget All")
|
||||
|
||||
;; planet status messages in the bottom of the drscheme window; the ~a is filled with the name of the package
|
||||
(planet-downloading "PLaneT: Downloading ~a...")
|
||||
(planet-installing "PLaneT: Installing ~a...")
|
||||
(planet-finished "PLaneT: Finished with ~a.")
|
||||
(planet-no-status "PLaneT") ;; this can happen when there is status shown in a different and then the user switches to a tab where planet hasn't been used
|
||||
|
||||
;; string normalization. To see this, paste some text with a ligature into DrScheme
|
||||
;; the first three strings are in the dialog that appears. The last one is in the preferences dialog
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user