From d08b0a8dc81f52ea10f7ea99e09126c5ea93ce10 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 25 Apr 2010 15:19:51 -0500 Subject: [PATCH] adjusted drracket to use drracket: prefixed names everywhere (the names are rewriten to drscheme: when tools are invoked) --- collects/drscheme/private/prefs-contract.rkt | 16 - collects/drscheme/private/tools-drs.rkt | 593 +++++++++++++++++++ 2 files changed, 593 insertions(+), 16 deletions(-) delete mode 100644 collects/drscheme/private/prefs-contract.rkt create mode 100644 collects/drscheme/private/tools-drs.rkt diff --git a/collects/drscheme/private/prefs-contract.rkt b/collects/drscheme/private/prefs-contract.rkt deleted file mode 100644 index d850ca725e..0000000000 --- a/collects/drscheme/private/prefs-contract.rkt +++ /dev/null @@ -1,16 +0,0 @@ -#lang racket/base - -(require (for-syntax racket/base) - framework/framework) - -(provide (rename-out [-preferences:get preferences:get]) - preferences:get-drscheme:large-letters-font) - -(define (preferences:get-drscheme:large-letters-font) - (preferences:get 'drscheme:large-letters-font)) - -(define-syntax (-preferences:get stx) - (syntax-case stx (quote) - [(_ (quote sym)) - (with-syntax ([nm (datum->syntax stx (string->symbol (string-append "preferences:get" "-" (symbol->string (syntax-e #'sym)))))]) - (syntax/loc stx (nm)))])) diff --git a/collects/drscheme/private/tools-drs.rkt b/collects/drscheme/private/tools-drs.rkt new file mode 100644 index 0000000000..5a36b62b5c --- /dev/null +++ b/collects/drscheme/private/tools-drs.rkt @@ -0,0 +1,593 @@ +#lang scheme/unit + +(require racket/class + racket/list + racket/runtime-path + racket/contract + setup/getinfo + mred + framework + framework/splash + "drsig.rkt" + "language-object-contract.rkt" + mrlib/switchable-button +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)))))))) + +(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.rkt") + (λ (port) + (parameterize ([read-accept-reader #t]) + (read port))))) + + (let loop ([sexp full-sexp]) + (match sexp + [`((#%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))])) + name + ctc) + body)] + [`(,a . ,b) + (loop b)] + [`() + (error 'tools.rkt "did not find provide/doc: ~a" full-sexp)])))])) + +;; 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 drracket:tool^) (export drracket:tool-exports^)) + (language-object-abstraction drracket:language:object/c #f) + (wrap-tool-inputs + (let () + (define-values/invoke-unit unit@ + (import drracket: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)))