adjusted drracket to use drracket: prefixed names everywhere (the names are rewriten to drscheme: when tools are invoked)
This commit is contained in:
Robby Findler
parent
d08b0a8dc8
commit
9fbfa9bfc3
|
|
@ -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^))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
#reader scribble/reader
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
scribble/srcdoc
|
||||
|
|
|
|||
|
|
@ -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@
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(string<? (car a) (car b))))))
|
||||
(define (tool-list-entry it)
|
||||
(let ([name (or (installed-tool-name it)
|
||||
(format "unnamed tool ~a"
|
||||
(installed-tool->module-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)))
|
||||
|
|
|
|||
|
|
@ -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))]))
|
||||
|
|
|
|||
|
|
@ -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^]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user