diff --git a/collects/drscheme/private/tool-contracts.ss b/collects/drscheme/private/tool-contracts.ss deleted file mode 100644 index 53d6cc9425..0000000000 --- a/collects/drscheme/private/tool-contracts.ss +++ /dev/null @@ -1,1380 +0,0 @@ - -(module tool-contracts "tool-contract-language.ss" - - ; - ; - ; - ; ; - ; ; - ; ; - ; ;;; ; ; ;;; ; - ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; - ; ;;;;;; ; ; ;;;; ; - ; ; ; ; ; ; ; - ; ; ; ; ; ; - ; ;;;; ; ;;;;; ; - ; - ; - ; - - - (drscheme:eval:set-basic-parameters - ((listof (is-a?/c snip-class%)) . -> . void?) - (snipclasses) - "sets the parameters that are shared between the repl's" - "initialization and \\iscmprocedure{drscheme:eval:build-user-eventspace/custodian}" - "" - "Specifically, it sets these parameters:" - "\\begin{itemize}" - "\\item \\rawscm{current-namespace} has been set to a newly" - " created empty namespace. This namespace has the following modules " - " copied (with \\MzLink{mz:namespace-utilities}{\\rawscm{namespace-attach-module}})" - " from DrScheme's original namespace:" - " \\begin{itemize}" - " \\item \\Symbol{mzscheme}" - " \\item \\scmc{'(lib \"mred.ss\" \"mred\")}" - " \\end{itemize}" - "" - "\\item" - " \\MzLink{mz:p:read-curly-brace-as-paren}{\\rawscm{read-curly-brace-as-paren}}" - " is \\scmc{\\#t}," - "\\item" - " \\MzLink{mz:p:read-square-bracket-as-paren}{\\rawscm{read-square-bracket-as-paren}}" - " is \\scmc{\\#t}," - "\\item " - " \\MzLink{mz:p:error-print-width}{\\rawscm{error-print-width}} is set to 250." - "\\item" - "@flink current-ps-setup" - "is set to a newly created" - "@link ps-setup" - "object." - "\\item The \\MzLink{mz:p:exit-handler}{\\rawscm{exit-handler}} is set to" - "a parameter that kills the user's custodian." - "\\item The snip-class-list, returned by" - "@flink get-the-snip-class-list" - "is initialized with all of the snipclasses in DrScheme's eventspace's snip-class-list." - "" - "\\end{itemize}") - - (drscheme:eval:get-snip-classes - (-> (listof (is-a?/c snip-class%))) - () - "Returns a list of all of the snipclasses in the current eventspace") - - (drscheme:eval:expand-program - ((or/c port? drscheme:language:text/pos?) - drscheme:language-configuration:language-settings? - boolean? - (-> void?) - (-> void?) - ((or/c eof-object? syntax? (cons/c string? any/c)) - (-> any) - . -> . - any) - . -> . - void?) - (input language-settings eval-compile-time-part? init kill-termination iter) - - "Use this function to expand the contents of the definitions" - "window for use with external program processing tools." - "" - "This function uses" - "@flink drscheme:eval:build-user-eventspace/custodian" - "to build the user's environment." - "The arguments \\var{language-settings}, \\var{init}, and" - "\\var{kill-termination} are passed to" - "@flink drscheme:eval:build-user-eventspace/custodian %" - "." - "" - "The \\var{input} argument specifies the source of the program." - "" - "The \\var{eval-compile-time-part?} argument indicates if" - "\\Mzhyperref{\\rawscm{expand}}{mz:expansion}" - "is called or if" - "\\scheme|expand-top-level-with-compile-time-evals|" - "is called when the program is expanded." - "Roughly speaking, if your tool will evaluate each expression" - "itself by calling" - "\\Mzhyperref{\\rawscm{eval}}{mz:evalload}" - "then pass \\scheme{#f}. Otherwise, if your tool" - "just processes the expanded program, be sure to pass" - "\\scheme{#t}." - "" - "This function calls" - "@ilink drscheme:language:language front-end/complete-program" - "to expand the program." - "" - "The first argument to \\var{iter} is the expanded program" - "(represented as syntax) or eof." - "The \\var{iter} argument is called for each expression in the" - "expanded program and once more with eof, unless an error is" - "raised during expansion." - "It is called from the user's thread." - "If an exception is raised during expansion of the" - "user's program, \\var{iter} is not called." - "Consider setting the exception-handler during \\var{init} to" - "handle this situation." - "" - "The second argument to \\var{iter} is a thunk that" - "continues expanding the rest of the contents of the" - "definitions window. If the first argument to \\var{iter} was" - "eof, this argument is just the primitive" - "\\rawscm{void}." - "" - "See also" - "@flink drscheme:eval:expand-program/multiple %" - ".") - - (drscheme:eval:traverse-program/multiple - (drscheme:language-configuration:language-settings? - (-> void?) - (-> void?) - . -> . - ((or/c port? drscheme:language:text/pos?) - ((or/c eof-object? syntax? (cons/c string? any/c)) - (-> any) - . -> . - any) - boolean? - . -> . - void?)) - (language-settings init kill-termination) - - "This function is similar to" - "@flink drscheme:eval:expand-program/multiple" - "The only difference is that it does not" - "expand the program in the editor; instead" - "the processing function can decide how to" - "expand the program.") - - (drscheme:eval:expand-program/multiple - (drscheme:language-configuration:language-settings? - boolean? - (-> void?) - (-> void?) - . -> . - ((or/c port? drscheme:language:text/pos?) - ((or/c eof-object? syntax? (cons/c string? any/c)) - (-> any) - . -> . - any) - boolean? - . -> . - void?)) - (language-settings eval-compile-time-part? init kill-termination) - - "This function is just like" - "@flink drscheme:eval:expand-program" - "except that it is curried and the second application" - "can be used multiple times." - "Use this function if you want to initialize the user's" - "thread (and namespace, etc) once but have program text" - "that comes from multiple sources." - "" - "The extra boolean argument to the result function" - "determines if" - "@ilink drscheme:language:language front-end/complete-program" - "or" - "@ilink drscheme:language:language front-end/interaction" - "is called.") - - (drscheme:eval:build-user-eventspace/custodian - ((drscheme:language-configuration:language-settings? - (-> void?) - (-> void?)) - . ->* . - (eventspace? custodian?)) - (language-settings init kill-termination) - - "This function creates a custodian and an eventspace (on the" - "new custodian) to expand the user's program. It does not" - "kill this custodian, but it can safely be shutdown (with" - "\\MzLink{mz:custodians}{custodian-shutdown-all}) after the" - "expansion is finished." - "" - "It initializes the" - "user's eventspace's main thread with several parameters:" - "\\begin{itemize}" - "\\item \\rawscm{current-custodian} is set to a new custodian." - "\\item" - "In addition, it calls" - "@flink drscheme:eval:set-basic-parameters %" - "." - "\\end{itemize}" - "" - "The \\var{language-settings} argument is the current" - "language and its settings. See" - "@flink drscheme:language-configuration:make-language-settings" - "for details on that structure." - "" - "If the program is associated with a DrScheme" - "frame, get the frame's language settings from the" - "@ilink drscheme:unit:definitions-text get-next-settings" - "method of " - "@ilink drscheme:unit:definitions-text %" - ". Also, the most recently chosen language in" - "the language dialog is saved via the framework's" - "preferences. Apply" - "@flink preferences:get" - "to" - "@flink drscheme:language-configuration:get-settings-preferences-symbol" - "for that \\var{language-settings}." - "" - "The \\var{init} argument is called after the user's parameters" - "are all set, but before the program is run. It is called on" - "the user's thread. The" - "\\MzLink{mz:p:current-directory}{current-directory} and" - "\\MzLink{mz:p:current-load-relative-directory}{current-load-relative-directory}" - "parameters are not set, so if there are appropriate directories," - "the \\var{init} argument is a good place to set them." - "" - "The \\var{kill-termination} argument is called when the main thread of" - "the eventspace terminates, no matter if the custodian was" - "shutdown, or the thread was killed. This procedure is also" - "called when the thread terminates normally. This procedure is" - "called from a new, dedicated thread ({\\it i. e.}, not the thread" - "created to do the expansion, nor the thread that" - "\\rawscm{drscheme:eval:build-user-eventspace/custodian} was called from.)") - - - - ; - ; - ; - ; ; ; - ; ; ; - ; ; ; - ; ;; ; ;;; ; ;; ; ; ;; ; - ; ; ;; ; ; ;; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ;; ; ; ;; ; ;; - ; ;; ; ;;;; ; ;; ;; ; ;; ; - ; ; - ; ; ; - ; ;;;; - - (drscheme:debug:show-error-and-highlight - (string? - (or/c any/c exn?) - (-> (listof srcloc?) (or/c false/c (listof (list/c (is-a?/c text%) number? number?))) any) - . -> . - any) - (msg exn highlight-errors) - "The first two arguments are the same as the arguments to the error-display-handler. " - "This function prints the error message to the current-error-port, like the default error-display-handler " - "and also calls \\var{highlight-errors} to do error highlighting. It is be passed the stack trace " - "for the error message." - "" - "This function should be called on the same thread/eventspace where the error happened.") - - (drscheme:debug:make-debug-error-display-handler - ((string? (or/c any/c exn?) . -> . any) - . -> . - (string? (or/c any/c exn?) . -> . any)) - - (oedh) - - "This function implements an error-display-handler in terms" - "of another error-display-handler." - "" - "This function is designed to work in conjunction with" - "@flink drscheme:debug:make-debug-eval-handler %" - "." - "" - "See also MzScheme's" - "MzLink{mz:p:error-display-handler}{error-display-handler}" - "parameter." - "" - "If the current-error-port is the definitions window in" - "drscheme, this error handler inserts some debugging" - "annotations, calls \\var{oedh}, and then highlights the" - "source location of the runtime error.") - - (drscheme:debug:make-debug-eval-handler - ((any/c . -> . any/c) - . -> . - (any/c . -> . any/c)) - - (odeh) - - "This function implements an eval-handler in terms of another" - "eval-handler." - "" - "This function is designed to work in conjunction with" - "@flink drscheme:debug:make-debug-error-display-handler %" - "." - "" - "See also MzScheme's MzLink{mz:p:eval-handler}{eval-handler}" - "parameter. " - "" - "The resulting eval-handler expands and annotates the input" - "expression and then passes it to the input eval-handler," - "unless the input expression is already compiled, in which" - "case it just hands it directly to the input eval-handler.") - - (drscheme:debug:hide-backtrace-window - (-> void?) - () - "Hides the backtrace window.") - - - (drscheme:debug:profiling-enabled - (case-> (boolean? . -> . void?) - (-> boolean?)) - ((enabled?) ()) - "A parameter that controls if profiling information is recorded." - "" - "Defaults to \\scmc{\\#f}." - "" - "Only applies if" - "@flink drscheme:debug:make-debug-eval-handler" - "has been added to the eval handler.") - - (drscheme:debug:add-prefs-panel - (-> void?) - () - "Adds the profiling preferences panel.") - - (drscheme:debug:open-and-highlight-in-file - (srcloc? . -> . void?) - (debug-info) - "This function opens a DrScheme to display" - "\\var{debug-info}. The first element in" - "the cons indicates where the file is" - "and the two number indicate a range of" - "text to show." - "" - "See also" - "@flink drscheme:debug:get-cm-key %" - ".") - - (drscheme:debug:show-backtrace-window - (string? - (or/c exn? (listof srcloc?)) - . -> . - void?) - (error-message dis) - "Shows the backtrace window you get when clicking on the bug in" - "DrScheme's REPL." - "" - "The \\var{error-message} argument is the text of the error," - "\\var{dis} is the debug information, extracted from the" - "continuation mark in the exception record, using" - "@flink drscheme:debug:get-cm-key %" - ".") - - (drscheme:debug:get-cm-key - (-> any) - () - "Returns a key used with \\scheme|contination-mark-set->list|." - "The contination mark set attached to an exception record" - "for the user's program may use this mark. If it does," - "each mark on the continuation is a list of the fields" - "of a srcloc object.") - - ; - ; - ; - ; ; - ; - ; ; - ; ; ; ; ;; ; ;;;; - ; ; ; ;; ; ; ; - ; ; ; ; ; ; ; - ; ; ; ; ; ; ; - ; ; ; ; ; ; ; - ; ; ;; ; ; ; ; - ; ;; ; ; ; ; ;; - ; - ; - ; - - - (drscheme:unit:get-program-editor-mixin - (-> ((subclass?/c text%) . -> . (subclass?/c text%))) - () - "Returns a mixin that must be mixed in to any" - "\\iscmclass{text} object that might contain" - "program text (and thus can be in the source" - "field of some syntax object)." - "" - "See also" - "@flink drscheme:unit:add-to-program-editor-mixin %" - ".") - - (drscheme:unit:add-to-program-editor-mixin - (((subclass?/c text%) . -> . (subclass?/c text%)) . -> . void?) - (mixin) - "\\phase{1}" - "" - "Adds \\var{mixin} to the result of" - "@flink drscheme:unit:get-program-editor-mixin %" - ".") - - (drscheme:unit:open-drscheme-window - (case-> - (-> (is-a?/c drscheme:unit:frame%)) - ((or/c string? false/c) . -> . (is-a?/c drscheme:unit:frame%))) - (() (filename)) - - "Opens a drscheme frame that displays \\var{filename}," - "or nothing if \\var{filename} is \\scmc{\\#f} or not supplied.") - - - - ; - ; - ; - ; ; - ; ; - ; ; - ; ; ;; ;; ;;; ;; ; ;;; ;;; - ; ;; ;; ; ; ; ; ;; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ;;;;;; ;; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ; - ; ; ; ; ;;; ;; ; ;;;; ;;; - ; - ; - ; - - - (drscheme:modes:add-mode - (string? - (or/c false/c (is-a?/c mode:surrogate-text<%>)) - ((is-a?/c drscheme:rep:text%) number? . -> . boolean?) - ((or/c false/c (listof string?)) . -> . boolean?) - . -> . - drscheme:modes:mode?) - (name surrogate repl-submit matches-language) - "Adds a mode to DrScheme. Returns a mode value" - "that identifies the mode." - "" - "The first argument, \\var{name}, is the name" - "of the mode, used in DrScheme's GUI to allow" - "the user to select this mode." - "" - "The \\var{surrogate} argument is set to the" - "definitions text and the interactions text" - "(via the" - "@ilink mode:host-text set-surrogate" - "method) whenever this mode is enabled." - "" - "The \\var{repl-submit} procedure is called" - "whenever the user types a return in the interactions" - "window. It is passed the interactions editor" - "and the position where the last prompt occurs." - "If it " - "returns \\scheme|#t|, the text after the last" - "prompt is treated as a program fragment and" - "evaluated, according to the language settings." - "If it returns \\scheme|#f|, the text is" - "assumed to be an incomplete program fragment, and" - "the keystroke is not treated specially." - "" - "The \\var{matches-language} predicate is called whenever" - "the language changes. If it returns \\scheme|#t|" - "this mode is installed. It is passed the list of strings" - "that correspond to the names of the language in the" - "language dialog." - "" - "Modes are tested in the opposite order that they are" - "added. That is, the last mode to be added gets tested" - "first when the filename changes or when the language" - "changes." - "" - "See also" - "@flink drscheme:modes:get-modes %" - ".") - - (drscheme:modes:mode? - (any/c . -> . boolean?) - (val) - "Determines if \\var{val} is a mode.") - - (drscheme:modes:get-modes - (-> (listof drscheme:modes:mode?)) - () - "Returns all of the modes currently added to DrScheme." - "" - "See also" - "@flink drscheme:modes:add-mode %" - ".") - - (drscheme:modes:mode-name - (drscheme:modes:mode? . -> . string?) - (mode) - "Extracts the name of the mode." - "" - "See also" - "@flink drscheme:modes:add-mode %" - ".") - - (drscheme:modes:mode-surrogate - (drscheme:modes:mode? . -> . (or/c false/c (is-a?/c mode:surrogate-text<%>))) - (mode) - "Extracts the surrogate of the mode." - "" - "See also" - "@flink drscheme:modes:add-mode %" - ".") - - (drscheme:modes:mode-repl-submit - (drscheme:modes:mode? . -> . any) - (mode) - "Extracts the repl submission predicate of the mode." - "" - "See also" - "@flink drscheme:modes:add-mode %" - ".") - - (drscheme:modes:mode-matches-language - (drscheme:modes:mode? . -> . ((or/c false/c (listof string?)) . -> . boolean?)) - (mode) - "Extracts the language matching predicate of the mode." - "" - "See also" - "@flink drscheme:modes:add-mode %" - ".") - - - ; - ; - ; - ; - ; - ; - ; ; ; ;;; ; ;; - ; ;; ; ; ;; ; - ; ; ; ; ; ; - ; ; ;;;;;; ; ; - ; ; ; ; ; - ; ; ; ;; ; - ; ; ;;;; ; ;; - ; ; - ; ; - ; ; - - - (drscheme:rep:get-welcome-delta - (-> (is-a?/c style-delta%)) - () - "Returns a style delta that matches the style and color of the " - "phrase ``Welcome to'' in the beginning of the interactions window.") - - (drscheme:rep:get-dark-green-delta - (-> (is-a?/c style-delta%)) - () - "Returns a style delta that matches the style and color of the " - "name of a language in the interactions window.") - - (drscheme:rep:get-drs-bindings-keymap - (-> (is-a?/c keymap%)) - () - "Returns a keymap that binds various DrScheme-specific" - "keybindings. This keymap is used in the definitions" - "and interactions window." - "" - "Defaultly binds C-x;o to a function that switches" - "the focus between the definitions and interactions" - "windows. Also binds f5 to Execute and f1 to Help Desk.") - - (drscheme:rep:current-rep - (-> (or/c false/c (is-a?/c drscheme:rep:text%))) - () - - "This is a parameter whose value should not be set by tools." - "It is initialized to the repl that controls this evaluation" - "in the user's thread." - "" - "It only returns \\scheme|#f| if the program not running" - "in the context of a repl (eg, the test suite window).") - - (drscheme:rep:current-value-port - (-> (or/c false/c port?)) - () - "This is a parameter whose value is a port that" - "prints in the REPL in blue. It is used to print" - "the values of toplevel expressions in the REPL." - "" - "It is only initialized on the user's thread") - - - ; - ; - ; - ; ; ; - ; ; ; - ; ; ; ; ; - ; ;; ; ;;; ;;;; ; ;;; ; ; ;;;; ;;; ; ;; ;; ; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;;; ; ; ;;;;;; ; ; ;;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; - ; ;; ; ;;;; ;; ; ;;;; ; ; ;; ;;;; ; ; ;; ; - ; ; ; - ; ; ; ; - ; ;;;; - - - (drscheme:get/extend:extend-tab - (case-> - ((make-mixin-contract drscheme:unit:tab%) . -> . void?) - ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This class implements the tabs in drscheme. One is created for each tab" - "in a frame (each frame always has at least one tab, even if the tab bar is not shown)" - "" - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#t}.") - - (drscheme:get/extend:extend-interactions-text - (case-> - ((make-mixin-contract drscheme:rep:text<%>) . -> . void?) - ((make-mixin-contract drscheme:rep:text<%>) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This text is used in the bottom window of drscheme frames." - "" - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#t}.") - - (drscheme:get/extend:get-interactions-text - (-> (implementation?/c drscheme:rep:text<%>)) - () - - "Once this function is called, " - "@flink drscheme:get/extend:extend-interactions-text " - "raises an error, disallowing any more extensions.") - - (drscheme:get/extend:extend-definitions-text - (case-> - ((make-mixin-contract drscheme:unit:definitions-text<%>) . -> . void?) - ((make-mixin-contract drscheme:unit:definitions-text<%>) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This text is used in the top window of drscheme frames." - "" - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#f}.") - - (drscheme:get/extend:get-definitions-text - (-> (implementation?/c drscheme:unit:definitions-text<%>)) - () - - "Once this function is called, " - "@flink drscheme:get/extend:extend-definitions-text " - "raises an error, disallowing any more extensions.") - - (drscheme:get/extend:extend-interactions-canvas - (case-> - ((make-mixin-contract drscheme:unit:interactions-canvas%) . -> . void?) - ((make-mixin-contract drscheme:unit:interactions-canvas%) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This canvas is used in the bottom window of drscheme frames." - "" - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#f}.") - - (drscheme:get/extend:get-interactions-canvas - (-> (subclass?/c drscheme:unit:interactions-canvas%)) - () - - "Once this function is called, " - "@flink drscheme:get/extend:extend-interactions-canvas" - "raises an error, disallowing any more extensions.") - - (drscheme:get/extend:extend-definitions-canvas - (case-> - ((make-mixin-contract drscheme:unit:definitions-canvas%) . -> . void?) - ((make-mixin-contract drscheme:unit:definitions-canvas%) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This canvas is used in the top window of drscheme frames." - - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#f}.") - - (drscheme:get/extend:get-definitions-canvas - (-> (subclass?/c drscheme:unit:definitions-canvas%)) - () - - "Once this function is called, " - "@flink drscheme:get/extend:extend-definitions-canvas" - "raises an error, disallowing any more extensions.") - - (drscheme:get/extend:extend-unit-frame - (case-> - ((make-mixin-contract drscheme:unit:frame%) . -> . void?) - ((make-mixin-contract drscheme:unit:frame%) boolean? . -> . void?)) - ((mixin) (mixin before?)) - - "This is the frame that implements the main drscheme window." - "" - "The argument, \\var{before}, controls if the mixin is applied before or" - "after already installed mixins." - "If unsupplied, this is the same as supplying \\scmc{\\#f}.") - - (drscheme:get/extend:get-unit-frame - (-> (subclass?/c drscheme:unit:frame%)) - () - - "Once this function is called, " - "@flink drscheme:get/extend:extend-unit-frame" - "raises an error, disallowing any more extensions.") - - - ; - ; - ; - ; ; - ; ; - ; ; - ; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; - ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; - ; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; - ; ; ; - ; ; ; ; ; - ; ;;;; ;;;; - ; - ; - ; - ; ;;; ; ; - ; ; - ; ; ; - ; ;;; ;;; ; ;; ;;;; ; ;; ; ; ; ; ; ;;; ;;;; ; ;;; ; ;; - ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; - ; ;;; ;;; ; ; ; ; ;; ; ;; ; ; ;;;;; ;; ; ;;; ; ; - ; ; - ; ; ; - ; ;;;; - - (drscheme:language-configuration:get-languages - (-> (listof (is-a?/c drscheme:language:language<%>))) - () - "This can only be called after all of the tools initialization phases have completed." - "" - "Returns the list of all of the languages installed in DrScheme.") - - (drscheme:language-configuration:add-language - ((and/c (is-a?/c drscheme:language:language<%>) language-object) - . -> . void?) - (language) - - "\\phase{2}" - "" - "Adds \\var{language} to the languages offerend by DrScheme.") - - (drscheme:language-configuration:get-settings-preferences-symbol - (-> symbol?) - () - "Returns the symbol that is used to store the user's language" - "settings. Use as an argument to either" - "@flink preferences:get" - "or" - "@flink preferences:set %" - ".") - - (drscheme:language-configuration:make-language-settings - ((or/c (is-a?/c drscheme:language:language<%>) language-object) - any/c - . -> . - drscheme:language-configuration:language-settings?) - (language settings) - - "This is the constructor for a record consisting of two" - "elements, a language and its settings. " - "" - "The settings is a language-specific record that holds a" - "value describing a parameterization of the language." - "" - "It has two selectors," - "@flink drscheme:language-configuration:language-settings-language" - "and " - "@flink drscheme:language-configuration:language-settings-settings %" - ", and a predicate," - "@flink drscheme:language-configuration:language-settings?") - - (drscheme:language-configuration:language-settings-settings - (drscheme:language-configuration:language-settings? - . -> . - any/c) - (ls) - "Extracts the settings field of a language-settings.") - - (drscheme:language-configuration:language-settings-language - (drscheme:language-configuration:language-settings? - . -> . - (or/c (is-a?/c drscheme:language:language<%>) language-object)) - (ls) - - "Extracts the language field of a language-settings.") - - (drscheme:language-configuration:language-settings? - (any/c . -> . boolean?) - (val) - - "Determines if the argument is a language-settings or not.") - - (drscheme:language-configuration:language-dialog - (opt-> - (boolean? drscheme:language-configuration:language-settings?) - ((or/c false/c (is-a?/c top-level-window<%>)) - boolean?) - (or/c false/c drscheme:language-configuration:language-settings?)) - ((show-welcome? language-settings-to-show) - ((parent #t) - (manuals? #f))) - "Opens the language configuration dialog." - "See also" - "@flink drscheme:language-configuration:fill-language-dialog %" - "." - "" - "The \\var{show-welcome?} argument determines if" - "if a ``Welcome to DrScheme'' message and some" - "natural language buttons are shown." - "" - "The \\var{language-settings-to-show} argument" - "must be some default language settings that the dialog" - "is initialized to." - "If unsure of a default, the currently set language" - "in the user's preferences can be obtained via:" - "\\begin{schemedisplay}" - "(preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))" - "\\end{schemedisplay}" - "" - "The \\var{parent} argument is used as the parent" - "to the dialog." - "" - "The \\var{manuals?} argument is passed to" - "@flink drscheme:language-configuration:fill-language-dialog %" - "." - "" - "The result if \\scheme|#f| when the user cancells the dialog, and" - "the selected language if they hit ok.") - - (drscheme:language-configuration:fill-language-dialog - (opt-> - ((is-a?/c vertical-panel%) - (is-a?/c area-container<%>) - drscheme:language-configuration:language-settings?) - ((or/c false/c (is-a?/c top-level-window<%>)) - boolean? - (-> symbol? void?)) - drscheme:language-configuration:language-settings?) - ((panel button-panel language-setting) - ((re-center #f) - (manuals? #f) - (ok-handler void))) - "This procedure accepts two parent panels and" - "fills them with the contents of the language dialog." - "It is used to include language configuration controls" - "in some larger context in another dialog." - "" - "The \\var{panel} argument is the main panel where the" - "language controls will be placed." - "The function adds buttons to the \\var{button-panel}" - "to revert a language to its default settings and to" - "show the details of a language." - "" - "The \\var{language-setting} is the default" - "language to show in the dialog." - "" - "The \\var{re-center} argument is used when the \\gui{Show Details}" - "button is clicked. If that argument is a \\iscmintf{top-level-window}," - "the \\gui{Show Details} callback will recenter the window each time" - "it is clicked. Otherwise, the argument is not used." - "" - "If \\var{manuals?} is \\scheme{#f} the usual language dialog (as seen" - "in the start up drscheme window and from the Choose Language dialog" - "created when drscheme is started up) is shown. If it isn't, the dialog" - "does not have the details and on the right-hand side shows the manual" - "ordering for the chosen language. This is used in Help Desk." - "" - "\\var{ok-handler} is a function that is in charge of interfacing the OK" - "button. It should accept a symbol message: \\scheme{'enable} and" - "\\scheme{'disable} to toggle the button, and \\scheme{'execute} to run" - "the desired operation. (The language selection dialog also uses an" - "internal \\scheme{'enable-sync} message.)") - - (drscheme:language:register-capability - (->r ([s symbol?] - [the-contract contract?] - [default the-contract]) - void?) - (s the-contract default) - "Registers a new capability with a default value for each language" - "and a contract on the values the capability might have." - "" - "By default, these capabilities are registered as DrScheme starts up:" - "\\begin{itemize}" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t)|" - "--- controls the visiblity of the check syntax button" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:language-menu-title (flat-contract string?) (string-constant scheme-menu-name))|" - " --- controls the name of the menu just to the right of the language menu (defaultly named ``Scheme'')" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:define-popup (or/c (cons/c string? string?) false/c) (cons \"(define\" \"(define ...)\"))|" - " --- specifies the prefix that the define popup should look for and what label it should have," - "or \\scheme|#f| if it should not appear at all." - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)|" - " --- determines if the insert fraction menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)|" - " --- determines if the insert lambda menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)|" - " --- determines if the insert large letters menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)|" - " --- determines if the insert image menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)|" - " --- determines if the insert comment box menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t)|" - " --- determines if the insert gui menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:slideshow-menu-item (flat-contract boolean?) #t)|" - " --- determines if the insert pict box menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-text-box (flat-contract boolean?) #t)|" - " --- determines if the insert text box menu item in the special menu is visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t)|" - " --- determines if the insert scheme box, insert scheme splice box, and the insert xml box menu item ins the special menu are visible" - "\\item \\scheme|(drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '()|" - " --- determines the list of words that are used when completing words in this language" - - "\\end{itemize}") - (drscheme:language:capability-registered? - (-> symbol? boolean?) - (s) - "Indicates if" - "@flink drscheme:language:register-capability" - "has been called with \\var{s}.") - (drscheme:language:get-capability-default - (->d (and/c symbol? drscheme:language:capability-registered?) - (λ (s) (drscheme:language:get-capability-contract s))) - (s) - "Returns the default for a particular capability.") - - - ; - ; - ; - ; ; - ; ; - ; ; - ; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; - ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; - ; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; - ; ; ; - ; ; ; ; ; - ; ;;;; ;;;; - - - (drscheme:language:add-snip-value - (opt-> ((-> any/c boolean?) - (-> any/c (is-a?/c snip%))) - ((-> any/c)) - void?) - ((test-value convert-value) - ((setup-thunk void))) - "Registers a handler to convert values into snips as they are printed in the REPL." - "" - "The \\var{test-snip} argument is called to determine if this handler can convert the value " - "and the \\var{convert-value} argument is called to build a snip. " - "The (optional) \\var{setup-thunk} is called just after the user's namespace and other " - "setings are built, but before any of the user's code is evaluated." - "" - "All three functions are called on the user's thread and with the user's settings.") - - (drscheme:language:extend-language-interface - (interface? - ((implementation?/c drscheme:language:language<%>) . ->d . (λ (%) (subclass?/c %))) - . -> . - void?) - (interface default-implementation) - - "\\phase{1}" - "" - "Each language added passed to" - "@flink drscheme:language-configuration:add-language" - "must implement \\var{interface}. " - "" - "The \\var{default-implementation} is a mixin" - "that provides a default implementation of " - "\\var{interface}. Languages that are unaware of" - "the specifics of \\var{extension} use" - "\\var{default-implementation} via" - "@flink drscheme:language:get-default-mixin %" - ".") - - (drscheme:language:get-default-mixin - (-> ((implementation?/c drscheme:language:language<%>) . ->d . (λ (%) (subclass?/c %)))) - () - - "\\phase{2}" - "" - "The result of this function is the composite of all of the " - "\\var{default-implementation} arguments passed" - "to" - "@flink drscheme:language:extend-language-interface %" - ".") - - (drscheme:language:get-language-extensions - (-> (listof interface?)) - () - "\\phase{2}" - "" - "Returns a list of the interfaces passed to" - "@flink drscheme:language:extend-language-interface %" - ".") - - (drscheme:language:put-executable - ((is-a?/c top-level-window<%>) - path? - (or/c boolean? (symbols 'launcher 'standalone 'distribution)) - boolean? - string? - . -> . (or/c false/c path?)) - (parent program-filename mode mred? title) - "Calls the MrEd primitive" - "@flink put-file" - "with arguments appropriate for creating an executable" - "from the file \\var{program-filename}. " - "" - "The arguments \\var{mred?} and \\var{mode} indicates" - "what type of executable this should be (and the dialog" - "may be slightly different on some platforms, depending" - "on these arguments). For historical reasons, \\scmc{\\#f}" - "is allowed for \\var{mode} as an alias for \\Symbol{launcher}, and" - "\\scmc{\\#t} is allowed for \\var{mode} as an alias for \\Symbol{stand-alone}." - "" - "The \\var{title} argument is used as the title to the primitive" - "@flink put-file" - "or" - "@flink get-directory" - "primitive.") - - (drscheme:language:create-executable-gui - ((or/c false/c (is-a?/c top-level-window<%>)) - (or/c false/c string?) - (or/c (λ (x) (eq? x #t)) (symbols 'launcher 'standalone 'distribution)) - (or/c (λ (x) (eq? x #t)) (symbols 'mzscheme 'mred)) - . -> . - (or/c false/c - (list/c (symbols 'no-show 'launcher 'stand-alone 'distribution) - (symbols 'no-show 'mred 'mzscheme) - string?))) - (parent program-name show-type show-base) - "Opens a dialog to prompt the user about their choice of executable." - "If \\var{show-type} is \\scmc{\\#t}, the user is prompted about" - "a choice of executable: stand-alone," - "launcher, or distribution; otherwise, the symbol determines the type." - "If \\var{show-base}" - "is \\scmc{\\#t}, the user is prompted about a choice of base" - "binary: mzscheme or mred; otherwise the symbol determines the base." - "" - "The \\var{program-name} argument is used to construct the default" - "executable name in a platform-specific manner." - "" - "The \\var{parent} argument is used for the parent of the dialog." - "" - "The result of this function is \\scmc{\\#f} if the user cancel's" - "the dialog and a list of three items indicating what options" - "they chose. If either \\var{show-type} or \\var{show-base}" - "was not \\scmc{\\#t}, the corresponding result will be \\scmc{'no-show}," - "otherwise it will indicate the user's choice.") - - (drscheme:language:create-module-based-stand-alone-executable - ((or/c path? string?) - (or/c path? string?) any/c any/c any/c boolean? boolean? - . -> . - void?) - (program-filename - executable-filename - module-language-spec - transformer-module-language-spec - init-code - gui? - use-copy?) - - "This procedure creates a stand-alone executable in the file" - "\\var{executable-filename} that runs the program" - "\\var{program-filename}. " - "" - "The arguments" - "\\var{module-language-spec} and" - "\\var{transformer-module-language-spec} specify the " - "settings of the initial namespace, both the transformer" - "portion and the regular portion. " - "" - "The \\var{init-code} argument is an s-expression representing" - "the code for a module. This module is expected to provide" - "the identifer \\rawscm{init-code}, bound to a procedure of no" - "arguments. That module is required and the \\var{init-code}" - "procedure is executed to initialize language-specific" - "settings before the code in \\var{program-filename} runs." - "" - "The \\var{gui?} argument indicates if a MrEd or MzScheme" - "stand-alone executable is created." - "" - "The \\var{use-copy?} argument indicates if the initial" - "namespace should be populated with" - "\\rawscm{namespace-require/copy} or" - "\\rawscm{namespace-require}. ") - - (drscheme:language:create-module-based-distribution - ((or/c path? string?) - (or/c path? string?) any/c any/c any/c boolean? boolean? - . -> . - void?) - (program-filename - distribution-filename - module-language-spec - transformer-module-language-spec - init-code - gui? - use-copy?) - - "Like" - "@flink drscheme:language:create-module-based-stand-alone-executable %" - ", but packages the stand-alone executable into a distribution.") - - (drscheme:language:create-distribution-for-executable - ((or/c path? string?) - boolean? - (-> path? void?) - . -> . - void?) - (distribution-filename - gui? - make-executable) - - "Creates a distribution where the given \\var{make-executable} procedure" - " creates the stand-alone executable to be distributed. " - "The \\var{make-executable} procedure is given the name of the " - "executable to create. The \\var{gui?} argument is needed in case the" - "executable's name (which \\rawscm{drscheme:language:create-distribution-for-executable} " - "must generate) depends on the type of executable. During the distribution-making " - "process, a progress dialog is shown to the user, and the user can click an " - "\\OnScreen{Abort} button that sends a break to the current thread.") - - (drscheme:language:create-module-based-launcher - ((or/c path? string?) (or/c path? string?) any/c any/c any/c boolean? boolean? - . -> . - void?) - (program-filename - executable-filename - module-language-spec - transformer-module-language-spec - init-code - gui? - use-copy?) - - "This procedure is identical to " - "@flink drscheme:language:create-module-based-stand-alone-executable %" - ", except that it creates a launcher instead of a" - "stand-alone executable.") - - (drscheme:language:text/pos-text - (drscheme:language:text/pos? . -> . (is-a?/c text%)) - (text/pos) - - "Selects the \\iscmclass{text} from a text/pos.") - - (drscheme:language:text/pos-start - (drscheme:language:text/pos? . -> . number?) - (text/pos) - - "Selects the starting position from a text/pos.") - - (drscheme:language:text/pos-end - (drscheme:language:text/pos? . -> . number?) - (text/pos) - - "Selects the ending position from a text/pos.") - - (drscheme:language:text/pos? - (any/c . -> . boolean?) - (val) - - "Returns \\scmc{\\#t} if \\var{val} is a text/pos, and \\scmc{\\#f}" - "otherwise.") - - (drscheme:language:make-text/pos - ((is-a?/c text%) number? number? - . -> . - drscheme:language:text/pos?) - (text start end) - - "Constructs a text/pos.") - - (drscheme:language:simple-settings-case-sensitive - (drscheme:language:simple-settings? . -> . boolean?) - (simple-settings) - - "Extracts the case-sensitive setting from a simple-settings.") - - (drscheme:language:simple-settings-printing-style - (drscheme:language:simple-settings? - . -> . - (symbols 'constructor 'quasiquote 'write 'current-print)) - (simple-settings) - - "Extracts the printing-style setting from a simple-settings.") - - (drscheme:language:simple-settings-fraction-style - (drscheme:language:simple-settings? - . -> . - (symbols 'mixed-fraction - 'mixed-fraction-e - 'repeating-decimal - 'repeating-decimal-e)) - (simple-settings) - - "Extracts the fraction-style setting from a simple-settings.") - - (drscheme:language:simple-settings-show-sharing - (drscheme:language:simple-settings? - . -> . - boolean?) - (simple-settings) - - "Extracts the show-sharing setting from a simple-settings.") - - (drscheme:language:simple-settings-insert-newlines - (drscheme:language:simple-settings? - . -> . - boolean?) - (simple-settings) - - "Extracts the insert-newline setting from a simple-settings.") - - (drscheme:language:simple-settings-annotations - (drscheme:language:simple-settings? - . -> . - (symbols 'none 'debug 'debug/profile 'test-coverage)) - (simple-settings) - - "Extracts the debugging setting from a simple-settings.") - - (drscheme:language:simple-settings? - (any/c . -> . boolean?) - (val) - - "Determines if \\var{val} is a simple-settings.") - - (drscheme:language:make-simple-settings - (boolean? - (symbols 'constructor 'quasiquote 'write 'current-print) - (symbols 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e) - boolean? - boolean? - (symbols 'none 'debug 'debug/profile 'test-coverage) - . -> . - drscheme:language:simple-settings?) - (case-sensitive - printing-style - fraction-style - show-sharing - insert-newlines - annotations) - - "Constructs a simple settings.") - - (drscheme:language:simple-settings->vector - (drscheme:language:simple-settings? . -> . vector?) - (simple-settings) - - "Constructs a vector whose elements are the fields of \\var{simple-settings}.") - - - - - ; - ; - ; - ; ; ; ; - ; ; ; - ; ; ; - ; ; ;;; ; ;; ;; ; ;;; ; ;; ; - ; ; ; ; ;; ; ; ;; ; ; ;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ; ;; ; ; - ; ; ;;;;; ; ; ;; ; ;;; ; ;; ; - ; ; ; - ; ; ; ; - ; ;;;; ;; - - - (define language-object - - (object-contract - (config-panel ((is-a?/c area-container<%>) - . -> . - (case-> (any/c . -> . void?) (-> any/c)))) - (create-executable (any/c - (or/c (is-a?/c dialog%) (is-a?/c frame%)) - path? - . -> . - void?)) - (default-settings (-> any/c)) - (default-settings? (any/c . -> . boolean?)) - (order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?))) - (front-end/complete-program (input-port? - any/c - . -> . - (-> any/c))) - (front-end/interaction (input-port? - any/c - . -> . - (-> any/c))) - (get-language-name (-> string?)) - (get-language-numbers (-> (cons/c number? (listof number?)))) - (get-language-position (-> (cons/c string? (listof string?)))) - (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) - (get-comment-character (-> (values string? char?))) - (get-style-delta (-> (or/c false/c - (is-a?/c style-delta%) - (listof (list/c (is-a?/c style-delta%) number? number?))))) - (marshall-settings (any/c . -> . printable/c)) - (on-execute (any/c ((-> any) . -> . any) . -> . any)) - (render-value (any/c - any/c - output-port? - . -> . - void?)) - (render-value/format (any/c - any/c - output-port? - (or/c number? (symbols 'infinity)) - . -> . - any)) - (unmarshall-settings (printable/c . -> . any)) - (capability-value - (->d (and/c symbol? drscheme:language:capability-registered?) - (λ (cap-name) (drscheme:language:get-capability-contract cap-name)))) - - ) - #; - (is-a?/c drscheme:language:language<%>))) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index e99ef9dab8..44f7e8105e 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -1,542 +1,575 @@ #lang scheme/unit - (require (lib "getinfo.ss" "setup") - mred - mzlib/class - mzlib/list - "drsig.ss" - mzlib/contract - "tool-contracts.ss" - framework - string-constants) - - (import [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:get/extend: drscheme:get/extend^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:language-configuration: drscheme:language-configuration^] - [prefix drscheme:help-desk: drscheme:help-desk^] - [prefix drscheme:init: drscheme:init^] - [prefix drscheme:debug: drscheme:debug^] - [prefix drscheme:eval: drscheme:eval^] - [prefix drscheme:modes: drscheme:modes^]) - (export drscheme:tools^) - ;; An installed-tool is - ;; (make-installed-tool directory-record module-spec string/#f string/#f string/#f string/#f) - (define-struct installed-tool (dir spec bitmap name url)) +(require (lib "getinfo.ss" "setup") + mred + scheme/class + scheme/list + "drsig.ss" + "language-object-contract.ss" + scheme/contract + framework + string-constants + scheme/runtime-path) - ;; installed-tools : (list-of installed-tool) - (define installed-tools null) - - ;; successful-tool = (make-successful-tool module-spec - ;; (union #f (instanceof bitmap%)) - ;; (union #f string) - ;; (union #f string)) - (define-struct successful-tool (spec bitmap name url)) +(require (for-syntax scheme/base scheme/match)) - ;; successful-tools : (listof successful-tool) - (define successful-tools null) - - ;; get-successful-tools : -> (listof successful-tool) - (define (get-successful-tools) successful-tools) - - ;; successfully-loaded-tool = - ;; (make-successfully-loaded-tool - ;; module-spec (union #f (instanceof bitmap%)) (union #f string) (union #f string) - ;; (-> void) (-> void)) - (define-struct successfully-loaded-tool (spec bitmap name url phase1 phase2)) - - ;; successfully-loaded-tools : (listof successfully-loaded-tool) - ;; this list contains the tools that successfully were loaded - ;; it is updated in load/invoke-tool. - (define successfully-loaded-tools null) - - ;; load/invoke-all-tools : -> void - (define (load/invoke-all-tools phase1-extras phase2-extras) - (rescan-installed-tools!) - (set! current-phase 'loading-tools) - (let ([candidate-tools (filter candidate-tool? installed-tools)]) - (for-each load/invoke-tool candidate-tools) - (run-phases phase1-extras phase2-extras))) +(import [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:get/extend: drscheme:get/extend^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:language-configuration: drscheme:language-configuration^] + [prefix drscheme:help-desk: drscheme:help-desk^] + [prefix drscheme:init: drscheme:init^] + [prefix drscheme:debug: drscheme:debug^] + [prefix drscheme:eval: drscheme:eval^] + [prefix drscheme:modes: drscheme:modes^]) +(export drscheme:tools^) - ;; rescan-installed-tools! : -> void - (define (rescan-installed-tools!) - (set! installed-tools (all-installed-tools))) - - ;; all-installed-tools : -> (list-of installed-tool) - (define (all-installed-tools) - (apply append - (map installed-tools-for-directory - (all-tool-directories)))) - - ;; all-tool-directories : -> (list-of directory-record) - (define (all-tool-directories) - (find-relevant-directory-records '(tools tool-icons tool-names tool-urls))) - - ;; installed-tools-for-directory : directory-record -> (list-of installed-tool) - (define (installed-tools-for-directory coll-dir) - (let ([table (get-info/full (directory-record-path coll-dir))]) - (if table - (let* ([tools (table 'tools (lambda () null))] - [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))] - [tool-names (table 'tool-names (lambda () (map (lambda (x) #f) tools)))] - [tool-urls (table 'tool-urls (lambda () (map (lambda (x) #f) tools)))]) - (unless (= (length tools) (length tool-icons)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-icons-same-length) - coll-dir tools tool-icons) - #f - '(ok stop)) - (set! tool-icons (map (lambda (x) #f) tools))) - (unless (= (length tools) (length tool-names)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-names-same-length) - coll-dir tools tool-names) - #f - '(ok stop)) - (set! tool-names (map (lambda (x) #f) tools))) - (unless (= (length tools) (length tool-urls)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-urls-same-length) - coll-dir tools tool-urls) - #f - '(ok stop)) - (set! tool-urls (map (lambda (x) #f) tools))) - (map (lambda (t i n u) (make-installed-tool coll-dir t i n u)) - tools tool-icons tool-names tool-urls)) - null))) - - ;; candidate-tool? : installed-tool -> boolean - ;; Predicate for tools selected for execution in this - ;; run of DrScheme (depending on env variables and preferences) - (define candidate-tool? - (cond - [(getenv "PLTNOTOOLS") - (printf "PLTNOTOOLS: skipping tools\n") - (lambda (it) #f)] - [(getenv "PLTONLYTOOL") => - (lambda (onlys) - (let* ([allowed (let ([exp (read (open-input-string onlys))]) - (cond - [(symbol? exp) (list exp)] - [(pair? exp) exp] - [else '()]))] - [directory-ok? (lambda (x) - (let-values ([(base name dir) (split-path x)]) - (memq (string->symbol (path->string name)) - allowed)))]) - (printf "PLTONLYTOOL: only loading ~s\n" allowed) - (lambda (it) - (directory-ok? - (directory-record-path - (installed-tool-dir it))))))] - [else - (lambda (it) - (eq? (or (get-tool-configuration it) - (default-tool-configuration it)) - 'load))])) +;; An installed-tool is +;; (make-installed-tool directory-record module-spec string/#f string/#f string/#f string/#f) +(define-struct installed-tool (dir spec bitmap name url)) - ;; get-tool-configuration : installed-tool -> symbol/#f - ;; Get tool configuration preference or #f if no preference set. - (define (get-tool-configuration it) - (let ([p (assoc (installed-tool->key it) (toolspref))]) - (and p (cadr p)))) - - ;; default-tool-configuration : installed-tool -> (union 'load 'skip) - (define (default-tool-configuration it) - (preferences:get 'drscheme:default-tools-configuration)) +;; installed-tools : (list-of installed-tool) +(define installed-tools null) - (define toolspref - (case-lambda - [() (preferences:get 'drscheme:tools-configuration)] - [(v) (preferences:set 'drscheme:tools-configuration v)])) +;; successful-tool = (make-successful-tool module-spec +;; (union #f (instanceof bitmap%)) +;; (union #f string) +;; (union #f string)) +(define-struct successful-tool (spec bitmap name url)) - (define (installed-tool->key it) - (list (directory-record-spec (installed-tool-dir it)) - (installed-tool-spec it))) +;; successful-tools : (listof successful-tool) +(define successful-tools null) - (define (installed-tool-full-path it) - (apply build-path - (directory-record-path (installed-tool-dir it)) - (let ([path-parts (installed-tool-spec it)]) - (cond [(list? path-parts) - (append (cdr path-parts) (list (car path-parts)))] - [else (list path-parts)])))) +;; get-successful-tools : -> (listof successful-tool) +(define (get-successful-tools) successful-tools) - (define (installed-tool->module-spec it) - (let* ([dirrec (installed-tool-dir it)] - [key (directory-record-spec dirrec)] - [maj (directory-record-maj dirrec)] - [min (directory-record-min dirrec)] - [parts (let ([parts0 (installed-tool-spec it)]) - (if (list? parts0) - parts0 - (list parts0)))] - [file (car parts)] - [rest-parts (cdr parts)]) - (case (car key) - ((lib) - `(lib ,(string-append - (apply string-append - (map (lambda (s) - (string-append s "/")) - (append (cdr key) rest-parts))) - file))) - ((planet) - `(planet ,file (,@(cdr key) ,maj ,min) ,@rest-parts))))) +;; successfully-loaded-tool = +;; (make-successfully-loaded-tool +;; module-spec (union #f (instanceof bitmap%)) (union #f string) (union #f string) +;; (-> void) (-> void)) +(define-struct successfully-loaded-tool (spec bitmap name url phase1 phase2)) - ;; installed-tool-is-loaded : installed-tool -> boolean - (define (installed-tool-is-loaded? it) - (let ([path (installed-tool-full-path it)]) - (ormap (lambda (st) (equal? path (successful-tool-spec st))) - (get-successful-tools)))) - +;; successfully-loaded-tools : (listof successfully-loaded-tool) +;; this list contains the tools that successfully were loaded +;; it is updated in load/invoke-tool. +(define successfully-loaded-tools null) - ;;; ;; ; ; ;; - ; ; ; ; - ; ; ; ; - ; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;; - ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; - ;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;; - ; +;; load/invoke-all-tools : -> void +(define (load/invoke-all-tools phase1-extras phase2-extras) + (rescan-installed-tools!) + (set! current-phase 'loading-tools) + (let ([candidate-tools (filter candidate-tool? installed-tools)]) + (for-each load/invoke-tool candidate-tools) + (run-phases phase1-extras phase2-extras))) + +;; rescan-installed-tools! : -> void +(define (rescan-installed-tools!) + (set! installed-tools (all-installed-tools))) + +;; all-installed-tools : -> (list-of installed-tool) +(define (all-installed-tools) + (apply append + (map installed-tools-for-directory + (all-tool-directories)))) + +;; all-tool-directories : -> (list-of directory-record) +(define (all-tool-directories) + (find-relevant-directory-records '(tools tool-icons tool-names tool-urls))) + +;; installed-tools-for-directory : directory-record -> (list-of installed-tool) +(define (installed-tools-for-directory coll-dir) + (let ([table (get-info/full (directory-record-path coll-dir))]) + (if table + (let* ([tools (table 'tools (lambda () null))] + [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))] + [tool-names (table 'tool-names (lambda () (map (lambda (x) #f) tools)))] + [tool-urls (table 'tool-urls (lambda () (map (lambda (x) #f) tools)))]) + (unless (= (length tools) (length tool-icons)) + (message-box (string-constant drscheme) + (format (string-constant tool-tool-icons-same-length) + coll-dir tools tool-icons) + #f + '(ok stop)) + (set! tool-icons (map (lambda (x) #f) tools))) + (unless (= (length tools) (length tool-names)) + (message-box (string-constant drscheme) + (format (string-constant tool-tool-names-same-length) + coll-dir tools tool-names) + #f + '(ok stop)) + (set! tool-names (map (lambda (x) #f) tools))) + (unless (= (length tools) (length tool-urls)) + (message-box (string-constant drscheme) + (format (string-constant tool-tool-urls-same-length) + coll-dir tools tool-urls) + #f + '(ok stop)) + (set! tool-urls (map (lambda (x) #f) tools))) + (map (lambda (t i n u) (make-installed-tool coll-dir t i n u)) + tools tool-icons tool-names tool-urls)) + null))) + +;; candidate-tool? : installed-tool -> boolean +;; Predicate for tools selected for execution in this +;; run of DrScheme (depending on env variables and preferences) +(define candidate-tool? + (cond + [(getenv "PLTNOTOOLS") + (printf "PLTNOTOOLS: skipping tools\n") + (lambda (it) #f)] + [(getenv "PLTONLYTOOL") => + (lambda (onlys) + (let* ([allowed (let ([exp (read (open-input-string onlys))]) + (cond + [(symbol? exp) (list exp)] + [(pair? exp) exp] + [else '()]))] + [directory-ok? (lambda (x) + (let-values ([(base name dir) (split-path x)]) + (memq (string->symbol (path->string name)) + allowed)))]) + (printf "PLTONLYTOOL: only loading ~s\n" allowed) + (lambda (it) + (directory-ok? + (directory-record-path + (installed-tool-dir it))))))] + [else + (lambda (it) + (eq? (or (get-tool-configuration it) + (default-tool-configuration it)) + 'load))])) + +;; get-tool-configuration : installed-tool -> symbol/#f +;; Get tool configuration preference or #f if no preference set. +(define (get-tool-configuration it) + (let ([p (assoc (installed-tool->key it) (toolspref))]) + (and p (cadr p)))) + +;; default-tool-configuration : installed-tool -> (union 'load 'skip) +(define (default-tool-configuration it) + (preferences:get 'drscheme:default-tools-configuration)) + +(define toolspref + (case-lambda + [() (preferences:get 'drscheme:tools-configuration)] + [(v) (preferences:set 'drscheme:tools-configuration v)])) + +(define (installed-tool->key it) + (list (directory-record-spec (installed-tool-dir it)) + (installed-tool-spec it))) + +(define (installed-tool-full-path it) + (apply build-path + (directory-record-path (installed-tool-dir it)) + (let ([path-parts (installed-tool-spec it)]) + (cond [(list? path-parts) + (append (cdr path-parts) (list (car path-parts)))] + [else (list path-parts)])))) + +(define (installed-tool->module-spec it) + (let* ([dirrec (installed-tool-dir it)] + [key (directory-record-spec dirrec)] + [maj (directory-record-maj dirrec)] + [min (directory-record-min dirrec)] + [parts (let ([parts0 (installed-tool-spec it)]) + (if (list? parts0) + parts0 + (list parts0)))] + [file (car parts)] + [rest-parts (cdr parts)]) + (case (car key) + ((lib) + `(lib ,(string-append + (apply string-append + (map (lambda (s) + (string-append s "/")) + (append (cdr key) rest-parts))) + file))) + ((planet) + `(planet ,file (,@(cdr key) ,maj ,min) ,@rest-parts))))) + +;; installed-tool-is-loaded : installed-tool -> boolean +(define (installed-tool-is-loaded? it) + (let ([path (installed-tool-full-path it)]) + (ormap (lambda (st) (equal? path (successful-tool-spec st))) + (get-successful-tools)))) - ;; load/invoke-tool : installed-tool -> void - (define (load/invoke-tool it) - (load/invoke-tool* (directory-record-path (installed-tool-dir it)) - (installed-tool-spec it) - (installed-tool-bitmap it) - (installed-tool-name it) - (installed-tool-url it))) - - ;; load/invoke-tool* : path - ;; (listof string[sub-collection-name]) - ;; (union #f (cons string[filename] (listof string[collection-name]))) - ;; (union #f string) - ;; (union #f string) - ;; -> void - ;; `coll' is a collection to load the tool from - ;; `in-path' is the `coll'-relative collection-path spec for the tool module file - ;; `icon-spec' is the collection-path spec for the tool's icon, if there is one. - ;; `name' is the name of the tool (only used in about box) - (define (load/invoke-tool* coll-dir in-path icon-spec name tool-url) - (let* ([icon-path - (cond - [(string? icon-spec) - (build-path coll-dir icon-spec)] - [(and (list? icon-spec) - (andmap string? icon-spec)) - (build-path (apply collection-path (cdr icon-spec)) (car icon-spec))] - [else #f])] - [tool-bitmap - (and icon-path - (install-tool-bitmap name icon-path))]) - (let/ec k - (unless (or (string? in-path) - (and (list? in-path) - (not (null? in-path)) - (andmap string? in-path))) - (message-box (string-constant drscheme) - (format (string-constant invalid-tool-spec) - coll-dir in-path) - #f - '(ok stop)) - (k (void))) - (let* ([tool-path - (if (string? in-path) - (build-path coll-dir in-path) - (apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))] - [unit - (with-handlers ([exn:fail? - (lambda (x) - (show-error - (format (string-constant error-invoking-tool-title) - coll-dir in-path) - x) - (k (void)))]) - (dynamic-require tool-path 'tool@))]) - (with-handlers ([exn:fail? - (lambda (x) - (show-error - (format (string-constant error-invoking-tool-title) - coll-dir in-path) - x))]) - (let-values ([(phase1-thunk phase2-thunk) - (invoke-tool unit (string->symbol (or name (path->string coll-dir))))]) - (set! successfully-loaded-tools - (cons (make-successfully-loaded-tool - tool-path - tool-bitmap - name - tool-url - phase1-thunk - phase2-thunk) - successfully-loaded-tools)))))))) - - ;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) - ;; invokes the tools and returns the two phase thunks. - (define (invoke-tool unit tool-name) - (define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^)) - (wrap-tool-inputs - (let () - (define-values/invoke-unit unit@ - (import drscheme:tool^) (export drscheme:tool-exports^)) - (values phase1 phase2)) - tool-name)) - - ;; show-error : string (union exn TST) -> void - (define (show-error title x) - (parameterize ([drscheme:init:error-display-handler-message-box-title - title]) - ((error-display-handler) - (if (exn? x) - (format "~a\n\n~a" title (exn-message x)) - (format "~a\n\nuncaught exception: ~s" title x)) - x))) - - - ;; install-tool-bitmap : string path -> bitmap - ;; adds the tool's bitmap to the splash screen - (define (install-tool-bitmap name bitmap-path) +;;; ;; ; ; ;; +; ; ; ; +; ; ; ; +; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;; +; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; +; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; +;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;; +; + + +;; load/invoke-tool : installed-tool -> void +(define (load/invoke-tool it) + (load/invoke-tool* (directory-record-path (installed-tool-dir it)) + (installed-tool-spec it) + (installed-tool-bitmap it) + (installed-tool-name it) + (installed-tool-url it))) + +;; load/invoke-tool* : path +;; (listof string[sub-collection-name]) +;; (union #f (cons string[filename] (listof string[collection-name]))) +;; (union #f string) +;; (union #f string) +;; -> void +;; `coll' is a collection to load the tool from +;; `in-path' is the `coll'-relative collection-path spec for the tool module file +;; `icon-spec' is the collection-path spec for the tool's icon, if there is one. +;; `name' is the name of the tool (only used in about box) +(define (load/invoke-tool* coll-dir in-path icon-spec name tool-url) + (let* ([icon-path + (cond + [(string? icon-spec) + (build-path coll-dir icon-spec)] + [(and (list? icon-spec) + (andmap string? icon-spec)) + (build-path (apply collection-path (cdr icon-spec)) (car icon-spec))] + [else #f])] + [tool-bitmap + (and icon-path + (install-tool-bitmap name icon-path))]) (let/ec k - (let ([bitmap - (with-handlers ([exn:fail:filesystem? (lambda (x) (k (void)))]) - (make-object bitmap% bitmap-path 'unknown/mask))]) - (unless (and (is-a? bitmap bitmap%) - (send bitmap ok?)) - (k #f)) - (let ([splash-eventspace ((dynamic-require '(lib "framework/splash.ss") 'get-splash-eventspace))] - [splash-bitmap ((dynamic-require '(lib "framework/splash.ss") 'get-splash-bitmap))] - [splash-canvas ((dynamic-require '(lib "framework/splash.ss") 'get-splash-canvas))]) - - (unless (and (eventspace? splash-eventspace) - (is-a? splash-bitmap bitmap%) - (send splash-bitmap ok?) - (is-a? splash-canvas canvas%)) - (k (void))) - - (parameterize ([current-eventspace splash-eventspace]) - (queue-callback - (lambda () - (let ([bdc (make-object bitmap-dc%)] - [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))]) - - ;; truncate/expand the bitmap, if necessary - (unless (and (= tool-bitmap-size (send bitmap get-width)) - (= tool-bitmap-size (send bitmap get-height))) - (let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)]) - (send bdc set-bitmap new-b) - (send bdc clear) - (send bdc draw-bitmap-section splash-bitmap - 0 0 - tool-bitmap-x translated-tool-bitmap-y - tool-bitmap-size tool-bitmap-size) - (send bdc draw-bitmap bitmap - (max 0 (- (/ tool-bitmap-size 2) - (/ (send bitmap get-width) 2))) - (max 0 (- (/ tool-bitmap-size 2) - (/ (send bitmap get-height) 2))) - 'solid - (make-object color% "black") - (send bitmap get-loaded-mask)) - (send bdc set-bitmap #f) - (set! bitmap new-b))) - - ((dynamic-require '(lib "framework/splash.ss") 'add-splash-icon) - bitmap tool-bitmap-x translated-tool-bitmap-y) - (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap)) - (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) - (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap)) - (set! tool-bitmap-x tool-bitmap-gap)) - (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) - (set! tool-bitmap-y tool-bitmap-gap))))))) - bitmap))) - - (define tool-bitmap-gap 3) - (define tool-bitmap-x tool-bitmap-gap) - (define tool-bitmap-y tool-bitmap-gap) - (define tool-bitmap-size 32) - - - - ;; ; ;;; - ; ;;; ;;; ; ; - ; ; ; ; ; ; - ; ;;; ; ;; ;;;; ;;; ;;; ; ; ; ; - ; ; ;; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ;;;; ;;; ;;;;; ; ;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; - ;;;; ;;; ;;; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;;;; - ; - ; - ;;; - - - ;; run-phases : -> void - (define (run-phases phase1-extras phase2-extras) - (let* ([after-phase1 (run-one-phase 'phase1 - (string-constant tool-error-phase1) - successfully-loaded-tool-phase1 - successfully-loaded-tools - phase1-extras)] - [after-phase2 (run-one-phase 'phase2 - (string-constant tool-error-phase2) - successfully-loaded-tool-phase2 - after-phase1 - phase2-extras)]) - (set! current-phase 'init-complete) - (set! successful-tools - (map (lambda (x) (make-successful-tool - (successfully-loaded-tool-spec x) - (successfully-loaded-tool-bitmap x) - (successfully-loaded-tool-name x) - (successfully-loaded-tool-url x))) - after-phase2)))) - - ;; run-one-phase : string - ;; (successfully-loaded-tool -> (-> void)) - ;; (listof successfully-loaded-tool) - ;; (-> void) - ;; -> (listof successfully-loaded-tool) - ;; filters out the tools that raise exceptions during the phase. - ;; extras is the thunk for DrScheme init stuff on this phase. - (define (run-one-phase _the-phase err-fmt selector tools extras) - (set! current-phase _the-phase) - (extras) - (let loop ([tools tools]) - (cond - [(null? tools) null] - [else - (let ([tool (car tools)]) - (let ([phase-thunk (selector tool)]) - (with-handlers ([exn:fail? - (lambda (exn) - (show-error - (format err-fmt - (successfully-loaded-tool-spec tool) - (successfully-loaded-tool-name tool)) - exn) - (loop (cdr tools)))]) - (phase-thunk) - (cons tool (loop (cdr tools))))))]))) - - ;; current-phase : (union #f 'loading-tools 'phase1 'phase2 'init-complete) - (define current-phase #f) - (define (get-current-phase) current-phase) - - ;; only-in-phase : sym (union #f 'loading-tools 'phase1 'phase2 'init-complete) ... -> void - ;; raises an error unless one of `phases' is the current phase - (define (only-in-phase func . phases) - (unless (memq current-phase phases) - (error func "can only be called in phase: ~a" - (apply string-append - (map (lambda (x) (format "~e " x)) - (filter (lambda (x) x) phases)))))) + (unless (or (string? in-path) + (and (list? in-path) + (not (null? in-path)) + (andmap string? in-path))) + (message-box (string-constant drscheme) + (format (string-constant invalid-tool-spec) + coll-dir in-path) + #f + '(ok stop)) + (k (void))) + (let* ([tool-path + (if (string? in-path) + (build-path coll-dir in-path) + (apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))] + [unit + (with-handlers ([exn:fail? + (lambda (x) + (show-error + (format (string-constant error-invoking-tool-title) + coll-dir in-path) + x) + (k (void)))]) + (dynamic-require tool-path 'tool@))]) + (with-handlers ([exn:fail? + (lambda (x) + (show-error + (format (string-constant error-invoking-tool-title) + coll-dir in-path) + x))]) + (let-values ([(phase1-thunk phase2-thunk) + (invoke-tool unit (string->symbol (or name (path->string coll-dir))))]) + (set! successfully-loaded-tools + (cons (make-successfully-loaded-tool + tool-path + tool-bitmap + name + tool-url + phase1-thunk + phase2-thunk) + successfully-loaded-tools)))))))) - ;; Preferences GUI +(define-syntax (wrap-tool-inputs stx) + (syntax-case stx () + [(_ body tool-name) + (let () + (define full-sexp + (call-with-input-file (build-path (collection-path "drscheme") "tool-lib.ss") + (λ (port) + (parameterize ([read-accept-reader #t]) + (read port))))) + + (let loop ([sexp full-sexp]) + (match sexp + [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...) + #`(let #,(map (λ (name ctc) + (with-syntax ([name (datum->syntax #'tool-name name)] + [ctc (datum->syntax #'tool-name ctc)]) + #`[name (contract (let ([name ctc]) name) + name + 'drscheme + tool-name + (quote-syntax name))])) + name + ctc) + body)] + [`(,a . ,b) + (loop b)] + [`() + (error 'tcl.ss "did not find provide/doc" full-sexp)])))])) - (define load-action "Load the tool") - (define skip-action "Skip the tool") - - (define (add-prefs-panel) - (preferences:add-panel - "Tools" - (lambda (parent) - (define main (new vertical-panel% (parent parent))) - (define advisory - (new message% - (parent main) - (label "Changes to tool configuration will take effect the next time you start DrScheme."))) - (define listing - (new list-box% - (parent main) - (label "Installed tools") - (choices null) - (callback (lambda _ (on-select-tool))))) - (define info - (new vertical-panel% - (parent main) - (style '(border)) - (stretchable-height #f))) - (define location - (new text-field% - (parent info) - (label "Tool: "))) - (define location-editor (send location get-editor)) - (define configuration - (new radio-box% - (label "Load the tool when DrScheme starts?") - (parent info) - (choices (list load-action skip-action #| default-action |#)) - (callback (lambda _ (on-select-policy))))) +;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) +;; invokes the tools and returns the two phase thunks. +(define (invoke-tool unit tool-name) + (define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^)) + (wrap-tool-inputs + (let () + (define-values/invoke-unit unit@ + (import drscheme:tool^) (export drscheme:tool-exports^)) + (values phase1 phase2)) + tool-name)) - (define (populate-listing!) - (send listing clear) - (for-each - (lambda (entry+it) - (send listing append - (car entry+it) - (cdr entry+it))) - (sort (map (lambda (it) (cons (tool-list-entry it) it)) - installed-tools) - (lambda (a b) - (stringmodule-spec it)))]) - (if (installed-tool-is-loaded? it) - (string-append name " (loaded)") - name))) - (define (on-select-tool) - (let ([it (get-selected-tool)]) - (send* location-editor - (begin-edit-sequence) - (lock #f) - (erase) - (insert - (if it - (format "~s" (installed-tool->module-spec it)) - "")) - (lock #t) - (end-edit-sequence)) - (send configuration set-selection - (case (and it (get-tool-configuration it)) - ((load) 0) - ((skip) 1) - ((#f) 0))) ;; XXX (or 2, if default is an option) - (send configuration enable (and it #t)) - (void))) - (define (on-select-policy) - (let ([it (get-selected-tool)] - [policy - (case (send configuration get-selection) - ((0) 'load) - ((1) 'skip))]) - (when it - (let ([key (installed-tool->key it)]) - (case policy - ((load) - (toolspref (cons (list key 'load) - (let ([ts (toolspref)]) - (remove (assoc key ts) ts))))) - ((skip) - (toolspref (cons (list key 'skip) - (let ([ts (toolspref)]) - (remove (assoc key ts) ts))))) - ((#f) - (toolspref (let ([ts (toolspref)]) - (remove (assoc key ts) ts)))))))) - (void)) - (define (get-selected-tool) - (let ([index (send listing get-selection)]) - (and index (send listing get-data index)))) - (populate-listing!) - (send location-editor lock #t) - main))) +;; show-error : string (union exn TST) -> void +(define (show-error title x) + (parameterize ([drscheme:init:error-display-handler-message-box-title + title]) + ((error-display-handler) + (if (exn? x) + (format "~a\n\n~a" title (exn-message x)) + (format "~a\n\nuncaught exception: ~s" title x)) + x))) + + +;; install-tool-bitmap : string path -> bitmap +;; adds the tool's bitmap to the splash screen +(define (install-tool-bitmap name bitmap-path) + (let/ec k + (let ([bitmap + (with-handlers ([exn:fail:filesystem? (lambda (x) (k (void)))]) + (make-object bitmap% bitmap-path 'unknown/mask))]) + (unless (and (is-a? bitmap bitmap%) + (send bitmap ok?)) + (k #f)) + (let ([splash-eventspace ((dynamic-require '(lib "framework/splash.ss") 'get-splash-eventspace))] + [splash-bitmap ((dynamic-require '(lib "framework/splash.ss") 'get-splash-bitmap))] + [splash-canvas ((dynamic-require '(lib "framework/splash.ss") 'get-splash-canvas))]) + + (unless (and (eventspace? splash-eventspace) + (is-a? splash-bitmap bitmap%) + (send splash-bitmap ok?) + (is-a? splash-canvas canvas%)) + (k (void))) + + (parameterize ([current-eventspace splash-eventspace]) + (queue-callback + (lambda () + (let ([bdc (make-object bitmap-dc%)] + [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))]) + + ;; truncate/expand the bitmap, if necessary + (unless (and (= tool-bitmap-size (send bitmap get-width)) + (= tool-bitmap-size (send bitmap get-height))) + (let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)]) + (send bdc set-bitmap new-b) + (send bdc clear) + (send bdc draw-bitmap-section splash-bitmap + 0 0 + tool-bitmap-x translated-tool-bitmap-y + tool-bitmap-size tool-bitmap-size) + (send bdc draw-bitmap bitmap + (max 0 (- (/ tool-bitmap-size 2) + (/ (send bitmap get-width) 2))) + (max 0 (- (/ tool-bitmap-size 2) + (/ (send bitmap get-height) 2))) + 'solid + (make-object color% "black") + (send bitmap get-loaded-mask)) + (send bdc set-bitmap #f) + (set! bitmap new-b))) + + ((dynamic-require '(lib "framework/splash.ss") 'add-splash-icon) + bitmap tool-bitmap-x translated-tool-bitmap-y) + (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap)) + (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) + (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap)) + (set! tool-bitmap-x tool-bitmap-gap)) + (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) + (set! tool-bitmap-y tool-bitmap-gap))))))) + bitmap))) + +(define tool-bitmap-gap 3) +(define tool-bitmap-x tool-bitmap-gap) +(define tool-bitmap-y tool-bitmap-gap) +(define tool-bitmap-size 32) + + + +;; ; ;;; +; ;;; ;;; ; ; +; ; ; ; ; ; +; ;;; ; ;; ;;;; ;;; ;;; ; ; ; ; +; ; ;; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;;;; ;;; ;;;;; ; ;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +;;;; ;;; ;;; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;;;; +; +; +;;; + + +;; run-phases : -> void +(define (run-phases phase1-extras phase2-extras) + (let* ([after-phase1 (run-one-phase 'phase1 + (string-constant tool-error-phase1) + successfully-loaded-tool-phase1 + successfully-loaded-tools + phase1-extras)] + [after-phase2 (run-one-phase 'phase2 + (string-constant tool-error-phase2) + successfully-loaded-tool-phase2 + after-phase1 + phase2-extras)]) + (set! current-phase 'init-complete) + (set! successful-tools + (map (lambda (x) (make-successful-tool + (successfully-loaded-tool-spec x) + (successfully-loaded-tool-bitmap x) + (successfully-loaded-tool-name x) + (successfully-loaded-tool-url x))) + after-phase2)))) + +;; run-one-phase : string +;; (successfully-loaded-tool -> (-> void)) +;; (listof successfully-loaded-tool) +;; (-> void) +;; -> (listof successfully-loaded-tool) +;; filters out the tools that raise exceptions during the phase. +;; extras is the thunk for DrScheme init stuff on this phase. +(define (run-one-phase _the-phase err-fmt selector tools extras) + (set! current-phase _the-phase) + (extras) + (let loop ([tools tools]) + (cond + [(null? tools) null] + [else + (let ([tool (car tools)]) + (let ([phase-thunk (selector tool)]) + (with-handlers ([exn:fail? + (lambda (exn) + (show-error + (format err-fmt + (successfully-loaded-tool-spec tool) + (successfully-loaded-tool-name tool)) + exn) + (loop (cdr tools)))]) + (phase-thunk) + (cons tool (loop (cdr tools))))))]))) + +;; current-phase : (union #f 'loading-tools 'phase1 'phase2 'init-complete) +(define current-phase #f) +(define (get-current-phase) current-phase) + +;; only-in-phase : sym (union #f 'loading-tools 'phase1 'phase2 'init-complete) ... -> void +;; raises an error unless one of `phases' is the current phase +(define (only-in-phase func . phases) + (unless (memq current-phase phases) + (error func "can only be called in phase: ~a" + (apply string-append + (map (lambda (x) (format "~e " x)) + (filter (lambda (x) x) phases)))))) + +;; Preferences GUI + +(define load-action "Load the tool") +(define skip-action "Skip the tool") + +(define (add-prefs-panel) + (preferences:add-panel + "Tools" + (lambda (parent) + (define main (new vertical-panel% (parent parent))) + (define advisory + (new message% + (parent main) + (label "Changes to tool configuration will take effect the next time you start DrScheme."))) + (define listing + (new list-box% + (parent main) + (label "Installed tools") + (choices null) + (callback (lambda _ (on-select-tool))))) + (define info + (new vertical-panel% + (parent main) + (style '(border)) + (stretchable-height #f))) + (define location + (new text-field% + (parent info) + (label "Tool: "))) + (define location-editor (send location get-editor)) + (define configuration + (new radio-box% + (label "Load the tool when DrScheme starts?") + (parent info) + (choices (list load-action skip-action #| default-action |#)) + (callback (lambda _ (on-select-policy))))) + + (define (populate-listing!) + (send listing clear) + (for-each + (lambda (entry+it) + (send listing append + (car entry+it) + (cdr entry+it))) + (sort (map (lambda (it) (cons (tool-list-entry it) it)) + installed-tools) + (lambda (a b) + (stringmodule-spec it)))]) + (if (installed-tool-is-loaded? it) + (string-append name " (loaded)") + name))) + (define (on-select-tool) + (let ([it (get-selected-tool)]) + (send* location-editor + (begin-edit-sequence) + (lock #f) + (erase) + (insert + (if it + (format "~s" (installed-tool->module-spec it)) + "")) + (lock #t) + (end-edit-sequence)) + (send configuration set-selection + (case (and it (get-tool-configuration it)) + ((load) 0) + ((skip) 1) + ((#f) 0))) ;; XXX (or 2, if default is an option) + (send configuration enable (and it #t)) + (void))) + (define (on-select-policy) + (let ([it (get-selected-tool)] + [policy + (case (send configuration get-selection) + ((0) 'load) + ((1) 'skip))]) + (when it + (let ([key (installed-tool->key it)]) + (case policy + ((load) + (toolspref (cons (list key 'load) + (let ([ts (toolspref)]) + (remove (assoc key ts) ts))))) + ((skip) + (toolspref (cons (list key 'skip) + (let ([ts (toolspref)]) + (remove (assoc key ts) ts))))) + ((#f) + (toolspref (let ([ts (toolspref)]) + (remove (assoc key ts) ts)))))))) + (void)) + (define (get-selected-tool) + (let ([index (send listing get-selection)]) + (and index (send listing get-data index)))) + (populate-listing!) + (send location-editor lock #t) + main))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 5d9af6745a..a9bf5837e9 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -20,7 +20,8 @@ all of the names in the tools library, for use defining keybindings framework framework/splash - scribble/srcdoc) + scribble/srcdoc + drscheme/private/language-object-contract) (require (for-syntax scheme/base)) @@ -38,67 +39,8 @@ all of the names in the tools library, for use defining keybindings #'((drscheme:unit:get-program-editor-mixin) a ...)] [_ #'(drscheme:unit:get-program-editor-mixin)])) -(define-syntax (language-object-abstraction stx) - (syntax-case stx () - [(_ id) - (with-syntax ([ctc - #'(object-contract - (config-panel (-> (is-a?/c area-container<%>) - (case-> (-> any/c void?) - (-> any/c)))) - (create-executable (-> any/c - (or/c (is-a?/c dialog%) (is-a?/c frame%)) - path? - void?)) - (default-settings (-> any/c)) - (default-settings? (-> any/c boolean?)) - (order-manuals (-> (listof bytes?) - (values (listof bytes?) boolean?))) - (front-end/complete-program (-> input-port? - any/c - (-> any/c))) - (front-end/interaction (-> input-port? - any/c - (-> any/c))) - (get-language-name (-> string?)) - (get-language-numbers (-> (cons/c number? (listof number?)))) - (get-language-position (-> (cons/c string? (listof string?)))) - (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) - (get-comment-character (-> (values string? char?))) - (get-style-delta - (-> (or/c false/c - (is-a?/c style-delta%) - (listof - (list/c (is-a?/c style-delta%) - number? - number?))))) - (marshall-settings (-> any/c printable/c)) - (on-execute (-> any/c (-> (-> any) any) any)) - (render-value (-> any/c - any/c - output-port? - void?)) - (render-value/format (-> any/c - any/c - output-port? - (or/c number? (symbols 'infinity)) - any)) - (unmarshall-settings (-> printable/c any)) - - (capability-value - (->d ([s (and/c symbol? - drscheme:language:capability-registered?)]) - () - [res (drscheme:language:get-capability-contract s)])))]) - #'(begin - (define id ctc) - (provide/doc - (thing-doc id - contract? - @{@schemeblock[ctc]}))))])) +(provide drscheme:language:object/c) -(language-object-abstraction drscheme:language:object/c) (provide/doc @@ -120,9 +62,9 @@ all of the names in the tools library, for use defining keybindings ; - (proc-doc/names - drscheme:eval:set-basic-parameters - (-> (listof (is-a?/c snip-class%)) void?) + (proc-doc/names + drscheme:eval:set-basic-parameters + (-> (listof (is-a?/c snip-class%)) void?) (snipclasses) @{sets the parameters that are shared between the repl's initialization and @scheme[drscheme:eval:build-user-eventspace/custodian] @@ -159,25 +101,23 @@ all of the names in the tools library, for use defining keybindings }}}) - (proc-doc/names - drscheme:eval:get-snip-classes + (proc-doc/names + drscheme:eval:get-snip-classes (-> (listof (is-a?/c snip-class%))) () @{Returns a list of all of the snipclasses in the current eventspace.}) (proc-doc/names drscheme:eval:expand-program - ((or/c port? drscheme:language:text/pos?) - drscheme:language-configuration:language-settings? - boolean? - (-> void?) - (-> void?) - ((or/c eof-object? syntax? (cons/c string? any/c)) - (-> any) - . -> . - any) - . -> . - void?) + (-> (or/c port? drscheme:language:text/pos?) + drscheme:language-configuration:language-settings? + boolean? + (-> void?) + (-> void?) + (-> (or/c eof-object? syntax? (cons/c string? any/c)) + (-> any) + any) + void?) (input language-settings eval-compile-time-part? init kill-termination iter) @{Use this function to expand the contents of the definitions diff --git a/collects/scribblings/tools/language.scrbl b/collects/scribblings/tools/language.scrbl index 711de01db6..c1e596a278 100644 --- a/collects/scribblings/tools/language.scrbl +++ b/collects/scribblings/tools/language.scrbl @@ -1008,4 +1008,5 @@ Translates a Scheme value into a settings, returning }} +@(include-extracted (lib "language-object-contract.ss" "drscheme" "private") #rx"^drscheme:language:") @(include-extracted (lib "tool-lib.ss" "drscheme") #rx"^drscheme:language:") diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 1d4ca2e013..98f8b529bc 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -15,6 +15,13 @@ @title{@bold{Plugins}: Extending DrScheme} @(defmodule drscheme/tool-lib) + +@bold{TODO} + +@itemize{@item{contract for capability-value method is wrong (commented out version is right, but has circular dependencies)}} + +---------------------------------------------------------------------------------------------------- + @bold{This Manual} This manual describes DrScheme's tools interface. It assumes