367 lines
19 KiB
Scheme
367 lines
19 KiB
Scheme
|
|
(module tools (lib "a-unit.ss")
|
|
(require (lib "getinfo.ss" "setup")
|
|
(lib "mred.ss" "mred")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
"drsig.ss"
|
|
(lib "contract.ss")
|
|
"tool-contracts.ss"
|
|
(lib "framework.ss" "framework")
|
|
(lib "string-constant.ss" "string-constants"))
|
|
|
|
(import [prefix drscheme:frame: drscheme:frame^]
|
|
[prefix drscheme:unit: drscheme:unit^]
|
|
[prefix drscheme:rep: drscheme:rep^]
|
|
[prefix drscheme:get/extend: drscheme:get/extend^]
|
|
[prefix drscheme:language: drscheme:language^]
|
|
[prefix drscheme:language-configuration: drscheme:language-configuration^]
|
|
[prefix drscheme:help-desk: drscheme:help-desk^]
|
|
[prefix drscheme:init: drscheme:init^]
|
|
[prefix drscheme:debug: drscheme:debug^]
|
|
[prefix drscheme:eval: drscheme:eval^]
|
|
[prefix drscheme:teachpack: drscheme:teachpack^]
|
|
[prefix drscheme:modes: drscheme:modes^])
|
|
(export drscheme:tools^)
|
|
|
|
;; 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)
|
|
(set! current-phase 'loading-tools)
|
|
(load/invoke-all-tools/collections
|
|
(all-tool-directories)
|
|
phase1-extras
|
|
phase2-extras))
|
|
|
|
|
|
(define (all-tool-directories)
|
|
(find-relevant-directories '(tools tool-icons tool-names tool-urls)))
|
|
|
|
;; loads the the tools in each directory
|
|
;; unless PLTNOTOOLS is set, in which case it
|
|
;; just runs the phases. If PLTONLYTOOL is set,
|
|
;; it only loads tools in those collections
|
|
(define (load/invoke-all-tools/collections directories phase1-extras phase2-extras)
|
|
(cond
|
|
[(getenv "PLTNOTOOLS") (printf "PLTNOTOOLS: skipping tools\n")]
|
|
[else
|
|
(let ([onlys (getenv "PLTONLYTOOL")])
|
|
(if onlys
|
|
(let* ([allowed (let ([exp (read (open-input-string onlys))])
|
|
(cond
|
|
[(symbol? exp) (list exp)]
|
|
[(pair? exp) exp]
|
|
[else '()]))]
|
|
[filtered (filter (lambda (x)
|
|
(let-values ([(base name dir) (split-path x)])
|
|
(memq (string->symbol (path->string name))
|
|
allowed)))
|
|
directories)])
|
|
(printf "PLTONLYTOOL: only loading ~s\n" filtered)
|
|
(for-each load/invoke-tools filtered))
|
|
(for-each load/invoke-tools directories)))])
|
|
(run-phases phase1-extras phase2-extras))
|
|
|
|
|
|
|
|
;;; ;; ; ; ;;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;;
|
|
; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ;
|
|
;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;;
|
|
;
|
|
|
|
|
|
|
|
|
|
;; load/invoke-tools : string[collection-name] -> void
|
|
;; loads each tool in a collection
|
|
(define (load/invoke-tools coll-dir)
|
|
(let ([table (with-handlers ([(lambda (x) #f) ; exn:fail?
|
|
(lambda (x)
|
|
(show-error
|
|
(format (string-constant error-getting-info-tool)
|
|
coll-dir)
|
|
x)
|
|
#f)])
|
|
(get-info/full coll-dir))])
|
|
(when 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)))
|
|
(for-each (load/invoke-tool coll-dir) tools tool-icons tool-names tool-urls)))))
|
|
|
|
;; load/invoke-tool : path[directory-of-collection]
|
|
;; -> (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)
|
|
(lambda (in-path icon-spec name tool-url)
|
|
(let* ([icon-path
|
|
(cond
|
|
[(string? icon-spec)
|
|
(build-path coll-dir icon-spec)]
|
|
[(and (list? icon-spec)
|
|
(andmap string? icon-spec))
|
|
(build-path (apply collection-path (cdr icon-spec)) (car icon-spec))]
|
|
[else #f])]
|
|
[tool-bitmap
|
|
(and icon-path
|
|
(install-tool-bitmap name icon-path))])
|
|
(let/ec k
|
|
(unless (or (string? in-path)
|
|
(and (list? in-path)
|
|
(not (null? in-path))
|
|
(andmap string? in-path)))
|
|
(message-box (string-constant drscheme)
|
|
(format (string-constant invalid-tool-spec)
|
|
coll-dir in-path)
|
|
#f
|
|
'(ok stop))
|
|
(k (void)))
|
|
(let* ([tool-path
|
|
(if (string? in-path)
|
|
(build-path coll-dir in-path)
|
|
(apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))]
|
|
[unit
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x)
|
|
(show-error
|
|
(format (string-constant error-invoking-tool-title)
|
|
coll-dir in-path)
|
|
x)
|
|
(k (void)))])
|
|
(dynamic-require tool-path 'tool@))])
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x)
|
|
(show-error
|
|
(format (string-constant error-invoking-tool-title)
|
|
coll-dir in-path)
|
|
x))])
|
|
(let-values ([(phase1-thunk phase2-thunk)
|
|
(invoke-tool unit (string->symbol (or name (path->string coll-dir))))])
|
|
(set! successfully-loaded-tools
|
|
(cons (make-successfully-loaded-tool
|
|
tool-path
|
|
tool-bitmap
|
|
name
|
|
tool-url
|
|
phase1-thunk
|
|
phase2-thunk)
|
|
successfully-loaded-tools)))))))))
|
|
|
|
;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
|
|
;; invokes the tools and returns the two phase thunks.
|
|
(define (invoke-tool unit tool-name)
|
|
(define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^))
|
|
(wrap-tool-inputs
|
|
(let ()
|
|
(define-values/invoke-unit unit@
|
|
(import drscheme:tool^) (export drscheme:tool-exports^))
|
|
(values phase1 phase2))
|
|
tool-name))
|
|
|
|
;; show-error : string (union exn TST) -> void
|
|
(define (show-error title x)
|
|
(parameterize ([drscheme:init:error-display-handler-message-box-title
|
|
title])
|
|
((error-display-handler)
|
|
(if (exn? x)
|
|
(format "~a\n\n~a" title (exn-message x))
|
|
(format "~a\n\nuncaught exception: ~s" title x))
|
|
x)))
|
|
|
|
|
|
;; install-tool-bitmap : string path -> bitmap
|
|
;; adds the tool's bitmap to the splash screen
|
|
(define (install-tool-bitmap name bitmap-path)
|
|
(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 "splash.ss" "framework") 'get-splash-eventspace))]
|
|
[splash-bitmap ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-bitmap))]
|
|
[splash-canvas ((dynamic-require '(lib "splash.ss" "framework") '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 "splash.ss" "framework") '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)))))))
|