diff --git a/collects/drscheme/private/drsig.rkt b/collects/drscheme/private/drsig.rkt index 56f196c06b..24eac1088f 100644 --- a/collects/drscheme/private/drsig.rkt +++ b/collects/drscheme/private/drsig.rkt @@ -11,6 +11,7 @@ drracket:language-configuration^ drracket:language-configuration/internal^ drracket:tools^ + drracket:tools-drs^ drracket:get/extend^ drracket:unit^ drracket:frame^ @@ -28,7 +29,9 @@ drracket:tracing^ drracket:tool-exports^ drracket:tool^ - drracket:tool-cm^) + drracket:tool-cm^ + drscheme:tool^ + drscheme:tool-cm^) (define-signature drracket:modes-cm^ ()) @@ -145,6 +148,11 @@ load/invoke-all-tools add-prefs-panel)) +(define-signature drracket:tools-drs-cm^ + ()) +(define-signature drracket:tools-drs^ extends drracket:tools-drs-cm^ + (invoke-drs-tool)) + (define-signature drracket:get/extend-cm^ ()) (define-signature drracket:get/extend^ extends drracket:get/extend-cm^ @@ -318,32 +326,42 @@ (phase1 phase2)) -(define-signature drracket:tool-cm^ - ((open (prefix drracket:debug: drracket:debug-cm^)) - (open (prefix drracket:unit: drracket:unit-cm^)) - (open (prefix drracket:rep: drracket:rep-cm^)) - (open (prefix drracket:frame: drracket:frame-cm^)) - (open (prefix drracket:get/extend: drracket:get/extend-cm^)) - (open (prefix drracket:language-configuration: drracket:language-configuration-cm^)) - (open (prefix drracket:language: drracket:language-cm^)) - (open (prefix drracket:help-desk: drracket:help-desk-cm^)) - (open (prefix drracket:eval: drracket:eval-cm^)) - (open (prefix drracket:modes: drracket:modes-cm^)) - (open (prefix drracket:tracing: drracket:tracing-cm^)) - (open (prefix drracket:module-language: drracket:module-language-cm^)) - (open (prefix drracket:module-language-tools: drracket:module-language-tools-cm^)))) +(define-signature no-prefix:tool-cm^ + ((open (prefix debug: drracket:debug-cm^)) + (open (prefix unit: drracket:unit-cm^)) + (open (prefix rep: drracket:rep-cm^)) + (open (prefix frame: drracket:frame-cm^)) + (open (prefix get/extend: drracket:get/extend-cm^)) + (open (prefix language-configuration: drracket:language-configuration-cm^)) + (open (prefix language: drracket:language-cm^)) + (open (prefix help-desk: drracket:help-desk-cm^)) + (open (prefix eval: drracket:eval-cm^)) + (open (prefix modes: drracket:modes-cm^)) + (open (prefix tracing: drracket:tracing-cm^)) + (open (prefix module-language: drracket:module-language-cm^)) + (open (prefix module-language-tools: drracket:module-language-tools-cm^)))) -(define-signature drracket:tool^ - ((open (prefix drracket:debug: drracket:debug^)) - (open (prefix drracket:unit: drracket:unit^)) - (open (prefix drracket:rep: drracket:rep^)) - (open (prefix drracket:frame: drracket:frame^)) - (open (prefix drracket:get/extend: drracket:get/extend^)) - (open (prefix drracket:language-configuration: drracket:language-configuration^)) - (open (prefix drracket:language: drracket:language^)) - (open (prefix drracket:help-desk: drracket:help-desk^)) - (open (prefix drracket:eval: drracket:eval^)) - (open (prefix drracket:modes: drracket:modes^)) - (open (prefix drracket:tracing: drracket:tracing^)) - (open (prefix drracket:module-language: drracket:module-language^)) - (open (prefix drracket:module-language-tools: drracket:module-language-tools^)))) +(define-signature drracket:tool-cm^ + ((open (prefix drracket: no-prefix:tool-cm^)))) +(define-signature drscheme:tool-cm^ + ((open (prefix drscheme: no-prefix:tool-cm^)))) + +(define-signature no-prefix:tool^ + ((open (prefix debug: drracket:debug^)) + (open (prefix unit: drracket:unit^)) + (open (prefix rep: drracket:rep^)) + (open (prefix frame: drracket:frame^)) + (open (prefix get/extend: drracket:get/extend^)) + (open (prefix language-configuration: drracket:language-configuration^)) + (open (prefix language: drracket:language^)) + (open (prefix help-desk: drracket:help-desk^)) + (open (prefix eval: drracket:eval^)) + (open (prefix modes: drracket:modes^)) + (open (prefix tracing: drracket:tracing^)) + (open (prefix module-language: drracket:module-language^)) + (open (prefix module-language-tools: drracket:module-language-tools^)))) + +(define-signature drracket:tool^ + ((open (prefix drracket: no-prefix:tool^)))) +(define-signature drscheme:tool^ + ((open (prefix drscheme: no-prefix:tool^)))) diff --git a/collects/drscheme/private/language-object-contract.rkt b/collects/drscheme/private/language-object-contract.rkt index d338a7ca3b..54d9a12677 100644 --- a/collects/drscheme/private/language-object-contract.rkt +++ b/collects/drscheme/private/language-object-contract.rkt @@ -1,4 +1,3 @@ -#reader scribble/reader #lang racket/base (require (for-syntax racket/base) scribble/srcdoc diff --git a/collects/drscheme/private/link.rkt b/collects/drscheme/private/link.rkt index 48c280e875..deb716681a 100644 --- a/collects/drscheme/private/link.rkt +++ b/collects/drscheme/private/link.rkt @@ -8,6 +8,7 @@ "debug.rkt" "module-language.rkt" "tools.rkt" + "tools-drs.rkt" "language.rkt" "language-configuration.rkt" "drsig.rkt" @@ -40,7 +41,7 @@ drracket:tracing^ drracket:module-language^ drracket:module-language-tools^) - (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ + (link init@ tools@ tools-drs@ modes@ text@ eval@ frame@ rep@ language@ module-overview@ unit@ debug@ multi-file-search@ get-extend@ language-configuration@ font@ module-language@ module-language-tools@ help-desk@ tracing@ app@ diff --git a/collects/drscheme/private/tools-drs.rkt b/collects/drscheme/private/tools-drs.rkt index 5a36b62b5c..bb121ee72c 100644 --- a/collects/drscheme/private/tools-drs.rkt +++ b/collects/drscheme/private/tools-drs.rkt @@ -1,5 +1,11 @@ #lang scheme/unit +#| + +This file sets up the right lexical environment to invoke the tools that want to use the drscheme: names. + +|# + (require racket/class racket/list racket/runtime-path @@ -11,301 +17,25 @@ "drsig.rkt" "language-object-contract.rkt" mrlib/switchable-button -string-constants) + string-constants) (require (for-syntax racket/base racket/match)) -(import [prefix drracket:frame: drracket:frame^] - [prefix drracket:unit: drracket:unit^] - [prefix drracket:rep: drracket:rep^] - [prefix drracket:get/extend: drracket:get/extend^] - [prefix drracket:language: drracket:language^] - [prefix drracket:language-configuration: drracket:language-configuration^] - [prefix drracket:help-desk: drracket:help-desk^] - [prefix drracket:init: drracket:init^] - [prefix drracket:debug: drracket:debug^] - [prefix drracket:eval: drracket:eval^] - [prefix drracket:modes: drracket:modes^] - [prefix drracket:tracing: drracket:tracing^] - [prefix drracket:module-language: drracket:module-language^] - [prefix drracket:module-language-tools: drracket:module-language-tools^]) -(export drracket: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)) - -;; 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)) - -;; 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))) - -;; 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 (with-handlers ((exn:fail? values)) - (get-info/full (directory-record-path coll-dir)))]) - (cond - [(not table) - null] - [(exn? table) - (message-box (string-constant drscheme) - (format (string-constant error-loading-tool-title) - (directory-record-path coll-dir) - (let ([sp (open-output-string)]) - (parameterize ([current-error-port sp] - [current-error-port sp]) - (drracket:init:original-error-display-handler (exn-message table) table)) - (get-output-string sp))) - #f - '(ok stop)) - null] - [else - (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))]))) - -;; candidate-tool? : installed-tool -> boolean -;; Predicate for tools selected for execution in this -;; run of DrRacket (depending on env variables and preferences) -(define candidate-tool? - (cond - [(getenv "PLTNOTOOLS") - (printf "PLTNOTOOLS: skipping tools\n") (flush-output) - (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) (flush-output) - (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)))))))) +(import [prefix drscheme:frame: drracket:frame^] + [prefix drscheme:unit: drracket:unit^] + [prefix drscheme:rep: drracket:rep^] + [prefix drscheme:get/extend: drracket:get/extend^] + [prefix drscheme:language: drracket:language^] + [prefix drscheme:language-configuration: drracket:language-configuration^] + [prefix drscheme:help-desk: drracket:help-desk^] + [prefix drscheme:init: drracket:init^] + [prefix drscheme:debug: drracket:debug^] + [prefix drscheme:eval: drracket:eval^] + [prefix drscheme:modes: drracket:modes^] + [prefix drscheme:tracing: drracket:tracing^] + [prefix drscheme:module-language: drracket:module-language^] + [prefix drscheme:module-language-tools: drracket:module-language-tools^]) +(export drracket:tools-drs^) (define-syntax (wrap-tool-inputs stx) (syntax-case stx () @@ -322,272 +52,48 @@ string-constants) [`((#%module-begin ,body ...)) (loop body)] [`((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 name) - (quote-syntax name))])) + #`(let #,(map (λ (orig-name ctc) + (define (rewrite obj) + (cond + [(symbol? obj) + (string->symbol (regexp-replace #rx"^drracket:" (symbol->string obj) "drscheme:"))] + [(pair? obj) + (cons (rewrite (car obj)) + (rewrite (cdr obj)))] + [else obj])) + (with-syntax ([name (datum->syntax #'tool-name (rewrite orig-name))] + [ctc (datum->syntax #'tool-name (rewrite ctc))]) + #`[name + (contract (let ([name ctc]) name) ;; need to replace the names in 'ctc' + name + 'drracket + tool-name + (quote name) + (quote-syntax name))])) name ctc) body)] [`(,a . ,b) (loop b)] [`() - (error 'tools.rkt "did not find provide/doc: ~a" full-sexp)])))])) + (error 'tools-drs.rkt "did not find provide/doc: ~a" full-sexp)])))])) -;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) +;; these two definitions are a hack. They give bindings for the drracket: based names that +;; appear in the source of language-object-contract.rkt. +(define drracket:language:capability-registered? drscheme:language:capability-registered?) +(define drracket:language:get-capability-contract drscheme:language:get-capability-contract) + +;; invoke-drs-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 drracket:tool^) (export drracket:tool-exports^)) - (language-object-abstraction drracket:language:object/c #f) +;; this is the same as the invoke-tool function in tools.rkt, but +;; supplies names prefixed with `drscheme:' +(define (invoke-drs-tool unit tool-name) + (define-unit-binding unit@ unit (import drscheme:tool^) (export drracket:tool-exports^)) + (language-object-abstraction drscheme:language:object/c #f) (wrap-tool-inputs (let () (define-values/invoke-unit unit@ - (import drracket:tool^) (export drracket:tool-exports^)) + (import drscheme:tool^) (export drracket:tool-exports^)) (values phase1 phase2)) tool-name)) -;; show-error : string (union exn TST) -> void -(define (show-error title x) - (parameterize ([drracket: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 (get-splash-eventspace)] - [splash-canvas (get-splash-canvas)] - [splash-width (get-splash-width)] - [splash-height (get-splash-height)]) - - (unless (and (eventspace? splash-eventspace) - (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 (- splash-height tool-bitmap-y tool-bitmap-size))]) - - ;; add the bitmap, but centered at its position - ;; (used to truncate the bitmap - ;; if it was too large, but no longer) - ((dynamic-require 'framework/splash 'add-splash-icon) - bitmap - (floor (+ tool-bitmap-x - (- (/ tool-bitmap-size 2) - (/ (send bitmap get-width) 2)))) - (floor (+ translated-tool-bitmap-y - (- (/ tool-bitmap-size 2) - (/ (send bitmap get-height) 2))))) - - (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap)) - (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . splash-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) . > . splash-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 DrRacket 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 DrRacket."))) - (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 DrRacket 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/private/tools.rkt b/collects/drscheme/private/tools.rkt index 5a36b62b5c..a820708815 100644 --- a/collects/drscheme/private/tools.rkt +++ b/collects/drscheme/private/tools.rkt @@ -28,7 +28,8 @@ string-constants) [prefix drracket:modes: drracket:modes^] [prefix drracket:tracing: drracket:tracing^] [prefix drracket:module-language: drracket:module-language^] - [prefix drracket:module-language-tools: drracket:module-language-tools^]) + [prefix drracket:module-language-tools: drracket:module-language-tools^] + [prefix drracket:tools-drs: drracket:tools-drs^]) (export drracket:tools^) ;; An installed-tool is @@ -296,7 +297,8 @@ string-constants) coll-dir in-path) x))]) (let-values ([(phase1-thunk phase2-thunk) - (invoke-tool unit (string->symbol (or name (path->string coll-dir))))]) + (drracket:tools-drs:invoke-drs-tool unit (string->symbol (or name (path->string coll-dir)))) + #;(invoke-tool unit (string->symbol (or name (path->string coll-dir))))]) (set! successfully-loaded-tools (cons (make-successfully-loaded-tool tool-path @@ -327,7 +329,7 @@ string-constants) [ctc (datum->syntax #'tool-name ctc)]) #`[name (contract (let ([name ctc]) name) name - 'drscheme + 'drracket tool-name (quote name) (quote-syntax name))])) diff --git a/collects/drscheme/tool.rkt b/collects/drscheme/tool.rkt index b44fcc646b..9d0842fc64 100644 --- a/collects/drscheme/tool.rkt +++ b/collects/drscheme/tool.rkt @@ -2,5 +2,5 @@ (require "private/drsig.ss") (provide drracket:tool^ drracket:tool-exports^ - (rename-out [drracket:tool^ drscheme:tool^] - [drracket:tool-exports^ drscheme:tool-exports^])) + drscheme:tool^ + (rename-out [drracket:tool-exports^ drscheme:tool-exports^]))