583 lines
25 KiB
Scheme
583 lines
25 KiB
Scheme
|
|
#lang scheme/unit
|
|
|
|
(require (lib "getinfo.ss" "setup")
|
|
mred
|
|
scheme/class
|
|
scheme/list
|
|
"drsig.ss"
|
|
"language-object-contract.ss"
|
|
scheme/contract
|
|
framework
|
|
string-constants
|
|
scheme/runtime-path)
|
|
|
|
(require (for-syntax scheme/base scheme/match))
|
|
|
|
(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))
|
|
|
|
;; 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 (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))))))))
|
|
|
|
(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)])))]))
|
|
|
|
;; 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^))
|
|
(language-object-abstraction drscheme:language:object/c #f)
|
|
(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)
|
|
(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)
|
|
(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)))
|