suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove changed code

Browse Source 
svn: r10335
This commit is contained in:
Eli Barzilay 2008-06-18 04:50:58 +00:00
parent 88edb0e088
commit f4926472b8
53 changed files with 0 additions and 22416 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/drscheme/acks.ss
View File

@ -1,82 +0,0 @@
(module acks mzscheme
(provide get-general-acks
get-translating-acks
get-authors)
(define (get-authors)
(get-general-acks))
(define (get-general-acks)
(string-append
"The following individuals contributed to the implementation"
" and documentation of PLT Scheme: "
"Yavuz Arkun, "
"Ian Barland, "
"Eli Barzilay, "
"Gann Bierner, "
"Filipe Cabecinhas, "
"Richard Cleis, "
"John Clements, "
"Richard Cobbe, "
"Greg Cooper, "
"Ryan Culpepper, "
"Carl Eastlund, "
"Moy Easwaran, "
"Will Farr, "
"Matthias Felleisen, "
"Robby Findler, "
"Kathi Fisler, "
"Cormac Flanagan, "
"Matthew Flatt, "
"Sebastian Good, "
"Paul Graunke, "
"Kathy Gray, "
"Dan Grossman, "
"Dave Gurnell, "
"Bruce Hauman, "
"Dave Herman, "
"Mark Krentel, "
"Shriram Krishnamurthi, "
"Mario Latendresse, "
"Guillaume Marceau, "
"Jacob Matthews, "
"Jay McCarthy, "
"Philippe Meunier, "
"Scott Owens, "
"Jamie Raymond, "
"Grant Rettke, "
"Paul Schlie, "
"Dorai Sitaram, "
"Mike Sperber, "
"Paul Steckler, "
"Jens Axel Søgaard, "
"Francisco Solsona, "
"Sam Tobin-Hochstadt, "
"Neil W. Van Dyke, "
"David Van Horn, "
"Anton van Straaten, "
"Dale Vaillancourt, "
"Dimitris Vyzovitis, "
"Stephanie Weirich, "
"Noel Welsh, "
"Adam Wick, "
"Danny Yoo, "
"and "
"ChongKai Zhu."))
(define (get-translating-acks)
(string-append
"Thanks to "
"ChongKai Zhu, "
"Ian Barland, "
"Biep Durieux, "
"Tim Hanson, "
"Chihiro Kuraya, "
"Philippe Meunier, "
"Jens Axel Søgaard, "
"Francisco Solsona, "
"Mike Sperber, "
"Reini Urban, "
"and "
"Paolo Zoppetti "
"for their help translating DrScheme's GUI to other languages.")))

195
collects/drscheme/arrow.ss
View File

@ -1,195 +0,0 @@
(module arrow mzscheme
(require mzlib/class
mzlib/list
mzlib/math
mred)
(provide draw-arrow)
(define largest 16383)
(define smallest -16383)
(define arrow-head-angle (/ pi 8))
(define cos-arrow-head-angle (cos arrow-head-angle))
(define sin-arrow-head-angle (sin arrow-head-angle))
(define arrow-head-size 8)
(define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
(define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))
(define arrow-root-radius 2.5)
(define arrow-root-diameter (* 2 arrow-root-radius))
; If alpha is the angle between the x axis and the Start->End vector:
;
; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
; = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
;
; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
; = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
;
; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
; = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
;
; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
; = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha
; dc<%> real real real real real real -> void
; draw one arrow
; The reason of the "-0.5" in the definition of start-x and end-x in the let
; right below is because, well, after numerous experiments done under carefully
; controlled conditions by a team of independent experts, it was thought to
; be The Right Thing for the arrows to be drawn correctly, maybe.
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
(let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
[uncropped-start-y (+ uncropped-pre-start-y dy)]
[uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
[uncropped-end-y (+ uncropped-pre-end-y dy)]
[old-smoothed (send dc get-smoothing)])
(let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
[(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
(send dc set-smoothing 'aligned)
(send dc draw-line start-x start-y end-x end-y)
(when (and (< smallest start-x largest)
(< smallest end-x largest))
(send dc draw-ellipse
(- start-x arrow-root-radius) (- start-y arrow-root-radius)
arrow-root-diameter arrow-root-diameter))
(when (and (< smallest end-x largest)
(< smallest end-y largest))
(unless (and (= start-x end-x) (= start-y end-y))
(let* ([offset-x (- end-x start-x)]
[offset-y (- end-y start-y)]
[arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
[cos-alpha (/ offset-x arrow-length)]
[sin-alpha (/ offset-y arrow-length)]
[arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
[arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
[arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
[arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
[pt1 (make-object point% end-x end-y)]
[pt2 (make-object point%
(- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
(+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
[pt3 (make-object point%
(+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
(- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
(send dc draw-polygon (list pt1 pt2 pt3)))))
(send dc set-smoothing old-smoothed))))
;; crop-to : number number number number -> (values number number)
;; returns x,y if they are in the range defined by largest and smallest
;; otherwise returns the coordinates on the line from x,y to ox,oy
;; that are closest to x,y and are in the range specified by
;; largest and smallest
(define (crop-to x y ox oy)
(cond
[(and (< smallest x largest) (< smallest y largest))
(values x y)]
[else
(let* ([xy-pr (cons x y)]
[left-i (find-intersection x y ox oy smallest smallest smallest largest)]
[top-i (find-intersection x y ox oy smallest smallest largest smallest)]
[right-i (find-intersection x y ox oy largest smallest largest largest)]
[bottom-i (find-intersection x y ox oy smallest largest largest largest)]
[d-top (and top-i (dist top-i xy-pr))]
[d-bottom (and bottom-i (dist bottom-i xy-pr))]
[d-left (and left-i (dist left-i xy-pr))]
[d-right (and right-i (dist right-i xy-pr))])
(cond
[(smallest? d-top d-bottom d-left d-right)
(values (car top-i) (cdr top-i))]
[(smallest? d-bottom d-top d-left d-right)
(values (car bottom-i) (cdr bottom-i))]
[(smallest? d-left d-top d-bottom d-right)
(values (car left-i) (cdr left-i))]
[(smallest? d-right d-top d-bottom d-left)
(values (car right-i) (cdr right-i))]
[else
;; uh oh... if this case happens, that's bad news...
(values x y)]))]))
;; smallest? : (union #f number)^4 -> boolean
;; returns #t if can is less and o1, o2, and o3
;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
(define (smallest? can o1 o2 o3)
(and can
(andmap (λ (x) (< can x))
(filter (λ (x) x)
(list o1 o2 o3)))))
;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
;; returns the original pair if the coordinates are between smallest and largest
;; and returns #f if the pair is #f or the coordinates are outside.
(define (inside? pr)
(and pr
(let ([x (car pr)]
[y (cdr pr)])
(if (and (< smallest x largest)
(< smallest y largest))
pr
#f))))
;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
;; finds the intersection between the lines specified by
;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
(define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
(cond
[(and (= x1 x2) (= x3 x4))
#f]
[(and (= x1 x2) (not (= x3 x4)))
(let* ([m2 (/ (- y3 y4) (- x3 x4))]
[b2 (- y3 (* m2 x3))])
(cons x1
(+ (* m2 x1) b2)))]
[(and (not (= x1 x2)) (= x3 x4))
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
[b1 (- y1 (* m1 x1))])
(cons x3
(+ (* m1 x3) b1)))]
[(and (not (= x1 x2)) (not (= x3 x4)))
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
[b1 (- y1 (* m1 x1))]
[m2 (/ (- y3 y4) (- x3 x4))]
[b2 (- y3 (* m2 x3))])
(if (= m1 m2)
#f
(let* ([x (/ (- b1 b2) (- m2 m1))]
[y (+ (* m1 x) b1)])
(cons x y))))]))
;; dist : (cons number number) (cons number number) -> number
(define (dist p1 p2)
(sqrt (+ (sqr (- (car p1) (car p2)))
(sqr (- (cdr p1) (cdr p2))))))
;; localled defined test code.... :(
;; use module language to run tests
(define (tests)
(and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
(equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
(equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
(equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
(equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
(equal? (smallest? 3 1 2 3) #f)
(equal? (smallest? 0 1 2 3) #t)
(equal? (smallest? 1 0 2 3) #f)
(equal? (smallest? 1 0 #f 4) #f)
(equal? (smallest? 1 #f #f 4) #t)
(equal? (smallest? 1 #f #f #f) #t)
(equal? (dist (cons 1 1) (cons 4 5)) 5))))

27
collects/drscheme/default-code-style.ss
View File

@ -1,27 +0,0 @@
(module default-code-style mzscheme
(provide color-default-code-styles
bw-default-code-styles
code-style-color
code-style-slant?
code-style-bold?
code-style-underline?)
(define-struct code-style (color slant? bold? underline?))
;; code-style = (make-code-style (union (list number number number) string) bolean boolean)
;; bw-default-code-styles : (listof (list symbol code-style
(define bw-default-code-styles
(list (list 'lexically-bound-variable (make-code-style "black" #f #f #t))
(list 'lexically-bound-syntax (make-code-style "black" #f #f #t))
(list 'imported-variable (make-code-style "black" #f #f #t))
(list 'imported-syntax (make-code-style "black" #f #f #t))
(list 'unbound-variable (make-code-style "black" #t #f #f))
(list 'constant (make-code-style '(51 135 39) #f #f #f))))
;; color-default-code-styles : (listof (list symbol code-style))
(define color-default-code-styles
(list (list 'keyword (make-code-style '(40 25 15) #f #f #f))
(list 'unbound-variable (make-code-style "red" #f #f #f))
(list 'bound-variable (make-code-style "navy" #f #f #f))
(list 'primitive (make-code-style "navy" #f #f #f))
(list 'constant (make-code-style '(51 135 39) #f #f #f)))))

BIN
collects/drscheme/doc.icns
View File

Binary file not shown.

2
collects/drscheme/drscheme.creator
View File

@ -1,2 +0,0 @@
DrSc
(This code is registered with Apple.)

20
collects/drscheme/drscheme.filetypes
View File

@ -1,20 +0,0 @@
((("CFBundleTypeName"
"Scheme Source")
("CFBundleTypeIconFile"
"doc")
("CFBundleTypeRole"
"Editor")
("CFBundleTypeOSTypes"
(array "TEXT" "WXME"))
("CFBundleTypeExtensions"
(array "scm" "ss")))
(("CFBundleTypeName"
"Package")
("CFBundleTypeIconFile"
"pltdoc")
("CFBundleTypeRole"
"Viewer")
("CFBundleTypeOSTypes"
(array "PLT_" "WXME"))
("CFBundleTypeExtensions"
(array "plt"))))

47
collects/drscheme/drscheme.ss
View File

@ -1,47 +0,0 @@
(module drscheme mzscheme
(require "private/key.ss")
(define debugging? (getenv "PLTDRDEBUG"))
(define install-cm? (and (not debugging?)
(getenv "PLTDRCM")))
(define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace")))
(when debugging?
(printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
(let-values ([(zo-compile
make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-namespace)]
[use-compiled-file-paths '()])
(values
(dynamic-require '(lib "zo-compile.ss" "errortrace") 'zo-compile)
(dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'mzlib/cm 'manager-trace-handler)))])
(current-compile zo-compile)
(use-compiled-file-paths (list (build-path "compiled" "errortrace")))
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(error-display-handler (dynamic-require '(lib "errortrace-lib.ss" "errortrace")
'errortrace-error-display-handler))
(when cm-trace?
(printf "PLTDRDEBUG: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline))))))
(when install-cm?
(printf "PLTDRCM: installing compilation manager\n")
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-namespace)])
(values
(dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'mzlib/cm 'manager-trace-handler)))])
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when cm-trace?
(printf "PLTDRCM: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline))))))
(dynamic-require 'drscheme/private/drscheme-normal #f))

15
collects/drscheme/drscheme.utiexports
View File

@ -1,15 +0,0 @@
((("UTTypeConformsTo"
(array
"public.text"
"public.plain-text"))
("UTTypeDescription"
"PLT Scheme program source")
("UTTypeIdentifier"
"org.plt-scheme.source")
("UTTypeTagSpecification"
(dict
(assoc-pair "com.apple.ostype"
"TEXT")
(assoc-pair "public.filename-extension"
(array "ss"
"scm"))))))

6
collects/drscheme/info.ss
View File

@ -1,6 +0,0 @@
#lang setup/infotab
(define tools (list "syncheck.ss" (list "time-keystrokes.ss" "private")))
(define tool-names (list "Check Syntax" "Time Keystrokes"))
(define mred-launcher-names (list "DrScheme"))
(define mred-launcher-libraries (list "drscheme.ss"))

21
collects/drscheme/installer.ss
View File

@ -1,21 +0,0 @@
(module installer mzscheme
(require mzlib/file
mzlib/etc
launcher)
(provide installer)
(define (installer plthome)
(do-installation)
(set! do-installation void))
(define (do-installation)
(for-each install-variation (available-mred-variants)))
(define (install-variation variant)
(parameterize ([current-launcher-variant variant])
(make-mred-launcher
(list "-ZmvqL" "drscheme.ss" "drscheme")
(mred-program-launcher-path "DrScheme")
(cons
`(exe-name . "DrScheme")
(build-aux-from-path (build-path (collection-path "drscheme") "drscheme")))))))

2
collects/drscheme/main.ss
View File

@ -1,2 +0,0 @@
(module main scheme/base
(require "drscheme.ss"))

BIN
collects/drscheme/pltdoc.icns
View File

Binary file not shown.

420
collects/drscheme/private/app.ss
View File

@ -1,420 +0,0 @@
#lang scheme/unit
(require mzlib/class
mzlib/list
scheme/file
string-constants
mred
framework
(lib "external.ss" "browser")
(lib "getinfo.ss" "setup")
"drsig.ss"
"../acks.ss")
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix help-desk: drscheme:help-desk^]
[prefix drscheme:tools: drscheme:tools^])
(export drscheme:app^)
(define about-frame%
(class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
(init-field main-text)
(define/private (edit-menu:do const)
(send main-text do-edit-operation const))
[define/override file-menu:create-revert? (λ () #f)]
[define/override file-menu:create-save? (λ () #f)]
[define/override file-menu:create-save-as? (λ () #f)]
[define/override file-menu:between-close-and-quit (λ (x) (void))]
[define/override edit-menu:between-redo-and-cut (λ (x) (void))]
[define/override edit-menu:between-select-all-and-find (λ (x) (void))]
[define/override edit-menu:copy-callback (λ (menu evt) (edit-menu:do 'copy))]
[define/override edit-menu:select-all-callback (λ (menu evt) (edit-menu:do 'select-all))]
[define/override edit-menu:create-find? (λ () #f)]
(super-new
(label (string-constant about-drscheme-frame-title)))))
(define (same-widths items)
(let ([max-width (apply max (map (λ (x) (send x get-width)) items))])
(for-each (λ (x) (send x min-width max-width)) items)))
(define (same-heights items)
(let ([max-height (apply max (map (λ (x) (send x get-height)) items))])
(for-each (λ (x) (send x min-height max-height)) items)))
(define wrap-edit%
(class text:hide-caret/selection%
(inherit begin-edit-sequence end-edit-sequence
get-max-width find-snip position-location)
(define/augment (on-set-size-constraint)
(begin-edit-sequence)
(let ([snip (find-snip 1 'after-or-none)])
(when (is-a? snip editor-snip%)
(send (send snip get-editor) begin-edit-sequence)))
(inner (void) on-set-size-constraint))
(define/augment (after-set-size-constraint)
(inner (void) after-set-size-constraint)
(let ([width (get-max-width)]
[snip (find-snip 1 'after-or-none)])
(when (is-a? snip editor-snip%)
(let ([b (box 0)])
(position-location 1 b #f #f #t)
(let ([new-width (- width 4 (unbox b))])
(when (> new-width 0)
(send snip resize new-width
17) ; smallest random number
(send snip set-max-height 'none))))
(send (send snip get-editor) end-edit-sequence)))
(end-edit-sequence))
(super-new)))
(define (get-plt-bitmap)
(make-object bitmap%
(build-path (collection-path "icons")
(if (< (get-display-depth) 8)
"pltbw.gif"
"PLT-206.png"))))
;
;
;
; ; ;
; ; ;
; ; ; ;
; ;;; ; ;;; ;;;; ; ; ;;;; ;;; ; ; ;; ;;;;
; ; ; ;; ; ; ; ; ; ; ; ;; ;; ;
; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;; ; ; ; ; ;; ; ; ;; ; ;
; ;;;;; ; ;;; ;;;; ;;; ; ;; ;;; ; ; ;;;;
;
;
;
(define (about-drscheme)
(let* ([e (make-object wrap-edit%)]
[main-text (make-object wrap-edit%)]
[plt-bitmap (get-plt-bitmap)]
[plt-icon (if (send plt-bitmap ok?)
(make-object image-snip% plt-bitmap)
(let ([i (make-object string-snip%)]
[label "[lambda]"])
(send i insert label (string-length label) 0)
i))]
[editor-snip (make-object editor-snip% e #f)]
[f (make-object about-frame% main-text)]
[main-panel (send f get-area-container)]
[editor-canvas (make-object editor-canvas% main-panel)]
[button-panel (make-object horizontal-panel% main-panel)]
[top (make-object style-delta% 'change-alignment 'top)]
[d-usual (make-object style-delta% 'change-family 'decorative)]
[d-dr (make-object style-delta%)]
[d-http (make-object style-delta%)]
[insert/clickback
(λ (str clickback)
(send e change-style d-http)
(let* ([before (send e get-start-position)]
[_ (send e insert str)]
[after (send e get-start-position)])
(send e set-clickback before after
(λ (a b c) (clickback))
d-http))
(send e change-style d-usual))]
[insert-url/external-browser
(λ (str url)
(insert/clickback str (λ () (send-url url))))])
(send* d-http
(copy d-usual)
(set-delta-foreground "BLUE")
(set-delta 'change-underline #t))
(send* d-usual
(set-delta-foreground "BLACK")
(set-delta 'change-underline #f))
(send* d-dr (copy d-usual) (set-delta 'change-bold))
(send d-usual set-weight-on 'normal)
(send* editor-canvas
(set-editor main-text)
(stretchable-width #t)
(stretchable-height #t))
(if (send plt-bitmap ok?)
(send* editor-canvas
(min-width (floor (+ (* 5/2 (send plt-bitmap get-width)) 50)))
(min-height (+ (send plt-bitmap get-height) 50)))
(send* editor-canvas
(min-width 500)
(min-height 400)))
(send* e
(change-style d-dr)
(insert (format (string-constant welcome-to-drscheme-version/language)
(version:version)
(this-language)))
(change-style d-usual))
(send e insert " by ")
(insert-url/external-browser "PLT" "http://www.plt-scheme.org/")
(send* e
(insert ".\n\n")
(insert (get-authors))
(insert "\n\nFor licensing information see "))
(insert/clickback "our software license"
(λ () (help-desk:goto-plt-license)))
(send* e
(insert ".\n\nBased on:\n ")
(insert (banner)))
(when (or (eq? (system-type) 'macos)
(eq? (system-type) 'macosx))
(send* e
(insert " The A List (c) 1997-2001 Kyle Hammond\n")))
(let ([tools (sort (drscheme:tools:get-successful-tools)
(lambda (a b)
(string<? (path->string (drscheme:tools:successful-tool-spec a))
(path->string (drscheme:tools:successful-tool-spec b)))))])
(unless (null? tools)
(let loop ([actions1 '()] [actions2 '()] [tools tools])
(if (pair? tools)
(let* ([successful-tool (car tools)]
[name (drscheme:tools:successful-tool-name successful-tool)]
[spec (drscheme:tools:successful-tool-spec successful-tool)]
[bm (drscheme:tools:successful-tool-bitmap successful-tool)]
[url (drscheme:tools:successful-tool-url successful-tool)])
(define (action)
(send e insert " ")
(when bm
(send* e
(insert (make-object image-snip% bm))
(insert #\space)))
(let ([name (or name (format "~a" spec))])
(cond [url (insert-url/external-browser name url)]
[else (send e insert name)]))
(send e insert #\newline))
(if name
(loop (cons action actions1) actions2 (cdr tools))
(loop actions1 (cons action actions2) (cdr tools))))
(begin (send e insert "\nInstalled tools:\n")
(for-each (λ (act) (act)) (reverse actions1))
;; (send e insert "Installed anonymous tools:\n")
(for-each (λ (act) (act)) (reverse actions2)))))))
(send e insert "\n")
(send e insert (get-translating-acks))
(let* ([docs-button (new button%
[label (string-constant help-desk)]
[parent button-panel]
[callback (λ (x y) (help-desk:help-desk))])])
(send docs-button focus))
(send button-panel stretchable-height #f)
(send button-panel set-alignment 'center 'center)
(send* e
(auto-wrap #t)
(set-autowrap-bitmap #f))
(send* main-text
(set-autowrap-bitmap #f)
(auto-wrap #t)
(insert plt-icon)
(insert editor-snip)
(change-style top 0 2)
(hide-caret #t))
(send f reflow-container)
(send* main-text
(set-position 1)
(scroll-to-position 0)
(lock #t))
(send* e
(set-position 0)
(scroll-to-position 0)
(lock #t))
(when (eq? (system-type) 'macosx)
;; otherwise, the focus is the tour button, as above
(send editor-canvas focus))
(send f show #t)
f))
;
;
;
; ; ; ;
; ;
; ; ; ;
; ; ; ;;;; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;;
; ;;; ; ;; ; ; ; ;; ;
; ;
; ;
; ;
;; switch-language-to : (is-a?/c top-level-window<%>) symbol -> void
;; doesn't return if the language changes
(define (switch-language-to parent other-language)
(define-values (other-are-you-sure other-cancel other-accept-and-quit)
(let loop ([languages (all-languages)]
[are-you-sures (string-constants are-you-sure-you-want-to-switch-languages)]
[cancels (string-constants cancel)]
[accept-and-quits (if (eq? (system-type) 'windows)
(string-constants accept-and-exit)
(string-constants accept-and-quit))])
(cond
[(null? languages) (error 'app.ss ".1")]
[(equal? other-language (car languages))
(values (car are-you-sures)
(car cancels)
(car accept-and-quits))]
[else (loop (cdr languages)
(cdr are-you-sures)
(cdr cancels)
(cdr accept-and-quits))])))
(define dialog (make-object dialog% (string-constant drscheme) parent 400))
(define (make-section are-you-sure cancel-label quit-label)
(define text (make-object text:hide-caret/selection%))
(define ec (instantiate editor-canvas% ()
(parent dialog)
(editor text)
(style '(no-hscroll))))
(define bp (instantiate horizontal-panel% ()
(parent dialog)
(alignment '(right center))))
(define-values (quit cancel)
(gui-utils:ok/cancel-buttons
bp
(λ (x y)
(set! cancelled? #f)
(send dialog show #f))
(λ (x y)
(send dialog show #f))
quit-label
cancel-label))
(send ec set-line-count 3)
(send text auto-wrap #t)
(send text set-autowrap-bitmap #f)
(send text insert are-you-sure)
(send text set-position 0 0))
(define cancelled? #t)
(make-section other-are-you-sure
other-cancel
other-accept-and-quit)
(make-section (string-constant are-you-sure-you-want-to-switch-languages)
(string-constant cancel)
(if (eq? (system-type) 'windows)
(string-constant accept-and-exit)
(string-constant accept-and-quit)))
(send dialog show #t)
(unless cancelled?
(let ([set-language? #t])
(exit:insert-on-callback
(λ ()
(when set-language?
(set-language-pref other-language))))
(exit:exit)
(set! set-language? #f))))
(define (add-important-urls-to-help-menu help-menu additional)
(let* ([important-urls
(instantiate menu% ()
(parent help-menu)
(label (string-constant web-materials)))]
[tool-urls-menu
(instantiate menu% ()
(parent help-menu)
(label (string-constant tool-web-sites)))]
[add
(λ (name url . parent)
(instantiate menu-item% ()
(label name)
(parent (if (null? parent) important-urls (car parent)))
(callback
(λ (x y)
(send-url url)))))])
(add (string-constant drscheme-homepage) "http://www.drscheme.org/")
(add (string-constant plt-homepage) "http://www.plt-scheme.org/")
(add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/")
(add (string-constant how-to-design-programs) "http://www.htdp.org/")
(for-each (λ (tool)
(cond [(drscheme:tools:successful-tool-url tool)
=>
(λ (url)
(add (drscheme:tools:successful-tool-name tool) url tool-urls-menu))]))
(drscheme:tools:get-successful-tools))
(let loop ([additional additional])
(cond
[(pair? additional)
(let ([x (car additional)])
(when (and (pair? x)
(pair? (cdr x))
(null? (cddr x))
(string? (car x))
(string? (cadr x)))
(add (car x) (cadr x))))
(loop (cdr additional))]
[else (void)]))))
(define (add-language-items-to-help-menu help-menu)
(let ([added-any? #f])
(for-each (λ (native-lang-string language)
(unless (equal? (this-language) language)
(unless added-any?
(make-object separator-menu-item% help-menu)
(set! added-any? #t))
(instantiate menu-item% ()
(label native-lang-string)
(parent help-menu)
(callback (λ (x1 x2) (switch-language-to #f language))))))
good-interact-strings
languages-with-good-labels)))
(define-values (languages-with-good-labels good-interact-strings)
(let loop ([langs (all-languages)]
[strs (string-constants interact-with-drscheme-in-language)]
[good-langs '()]
[good-strs '()])
(cond
[(null? strs) (values (reverse good-langs)
(reverse good-strs))]
[else (let ([str (car strs)]
[lang (car langs)])
(if (andmap (λ (char) (send normal-control-font screen-glyph-exists? char #t))
(string->list str))
(loop (cdr langs)
(cdr strs)
(cons lang good-langs)
(cons str good-strs))
(loop (cdr langs) (cdr strs) good-langs good-strs)))])))

62
collects/drscheme/private/auto-language.ss
View File

@ -1,62 +0,0 @@
(module auto-language mzscheme
(require mred
mzlib/class)
(provide pick-new-language looks-like-module?)
(define reader-tag "#reader")
(define (pick-new-language text all-languages module-language module-language-settings)
(with-handlers ([exn:fail:read? (λ (x) (values #f #f))])
(let ([found-language? #f]
[settings #f])
(for-each
(λ (lang)
(let ([lang-spec (send lang get-reader-module)])
(when lang-spec
(let* ([lines (send lang get-metadata-lines)]
[str (send text get-text
0
(send text paragraph-end-position (- lines 1)))]
[sp (open-input-string str)])
(when (regexp-match #rx"#reader" sp)
(let ([spec-in-file (read sp)])
(when (equal? lang-spec spec-in-file)
(set! found-language? lang)
(set! settings (send lang metadata->settings str))
(send text while-unlocked
(λ ()
(send text delete 0 (send text paragraph-start-position lines)))))))))))
all-languages)
;; check to see if it looks like the module language.
(unless found-language?
(when module-language
(when (looks-like-module? text)
(set! found-language? module-language)
(set! settings module-language-settings))))
(values found-language?
settings))))
(define (looks-like-module? text)
(or (looks-like-new-module-style? text)
(looks-like-old-module-style? text)))
(define (looks-like-old-module-style? text)
(with-handlers ((exn:fail:read? (λ (x) #f)))
(let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)]
[r1 (parameterize ([read-accept-reader #f]) (read tp))]
[r2 (parameterize ([read-accept-reader #f]) (read tp))])
(and (eof-object? r2)
(pair? r1)
(eq? (car r1) 'module)))))
(define (looks-like-new-module-style? text)
(let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)]
[l1 (with-handlers ([exn:fail? (lambda (exn) eof)])
;; If tp contains a snip, read-line fails.
(read-line tp))])
(and (string? l1)
(regexp-match #rx"#lang .*$" l1)))))

305
collects/drscheme/private/bindings-browser.ss
View File

@ -1,305 +0,0 @@
#|
CODE COPIED (with permission ...) from syntax-browser.ss
desperately seeking abstraction.
Marshalling (and hence the 'read' method of the snipclass omitted for fast prototyping
|#
(module bindings-browser mzscheme
(require mzlib/pretty
mzlib/list
mzlib/class
mred
mzlib/match
mzlib/string
(lib "marks.ss" "stepper" "private")
mzlib/contract)
(provide render-bindings/snip)
(define (render-bindings/snip stx) (make-object bindings-snip% stx))
(define bindings-snipclass%
(class snip-class%
; not overriding read
(super-instantiate ())))
(define bindings-snipclass (make-object bindings-snipclass%))
(send bindings-snipclass set-version 1)
(send bindings-snipclass set-classname "drscheme:bindings-snipclass%")
(send (get-the-snip-class-list) add bindings-snipclass)
(define bindings-snip%
(class editor-snip%
(init-field bindings)
(unless ((flat-contract-predicate (listof (list/c syntax? any/c))) bindings)
(error 'bindings-snip% "expected bindings association list, given ~v" bindings))
(define/public (get-bindings) bindings)
(define/override (copy) (make-object bindings-snip% bindings))
(define/override (write stream)
(error 'bindings-snip "'write' not implemented for bindings-snip"))
(define output-text (make-object text%))
(define output-port (make-text-port output-text))
(define/private (make-modern text)
(send text change-style
(make-object style-delta% 'change-family 'modern)
0
(send text last-position)))
(begin (parameterize ([current-output-port output-port]
[pretty-print-columns 30])
(for-each
(λ (binding-pair)
(let* ([stx (car binding-pair)]
[value (cadr binding-pair)])
; this totally destroys the 'output-port' abstraction. I don't know
; how to enrich the notion of an output-port to get 'bold'ing to
; work otherwise...
(let* ([before (send output-text last-position)])
(pretty-print (syntax-object->datum stx))
(let* ([post-newline (send output-text last-position)])
(send output-text delete post-newline) ; delete the trailing \n. yuck!
(send output-text insert " ")
(send output-text change-style
(make-object style-delta% 'change-bold)
before (- post-newline 1)))
(pretty-print value))))
bindings))
(send output-text delete (send output-text last-position)) ; delete final trailing \n
(make-modern output-text))
(define outer-t (make-object text%))
(super-new
(editor outer-t)
(with-border? #f)
(left-margin 3)
(top-margin 0)
(right-margin 0)
(bottom-margin 0)
(left-inset 1)
(top-inset 0)
(right-inset 0)
(bottom-inset 0))
(define inner-t (make-object text%))
(define inner-es (instantiate editor-snip% ()
(editor inner-t)
(with-border? #f)
(left-margin 0)
(top-margin 0)
(right-margin 0)
(bottom-margin 0)
(left-inset 0)
(top-inset 0)
(right-inset 0)
(bottom-inset 0)))
(define details-shown? #t)
(inherit show-border set-tight-text-fit)
(define/private (hide-details)
(when details-shown?
(send outer-t lock #f)
(show-border #f)
(set-tight-text-fit #t)
(send outer-t release-snip inner-es)
(send outer-t delete (send outer-t last-position))
(send outer-t lock #t)
(set! details-shown? #f)))
(define/private (show-details)
(unless details-shown?
(send outer-t lock #f)
(show-border #t)
(set-tight-text-fit #f)
(send outer-t insert #\newline
(send outer-t last-position)
(send outer-t last-position))
(send outer-t insert inner-es
(send outer-t last-position)
(send outer-t last-position))
(send outer-t lock #t)
(set! details-shown? #t)))
(send outer-t insert (make-object turn-snip%
(λ () (hide-details))
(λ () (show-details))))
(send outer-t insert (format "bindings\n"))
(send outer-t insert inner-es)
(make-modern outer-t)
(send inner-t insert (instantiate editor-snip% ()
(editor output-text)
(with-border? #f)
(left-margin 0)
(top-margin 0)
(right-margin 0)
(bottom-margin 0)
(left-inset 0)
(top-inset 0)
(right-inset 0)
(bottom-inset 0)))
(send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)
(send output-text hide-caret #t)
(send inner-t hide-caret #t)
(send outer-t hide-caret #t)
(send output-text lock #t)
(send inner-t lock #t)
(send outer-t lock #t)
(hide-details)
(inherit set-snipclass)
(set-snipclass bindings-snipclass)))
(define black-style-delta (make-object style-delta% 'change-normal-color))
(define green-style-delta (make-object style-delta%))
(send green-style-delta set-delta-foreground "forest green")
(define turn-snip%
(class snip%
(init-field on-up on-down)
;; state : (union 'up 'down 'up-click 'down-click))
(init-field [state 'up])
(define/override (copy)
(instantiate turn-snip% ()
(on-up on-up)
(on-down on-down)
(state state)))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([bitmap (case state
[(up) up-bitmap]
[(down) down-bitmap]
[(up-click) up-click-bitmap]
[(down-click) down-click-bitmap])])
(cond
[(send bitmap ok?)
(send dc draw-bitmap bitmap x y)]
[(send dc draw-rectangle x y 10 10)
(send dc drawline x y 10 10)])))
(define/override (get-extent dc x y w h descent space lspace rspace)
(set-box/f! descent 0)
(set-box/f! space 0)
(set-box/f! lspace 0)
(set-box/f! rspace 0)
(set-box/f! w arrow-snip-width)
(set-box/f! h arrow-snip-height))
(define/override (on-event dc x y editorx editory evt)
(let ([snip-evt-x (- (send evt get-x) x)]
[snip-evt-y (- (send evt get-y) y)])
(cond
[(send evt button-down? 'left)
(set-state (case state
[(up) 'up-click]
[(down) 'down-click]
[else 'down-click]))]
[(and (send evt button-up? 'left)
(<= 0 snip-evt-x arrow-snip-width)
(<= 0 snip-evt-y arrow-snip-height))
(set-state (case state
[(up up-click)
(on-down)
'down]
[(down down-click)
(on-up)
'up]
[else 'down]))]
[(send evt button-up? 'left)
(set-state (case state
[(up up-click) 'up]
[(down down-click) 'down]
[else 'up]))]
[(and (send evt get-left-down)
(send evt dragging?)
(<= 0 snip-evt-x arrow-snip-width)
(<= 0 snip-evt-y arrow-snip-height))
(set-state (case state
[(up up-click) 'up-click]
[(down down-click) 'down-click]
[else 'up-click]))]
[(and (send evt get-left-down)
(send evt dragging?))
(set-state (case state
[(up up-click) 'up]
[(down down-click) 'down]
[else 'up-click]))]
[else
(super on-event dc x y editorx editory evt)])))
(inherit get-admin)
(define/private (set-state new-state)
(unless (eq? state new-state)
(set! state new-state)
(let ([admin (get-admin)])
(when admin
(send admin needs-update this 0 0 arrow-snip-width arrow-snip-height)))))
(define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor)
(super-instantiate ())
(inherit get-flags set-flags)
(set-flags (cons 'handles-events (get-flags)))))
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
(define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png")))
(define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png")))
(define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))
(define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png")))
(define arrow-snip-height
(max 10
(send up-bitmap get-height)
(send down-bitmap get-height)
(send up-click-bitmap get-height)
(send down-click-bitmap get-height)))
(define arrow-snip-width
(max 10
(send up-bitmap get-width)
(send down-bitmap get-width)
(send up-click-bitmap get-width)
(send down-click-bitmap get-width)))
(define arrow-snip-cursor (make-object cursor% 'arrow))
;; make-text-port : text -> port
;; builds a port from a text object.
(define (make-text-port text)
(make-output-port #f
always-evt
(λ (s start end flush?)
(send text insert (substring s start end)
(send text last-position)
(send text last-position))
(- end start))
void)))
; one trivial test case:
;
;(require bindings-browser)
;
;(let ([es (render-bindings/snip `((,#`a 3) (,#`b 4) (,#`c (1 3 4))))])
; (define f (make-object frame% "frame" #f 850 500))
; (define mb (make-object menu-bar% f))
; (define edit-menu (make-object menu% "Edit" mb))
; (define t (make-object text%))
; (define ec (make-object editor-canvas% f t))
; (append-editor-operation-menu-items edit-menu)
; (send t insert es)
; (send f show #t))

2005
collects/drscheme/private/debug.ss
View File

File diff suppressed because it is too large Load Diff

280
collects/drscheme/private/drscheme-normal.ss
View File

@ -1,280 +0,0 @@
(module drscheme-normal mzscheme
(require mred
mzlib/class
mzlib/cmdline
(lib "bday.ss" "framework" "private"))
; (current-load text-editor-load-handler)
(define files-to-open
(command-line
(case (system-type)
[(windows) "DrScheme.exe"]
[(macosx) "drscheme" #;"DrScheme"]
[else "drscheme"])
(current-command-line-arguments)
(args filenames filenames)))
(define icons-bitmap
(let ([icons (collection-path "icons")])
(lambda (name)
(make-object bitmap% (build-path icons name)))))
;; updates the command-line-arguments with only the files
;; to open. See also main.ss.
(current-command-line-arguments (apply vector files-to-open))
(define-values (texas-independence-day? halloween?)
(let* ([date (seconds->date (current-seconds))]
[month (date-month date)]
[day (date-day date)])
(values (and (= 3 month) (= 2 day))
(and (= 10 month) (= 31 day)))))
(define high-color? ((get-display-depth) . > . 8))
(define special-state #f)
(define normal-bitmap #f) ; set by load-magic-images
(define-struct magic-image (chars filename bitmap))
(define (magic-img str img)
(make-magic-image (reverse (string->list str)) img #f))
;; magic strings and their associated images. There should not be a string
;; in this list that is a prefix of another.
(define magic-images
(list (magic-img "larval" "PLT-206-larval.png")
(magic-img "mars" "PLT-206-mars.jpg")))
(define (load-magic-images)
(set! load-magic-images void) ; run only once
(unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png")))
(for-each (λ (magic-image)
(unless (magic-image-bitmap magic-image)
(set-magic-image-bitmap!
magic-image
(icons-bitmap (magic-image-filename magic-image)))))
magic-images))
(define longest-magic-string
(apply max (map (λ (s) (length (magic-image-chars s))) magic-images)))
(define key-codes null)
(define (find-magic-image)
(define (prefix? l1 l2)
(or (null? l1)
(and (pair? l2)
(eq? (car l1) (car l2))
(prefix? (cdr l1) (cdr l2)))))
(ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i))
magic-images))
(define (add-key-code new-code)
(set! key-codes
(cons
new-code
(let loop ([n (- longest-magic-string 2)] [l key-codes])
(cond [(null? l) null]
[(zero? n) null]
[else (let ([p (loop (sub1 n) (cdr l))])
(if (eq? p (cdr l))
l
(cons (car l) p)))])))))
(let ([set-splash-bitmap
(dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)])
((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer)
(λ (evt)
(let ([ch (send evt get-key-code)])
(when (char? ch)
;; as soon as something is typed, load the bitmaps
(load-magic-images)
(add-key-code ch)
(let ([match (find-magic-image)])
(when match
(set! key-codes null)
(set-splash-bitmap
(if (eq? special-state match)
(begin (set! special-state #f) normal-bitmap)
(begin (set! special-state match)
(magic-image-bitmap match)))))))))))
(when (eb-bday?)
(let ()
(define main-size 260)
(define pi (atan 0 -1))
(define eli (icons-bitmap "eli-purple.jpg"))
(define bitmap (make-object bitmap% main-size main-size))
(define bdc (make-object bitmap-dc% bitmap))
(define outer-color (send the-color-database find-color "darkorange"))
(define inner-color (send the-color-database find-color "green"))
(define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
(define hebrew-str " ףוס ןיא ףוס ןיא")
(define (draw-letter dc cx cy angle radius letter color)
(let ([x (+ cx (* (cos angle) radius))]
[y (- cy (* (sin angle) radius))])
(send bdc set-text-foreground color)
(send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
(define (draw-single-loop str dc offset cx cy radius font-size color)
(send dc set-font (send the-font-list find-or-create-font font-size 'modern))
(let loop ([i (string-length str)])
(unless (zero? i)
(draw-letter dc
cx
cy
(normalize-angle
(+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
(/ pi 2)
offset))
radius
(string (string-ref str (- i 1)))
color)
(loop (- i 1)))))
(define (normalize-angle angle)
(cond
[(<= 0 angle (* 2 pi)) angle]
[(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
[else (normalize-angle (- angle (* 2 pi)))]))
(define splash-canvas ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-canvas)))
(define (draw-single-step dc offset)
(send bdc draw-bitmap eli 0 0)
(draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
(draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
(send splash-canvas on-paint))
(define gc-b
(with-handlers ([exn:fail? (lambda (x)
(printf "~s\n" (exn-message x))
#f)])
(let ([b (icons-bitmap "recycle.gif")])
(cond
[(send b ok?)
(let ([gbdc (make-object bitmap-dc% b)]
[ebdc (make-object bitmap-dc% eli)]
[color1 (make-object color%)]
[color2 (make-object color%)]
[avg (lambda (x y) (floor (* (/ x 255) y)))]
[ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
[oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
(let loop ([i (send b get-width)])
(unless (zero? i)
(let loop ([j (send b get-height)])
(unless (zero? j)
(let ([x (- i 1)]
[y (- j 1)])
(send gbdc get-pixel x y color1)
(send ebdc get-pixel (+ x ox) (+ y oy) color2)
(send color1 set
(avg (send color1 red) (send color2 red))
(avg (send color1 green) (send color2 green))
(avg (send color1 blue) (send color2 blue)))
(send gbdc set-pixel x y color1)
(loop (- j 1)))))
(loop (- i 1))))
(send gbdc set-bitmap #f)
(send ebdc set-bitmap #f)
b)]
[else #f]))))
(define (eli-paint dc)
(send dc draw-bitmap bitmap 0 0))
(define (eli-event evt)
(cond
[(send evt leaving?)
((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) orig-paint)
(when gc-b
(unregister-collecting-blit splash-canvas))
(send splash-canvas refresh)
(when draw-thread
(kill-thread draw-thread)
(set! draw-thread #f))]
[(send evt entering?)
((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) eli-paint)
(when gc-b
(register-collecting-blit splash-canvas
(floor (- (/ main-size 2)
(/ (send gc-b get-width) 2)))
(floor (- (/ main-size 2)
(/ (send gc-b get-height) 2)))
(send gc-b get-width)
(send gc-b get-height)
gc-b gc-b))
(send splash-canvas refresh)
(unless draw-thread
(start-thread))]))
(define splash-eventspace ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-eventspace)))
(define draw-next-state
(let ([o 0])
(lambda ()
(let ([s (make-semaphore 0)])
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
(λ ()
(draw-single-step bdc o)
(semaphore-post s))))
(semaphore-wait s))
(let ([next (+ o (/ pi 60))])
(set! o (if (< next (* 2 pi))
next
(- next (* 2 pi))))))))
(define draw-thread #f)
(define (start-thread)
(set! draw-thread
(thread
(λ ()
(let loop ()
(draw-next-state)
(sleep .01)
(loop))))))
(define orig-paint ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-paint-callback)))
(draw-next-state)
((dynamic-require '(lib "splash.ss" "framework") 'set-splash-event-callback) eli-event)
(send splash-canvas refresh)))
((dynamic-require '(lib "splash.ss" "framework") 'start-splash)
(build-path (collection-path "icons")
(cond
[texas-independence-day?
"texas-plt-bw.gif"]
[(and halloween? high-color?)
"PLT-pumpkin.png"]
[high-color? "PLT-206.png"]
[(= (get-display-depth) 1)
"pltbw.gif"]
[else
"plt-flat.gif"]))
"DrScheme"
99)
(when (getenv "PLTDRBREAK")
(printf "PLTDRBREAK: creating break frame\n")
(let ([to-break (eventspace-handler-thread (current-eventspace))])
(parameterize ([current-eventspace (make-eventspace)])
(let* ([f (new frame% (label "Break DrScheme"))]
[b (new button%
(label "Break Main Thread")
(callback
(λ (x y)
(break-thread to-break)))
(parent f))]
[b (new button%
(label "Break All Threads")
(callback
(λ (x y)
((dynamic-require '(lib "key.ss" "drscheme" "private") 'break-threads))))
(parent f))])
(send f show #t)))))
(dynamic-require '(lib "tool-lib.ss" "drscheme") #f))

316
collects/drscheme/private/drsig.ss
View File

@ -1,316 +0,0 @@
(module drsig scheme/base
(require scheme/unit)
(provide drscheme:eval^
drscheme:debug^
drscheme:module-language^
drscheme:get-collection^
drscheme:main^
drscheme:init^
drscheme:language-configuration^
drscheme:language-configuration/internal^
drscheme:tools^
drscheme:get/extend^
drscheme:unit^
drscheme:frame^
drscheme:program^
drscheme:text^
drscheme:rep^
drscheme:app^
drscheme:draw-arrow^
drscheme:help-desk^
drscheme:language^
drscheme:multi-file-search^
drscheme:module-overview^
drscheme:font^
drscheme:modes^
drscheme:tool-exports^
drscheme:tool^
drscheme:tool-cm^)
(define-signature drscheme:modes-cm^
())
(define-signature drscheme:modes^ extends drscheme:modes-cm^
(add-mode
get-modes
add-initial-modes
(struct mode (name surrogate repl-submit matches-language)
#:omit-constructor)))
(define-signature drscheme:font-cm^
())
(define-signature drscheme:font^ extends drscheme:font-cm^
(setup-preferences))
(define-signature drscheme:debug-cm^
(profile-definitions-text-mixin
profile-tab-mixin
profile-unit-frame-mixin
test-coverage-interactions-text-mixin
test-coverage-definitions-text-mixin
test-coverage-tab-mixin))
(define-signature drscheme:debug^ extends drscheme:debug-cm^
(make-debug-error-display-handler
make-debug-eval-handler
error-display-handler/stacktrace
test-coverage-enabled
profiling-enabled
add-prefs-panel
get-error-color
hide-backtrace-window
show-backtrace-window
open-and-highlight-in-file
get-cm-key
;show-error-and-highlight
;print-bug-to-stderr
;display-srclocs-in-error
;show-syntax-error-context
))
(define-signature drscheme:module-langauge-cm^
(module-language<%>))
(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^
(add-module-language
module-language-put-file-mixin))
(define-signature drscheme:get-collection-cm^ ())
(define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^
(get-file/collection))
(define-signature drscheme:main-cm^ ())
(define-signature drscheme:main^ extends drscheme:main-cm^ ())
(define-signature drscheme:init-cm^
())
(define-signature drscheme:init^ extends drscheme:init-cm^
(original-output-port
original-error-port
original-error-display-handler
primitive-eval
primitive-load
error-display-handler-message-box-title
system-custodian
system-eventspace
system-namespace
first-dir))
(define-signature drscheme:language-configuration-cm^
())
(define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^
(add-language
get-languages
(struct language-settings (language settings))
get-settings-preferences-symbol
language-dialog
fill-language-dialog))
(define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^
(add-info-specified-languages
get-default-language-settings
settings-preferences-symbol
get-all-scheme-manual-keywords
add-built-in-languages
not-a-language-language<%>))
(define-signature drscheme:tools-cm^
())
(define-signature drscheme:tools^ extends drscheme:tools-cm^
((struct successful-tool (spec bitmap name url))
get-successful-tools
only-in-phase
load/invoke-all-tools
add-prefs-panel))
(define-signature drscheme:get/extend-cm^
())
(define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^
(extend-tab
extend-interactions-text
extend-definitions-text
extend-interactions-canvas
extend-definitions-canvas
extend-unit-frame
get-tab
get-interactions-text
get-definitions-text
get-interactions-canvas
get-definitions-canvas
get-unit-frame))
(define-signature drscheme:unit-cm^
(tab%
tab<%>
frame%
frame<%>
definitions-canvas%
get-definitions-text%
definitions-text<%>
interactions-canvas%))
(define-signature drscheme:unit^ extends drscheme:unit-cm^
(open-drscheme-window
find-symbol
get-program-editor-mixin
add-to-program-editor-mixin
(struct teachpack-callbacks (get-names remove add))))
(define-signature drscheme:frame-cm^
(<%>
mixin
basics-mixin
basics<%>))
(define-signature drscheme:frame^ extends drscheme:frame-cm^
(create-root-menubar
add-keybindings-item
planet-spec?))
(define-signature drscheme:program-cm^
(frame%))
(define-signature drscheme:program^ extends drscheme:program-cm^
())
(define-signature drscheme:eval-cm^
())
(define-signature drscheme:eval^ extends drscheme:eval-cm^
(expand-program
expand-program/multiple
traverse-program/multiple
build-user-eventspace/custodian
set-basic-parameters
get-snip-classes))
(define-signature drscheme:text-cm^
(text<%>
text%))
(define-signature drscheme:text^ extends drscheme:text-cm^
())
(define-signature drscheme:setup-cm^
())
(define-signature drscheme:setup^ extends drscheme:setup-cm^
(do-setup))
(define-signature drscheme:rep-cm^
(drs-bindings-keymap-mixin
text%
text<%>
context<%>))
(define-signature drscheme:rep^ extends drscheme:rep-cm^
(current-rep
current-language-settings
current-value-port
get-drs-bindings-keymap
error-delta
get-welcome-delta
get-dark-green-delta
drs-autocomplete-mixin))
(define-signature drscheme:app-cm^
())
(define-signature drscheme:app^ extends drscheme:app-cm^
(about-drscheme
add-language-items-to-help-menu
add-important-urls-to-help-menu
switch-language-to))
(define-signature drscheme:draw-arrow-cm^
())
(define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^
(draw-arrow))
(define-signature drscheme:help-desk-cm^
())
(define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^
(help-desk
goto-plt-license
get-docs))
(define-signature drscheme:language-cm^
(language<%>
module-based-language<%>
simple-module-based-language<%>
simple-module-based-language%
simple-module-based-language->module-based-language-mixin
module-based-language->language-mixin))
(define-signature drscheme:language^ extends drscheme:language-cm^
(get-default-mixin
extend-language-interface
get-language-extensions
create-module-based-launcher
create-module-based-stand-alone-executable
create-module-based-distribution
create-distribution-for-executable
create-executable-gui
put-executable
;(struct loc (source position line column span))
(struct text/pos (text start end))
(struct simple-settings (case-sensitive
printing-style
fraction-style
show-sharing
insert-newlines
annotations))
simple-settings->vector
simple-module-based-language-config-panel
add-snip-value
setup-setup-values
register-capability
capability-registered?
get-capability-default
get-capability-contract))
(define-signature drscheme:multi-file-search-cm^
())
(define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^
(multi-file-search))
(define-signature drscheme:module-overview-cm^
())
(define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^
(module-overview
make-module-overview-pasteboard
fill-pasteboard))
(define-signature drscheme:tool-exports-cm^
())
(define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^
(phase1
phase2))
(define-signature drscheme:tool-cm^
((open (prefix drscheme:debug: drscheme:debug-cm^))
(open (prefix drscheme:unit: drscheme:unit-cm^))
(open (prefix drscheme:rep: drscheme:rep-cm^))
(open (prefix drscheme:frame: drscheme:frame-cm^))
(open (prefix drscheme:get/extend: drscheme:get/extend-cm^))
(open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^))
(open (prefix drscheme:language: drscheme:language-cm^))
(open (prefix drscheme:help-desk: drscheme:help-desk-cm^))
(open (prefix drscheme:eval: drscheme:eval-cm^))
(open (prefix drscheme:modes: drscheme:modes-cm^))))
(define-signature drscheme:tool^
((open (prefix drscheme:debug: drscheme:debug^))
(open (prefix drscheme:unit: drscheme:unit^))
(open (prefix drscheme:rep: drscheme:rep^))
(open (prefix drscheme:frame: drscheme:frame^))
(open (prefix drscheme:get/extend: drscheme:get/extend^))
(open (prefix drscheme:language-configuration: drscheme:language-configuration^))
(open (prefix drscheme:language: drscheme:language^))
(open (prefix drscheme:help-desk: drscheme:help-desk^))
(open (prefix drscheme:eval: drscheme:eval^))
(open (prefix drscheme:modes: drscheme:modes^)))))

221
collects/drscheme/private/eval.ss
View File

@ -1,221 +0,0 @@
(module eval mzscheme
(require mred
mzlib/unit
mzlib/port
mzlib/class
syntax/toplevel
framework
"drsig.ss")
;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace
;; these things are for effect only!
(require (lib "cache-image-snip.ss" "mrlib")
#;
(prefix foo htdp/matrix))
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(provide eval@)
(define-unit eval@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:unit: drscheme:unit^])
(export drscheme:eval^)
(define (traverse-program/multiple language-settings
init
kill-termination)
(let-values ([(eventspace custodian)
(build-user-eventspace/custodian
language-settings
init
kill-termination)])
(let ([language (drscheme:language-configuration:language-settings-language
language-settings)]
[settings (drscheme:language-configuration:language-settings-settings
language-settings)])
(λ (input iter complete-program?)
(let-values ([(port src)
(cond
[(input-port? input) (values input #f)]
[else (values
(let* ([text (drscheme:language:text/pos-text input)]
[start (drscheme:language:text/pos-start input)]
[end (drscheme:language:text/pos-end input)]
[text-port (open-input-text-editor text start end values
(send text get-port-name))])
(port-count-lines! text-port)
(let* ([line (send text position-paragraph start)]
[column (- start (send text paragraph-start-position line))]
[relocated-port (relocate-input-port text-port
(+ line 1)
column
(+ start 1))])
(port-count-lines! relocated-port)
relocated-port))
(drscheme:language:text/pos-text input))])])
(parameterize ([current-eventspace eventspace])
(queue-callback
(λ ()
(let ([read-thnk
(if complete-program?
(send language front-end/complete-program port settings)
(send language front-end/interaction port settings))])
(let loop ()
(let ([in (read-thnk)])
(cond
[(eof-object? in)
(iter in (λ () (void)))]
[else
(iter in (λ () (loop)))]))))))))))))
(define (expand-program/multiple language-settings
eval-compile-time-part?
init
kill-termination)
(let ([res (traverse-program/multiple language-settings init kill-termination)])
(λ (input iter complete-program?)
(let ([expanding-iter
(λ (rd cont)
(cond
[(eof-object? rd) (iter rd cont)]
[eval-compile-time-part?
(iter (expand-top-level-with-compile-time-evals rd) cont)]
[else (iter (expand rd) cont)]))])
(res input
expanding-iter
complete-program?)))))
(define (expand-program input
language-settings
eval-compile-time-part?
init
kill-termination
iter)
((expand-program/multiple
language-settings
eval-compile-time-part?
init
kill-termination)
input
iter
#t))
(define (build-user-eventspace/custodian language-settings init kill-termination)
(let* ([user-custodian (make-custodian)]
[eventspace (parameterize ([current-custodian user-custodian])
(make-eventspace))]
[language (drscheme:language-configuration:language-settings-language
language-settings)]
[settings (drscheme:language-configuration:language-settings-settings
language-settings)]
[eventspace-main-thread #f]
[run-in-eventspace
(λ (thnk)
(parameterize ([current-eventspace eventspace])
(let ([sema (make-semaphore 0)]
[ans #f])
(queue-callback
(λ ()
(let/ec k
(parameterize ([error-escape-handler
(let ([drscheme-expand-program-error-escape-handler
(λ () (k (void)))])
drscheme-expand-program-error-escape-handler)])
(set! ans (thnk))))
(semaphore-post sema)))
(semaphore-wait sema)
ans)))]
[drs-snip-classes (get-snip-classes)])
(run-in-eventspace
(λ ()
(current-custodian user-custodian)
(set-basic-parameters drs-snip-classes)
(drscheme:rep:current-language-settings language-settings)))
(send language on-execute settings run-in-eventspace)
(run-in-eventspace
(λ ()
(set! eventspace-main-thread (current-thread))
(init)
(break-enabled #t)))
(thread
(λ ()
(thread-wait eventspace-main-thread)
(kill-termination)))
(values eventspace user-custodian)))
;; get-snip-classes : -> (listof snipclass)
;; returns a list of the snip classes in the current eventspace
(define (get-snip-classes)
(let loop ([n (send (get-the-snip-class-list) number)])
(if (zero? n)
null
(cons (send (get-the-snip-class-list) nth (- n 1))
(loop (- n 1))))))
;; set-basic-parameters : (listof (is-a/c? snipclass%)) -> void
;; sets the parameters that are shared between the repl's initialization
;; and expand-program
(define (set-basic-parameters snip-classes)
(for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class))
snip-classes)
(current-thread-group (make-thread-group))
(current-command-line-arguments #())
(current-pseudo-random-generator (make-pseudo-random-generator))
(current-evt-pseudo-random-generator (make-pseudo-random-generator))
(read-curly-brace-as-paren #t)
(read-square-bracket-as-paren #t)
(error-print-width 250)
(current-ps-setup (make-object ps-setup%))
(current-namespace (make-namespace 'empty))
(for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x))
to-be-copied-module-names))
;; these module specs are copied over to each new user's namespace
(define to-be-copied-module-specs
(list 'mzscheme
'(lib "mzlib/foreign.ss")
'(lib "mred/mred.ss")
'(lib "mrlib/cache-image-snip.ss")
'(lib "mrlib/matrix-snip.ss")
'(lib "mzlib/pconvert-prop.ss")))
;; ensure that they are all here.
(for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs)
;; get the names of those modules.
(define to-be-copied-module-names
(let ([get-name
(λ (spec)
(if (symbol? spec)
spec
((current-module-name-resolver) spec #f #f)))])
(map get-name to-be-copied-module-specs)))
;; build-input-port : string[file-exists?] -> (values input any)
;; constructs an input port for the load handler. Also
;; returns a value representing the source of code read from the file.
(define (build-input-port filename)
(let* ([p (open-input-file filename)]
[chars (list (read-char p)
(read-char p)
(read-char p)
(read-char p))])
(close-input-port p)
(cond
[(equal? chars (string->list "WXME"))
(let ([text (make-object text%)])
(send text load-file filename)
(let ([port (open-input-text-editor text)])
(port-count-lines! port)
(values port text)))]
[else
(let ([port (open-input-file filename)])
(port-count-lines! port)
(values port filename))])))))

218
collects/drscheme/private/font.ss
View File

@ -1,218 +0,0 @@
(module font mzscheme
(require mzlib/unit
mzlib/class
"drsig.ss"
mred
framework
string-constants)
(define sc-smoothing-label (string-constant font-smoothing-label))
(define sc-smoothing-none (string-constant font-smoothing-none))
(define sc-smoothing-some (string-constant font-smoothing-some))
(define sc-smoothing-all (string-constant font-smoothing-all))
(define sc-smoothing-default (string-constant font-smoothing-default))
(provide font@)
(define-unit font@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
(export drscheme:font^)
(define (setup-preferences)
(preferences:add-panel
(list (string-constant font-prefs-panel-title)
#;(string-constant drscheme)) ;; thre is no help desk font configuration anymore ...
(λ (panel)
(letrec ([main (make-object vertical-panel% panel)]
[min-size 1]
[max-size 72]
[options-panel (make-object horizontal-panel% main)]
[size-panel (new group-box-panel%
(parent options-panel)
(label (string-constant font-size)))]
[adjust-font-size
(λ (f)
(preferences:set
'framework:standard-style-list:font-size
(f (preferences:get
'framework:standard-style-list:font-size))))]
[size-slider
(new slider%
(label #f)
(min-value min-size)
(max-value max-size)
(parent size-panel)
(callback
(λ (size evt)
(adjust-font-size
(λ (old-size)
(send size get-value)))))
(init-value
(preferences:get 'framework:standard-style-list:font-size)))]
[size-hp (new horizontal-pane% (parent size-panel))]
[mk-size-button
(λ (label chng)
(new button%
(parent size-hp)
(stretchable-width #t)
(callback
(λ (x y)
(adjust-font-size
(λ (old-size)
(min max-size (max min-size (chng old-size)))))))
(label label)))]
[size-sub1 (mk-size-button "-1" sub1)]
[size-add1 (mk-size-button "+1" add1)]
[mono-list 'mono-list-not-yet-computed]
[choice-panel
(new (class vertical-panel%
(define/private (force-cache receiver)
(when (eq? receiver font-name-control)
(when (symbol? mono-list)
(begin-busy-cursor)
(set! mono-list (get-face-list 'mono))
(send font-name-control clear)
(for-each
(λ (x) (send font-name-control append x))
(append mono-list (list (string-constant other...))))
(let ([pref (preferences:get 'framework:standard-style-list:font-name)])
(cond
[(member pref mono-list)
(send font-name-control set-string-selection pref)]
[else
(send font-name-control set-selection (length mono-list))]))
(end-busy-cursor))))
(define/override (on-subwindow-event receiver evt)
(unless (or (send evt moving?)
(send evt entering?)
(send evt leaving?))
(force-cache receiver))
(super on-subwindow-event receiver evt))
(define/override (on-subwindow-char receiver evt)
(force-cache receiver)
(super on-subwindow-char receiver evt))
(super-new [parent options-panel])))]
[font-name-control
(let* ([choice
(new choice%
(label (string-constant font-name))
(choices (list (preferences:get 'framework:standard-style-list:font-name)))
(parent choice-panel)
(stretchable-width #t)
(callback
(λ (font-name evt)
(let ([selection (send font-name get-selection)])
(cond
[(< selection (length mono-list))
(preferences:set
'framework:standard-style-list:font-name
(list-ref mono-list selection))]
[else
(let* ([all-faces (get-face-list)]
[init-choices
(let ([init (preferences:get 'framework:standard-style-list:font-name)])
(let loop ([faces all-faces]
[num 0])
(cond
[(null? faces) null]
[else
(let ([face (car faces)])
(if (equal? init face)
(list num)
(loop (cdr faces)
(+ num 1))))])))]
[choice (get-choices-from-user
(string-constant select-font-name)
(string-constant select-font-name)
all-faces
#f
init-choices)])
(when choice
(preferences:set
'framework:standard-style-list:font-name
(list-ref all-faces (car choice)))))])))))]
[font-name (preferences:get 'framework:standard-style-list:font-name)]
[set-choice-selection
(λ (font-name)
(cond
[(send choice find-string font-name)
(send choice set-string-selection font-name)]
[else
(send choice set-selection (- (send choice get-number) 1))]))])
(preferences:add-callback
'framework:standard-style-list:font-name
(λ (p v)
(set-choice-selection v)))
(set-choice-selection font-name)
choice)]
[smoothing-contol
(new choice%
(label sc-smoothing-label)
(choices (list sc-smoothing-none
sc-smoothing-some
sc-smoothing-all
sc-smoothing-default))
(parent choice-panel)
(stretchable-width #t)
(selection (case (preferences:get 'framework:standard-style-list:smoothing)
[(unsmoothed) 0]
[(partly-smoothed) 1]
[(smoothed) 2]
[(default) 3]))
(callback (λ (x y)
(preferences:set
'framework:standard-style-list:smoothing
(case (send x get-selection)
[(0) 'unsmoothed]
[(1) 'partly-smoothed]
[(2) 'smoothed]
[(3) 'default])))))]
[text (make-object (text:foreground-color-mixin
(editor:standard-style-list-mixin
text:basic%)))]
[ex-panel (make-object horizontal-panel% main)]
[msg (make-object message% (string-constant example-text) ex-panel)]
[canvas (make-object canvas:color% main text)]
[update-text
(λ (setting)
(send text begin-edit-sequence)
(send text lock #f)
(send text erase)
(send text insert
(format
";; howmany : list-of-numbers -> number~
\n;; to determine how many numbers are in `a-lon'~
\n(define (howmany a-lon)~
\n (cond~
\n [(empty? a-lon) 0]~
\n [else (+ 1 (howmany (rest a-lon)))]))~
\n~
\n;; examples as tests~
\n(howmany empty)~
\n\"should be\"~
\n0~
\n~
\n(howmany (cons 1 (cons 2 (cons 3 empty))))~
\n\"should be\"~
\n3"))
(send text set-position 0 0)
(send text lock #t)
(send text end-edit-sequence))])
(preferences:add-callback
'framework:standard-style-list:font-size
(λ (p v) (send size-slider set-value v)))
(preferences:add-callback
drscheme:language-configuration:settings-preferences-symbol
(λ (p v)
(update-text v)))
(update-text (preferences:get drscheme:language-configuration:settings-preferences-symbol))
(send ex-panel set-alignment 'left 'center)
(send ex-panel stretchable-height #f)
(send canvas allow-tab-exit #t)
(send options-panel stretchable-height #f)
(send options-panel set-alignment 'center 'top)
(send text lock #t)
main))))))

595
collects/drscheme/private/frame.ss
View File

@ -1,595 +0,0 @@
#lang scheme/unit
(require string-constants
mzlib/match
mzlib/class
mzlib/string
mzlib/list
"drsig.ss"
mred
framework
net/url
net/head
(lib "plt-installer.ss" "setup")
(lib "bug-report.ss" "help")
scheme/file)
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:app: drscheme:app^]
[prefix help: drscheme:help-desk^]
[prefix drscheme:multi-file-search: drscheme:multi-file-search^]
[prefix drscheme:init: drscheme:init^])
(export (rename drscheme:frame^
[-mixin mixin]))
(define basics<%> (interface (frame:standard-menus<%>)))
(define last-keybindings-planet-attempt "")
(define basics-mixin
(mixin (frame:standard-menus<%>) (basics<%>)
(inherit get-edit-target-window get-edit-target-object get-menu-bar)
(define/private (get-menu-bindings)
(let ([name-ht (make-hasheq)])
(let loop ([menu-container (get-menu-bar)])
(for-each
(λ (item)
(when (is-a? item selectable-menu-item<%>)
(let ([short-cut (send item get-shortcut)])
(when short-cut
(let ([keyname
(string->symbol
(keymap:canonicalize-keybinding-string
(string-append
(menu-item->prefix-string item)
(case short-cut
[(#\;) "semicolon"]
[(#\:) "colon"]
[(#\space) "space"]
[else (string short-cut)]))))])
(hash-set! name-ht keyname (send item get-plain-label))))))
(when (is-a? item menu-item-container<%>)
(loop item)))
(send menu-container get-items)))
(when (eq? (system-type) 'windows)
(for-each (λ (top-level-menu)
(when (is-a? top-level-menu menu%)
(let ([amp-key
(let loop ([str (send top-level-menu get-label)])
(cond
[(regexp-match #rx"[^&]*[&](.)(.*)" str)
=>
(λ (m)
(let ([this-amp (list-ref m 1)]
[rest (list-ref m 2)])
(cond
[(equal? this-amp "&")
(loop rest)]
[else
(string-downcase this-amp)])))]
[else #f]))])
(when amp-key
(hash-set! name-ht
(format "m:~a" amp-key)
(format "~a menu" (send top-level-menu get-plain-label)))
(hash-set! name-ht
(format "m:s:~a" amp-key)
(format "~a menu" (send top-level-menu get-plain-label)))))))
(send (get-menu-bar) get-items)))
name-ht))
(define/private (menu-item->prefix-string item)
(apply
string-append
(map (λ (prefix)
(case prefix
[(alt) (if (eq? (system-type) 'windows)
"m:"
"a:")]
[(cmd) "d:"]
[(meta) "m:"]
[(ctl) "c:"]
[(shift) "s:"]
[(opt) "a:"]))
(send item get-shortcut-prefix))))
[define/private copy-hash-table
(λ (ht)
(let ([res (make-hasheq)])
(hash-for-each
ht
(λ (x y) (hash-set! res x y)))
res))]
[define/private can-show-keybindings?
(λ ()
(let ([edit-object (get-edit-target-object)])
(and edit-object
(is-a? edit-object editor<%>)
(let ([keymap (send edit-object get-keymap)])
(is-a? keymap keymap:aug-keymap<%>)))))]
[define/private (show-keybindings)
(if (can-show-keybindings?)
(let* ([edit-object (get-edit-target-object)]
[keymap (send edit-object get-keymap)]
[menu-names (get-menu-bindings)]
[table (send keymap get-map-function-table)]
[bindings (hash-map table list)]
[w/menus
(append (hash-map menu-names list)
(filter (λ (binding) (not (bound-by-menu? binding menu-names)))
bindings))]
[structured-list
(sort
w/menus
(λ (x y) (string-ci<=? (cadr x) (cadr y))))])
(show-keybindings-to-user structured-list this))
(bell))]
(define/private (bound-by-menu? binding menu-table)
(ormap (λ (constituent)
(hash-ref menu-table (string->symbol constituent) (λ () #f)))
(regexp-split #rx";" (symbol->string (car binding)))))
(define/override (help-menu:before-about help-menu)
(make-help-desk-menu-item help-menu))
(define/override (help-menu:about-callback item evt) (drscheme:app:about-drscheme))
(define/override (help-menu:about-string) (string-constant about-drscheme))
(define/override (help-menu:create-about?) #t)
(define/public (get-additional-important-urls) '())
(define/override (help-menu:after-about menu)
(drscheme:app:add-important-urls-to-help-menu
menu
(get-additional-important-urls))
(new menu-item%
(label (string-constant bug-report-submit-menu-item))
(parent menu)
(callback
(λ (x y)
(help-desk:report-bug))))
(drscheme:app:add-language-items-to-help-menu menu))
(define/override (file-menu:new-string) (string-constant new-menu-item))
(define/override (file-menu:open-string) (string-constant open-menu-item))
(define/override (file-menu:between-open-and-revert file-menu)
(make-object menu-item%
(string-constant install-plt-file-menu-item...)
file-menu
(λ (item evt)
(install-plt-file this)))
(super file-menu:between-open-and-revert file-menu))
(define/override (file-menu:between-print-and-close menu)
(super file-menu:between-print-and-close menu)
(instantiate menu-item% ()
(label (string-constant mfs-multi-file-search-menu-item))
(parent menu)
(callback
(λ (_1 _2)
(drscheme:multi-file-search:multi-file-search))))
(new separator-menu-item% (parent menu)))
(define/override (edit-menu:between-find-and-preferences menu)
(make-object separator-menu-item% menu)
(let ([keybindings-on-demand
(λ (menu-item)
(let ([last-edit-object (get-edit-target-window)])
(send menu-item enable (can-show-keybindings?))))])
(instantiate menu% ()
(label (string-constant keybindings-menu-item))
(parent menu)
(demand-callback
(λ (keybindings-menu)
(for-each (λ (old) (send old delete))
(send keybindings-menu get-items))
(new menu-item%
(parent keybindings-menu)
(label (string-constant keybindings-show-active))
(callback (λ (x y) (show-keybindings)))
(help-string (string-constant keybindings-info))
(demand-callback keybindings-on-demand))
(new menu-item%
(parent keybindings-menu)
(label (string-constant keybindings-add-user-defined-keybindings))
(callback
(λ (x y)
(with-handlers ([exn? (λ (x)
(printf "~a\n" (exn-message x)))])
(let ([filename (finder:get-file
#f
(string-constant keybindings-choose-user-defined-file)
#f
""
this)])
(when filename
(add-keybindings-item/update-prefs filename)))))))
(new menu-item%
(parent keybindings-menu)
(label (string-constant keybindings-add-user-defined-keybindings/planet))
(callback
(λ (x y)
(let ([planet-spec (get-text-from-user (string-constant drscheme)
(string-constant keybindings-type-planet-spec)
this
last-keybindings-planet-attempt)])
(when planet-spec
(set! last-keybindings-planet-attempt planet-spec)
(cond
[(planet-string-spec? planet-spec)
=>
(λ (planet-sexp-spec)
(add-keybindings-item/update-prefs planet-sexp-spec))]
[else
(message-box (string-constant drscheme)
(format (string-constant keybindings-planet-malformed-spec)
planet-spec))]))))))
(let ([ud (preferences:get 'drscheme:user-defined-keybindings)])
(unless (null? ud)
(new separator-menu-item% (parent keybindings-menu))
(for-each (λ (item)
(new menu-item%
(label (format (string-constant keybindings-menu-remove)
(if (path? item)
(path->string item)
(format "~s" item))))
(parent keybindings-menu)
(callback
(λ (x y) (remove-keybindings-item item)))))
ud)))))))
(unless (current-eventspace-has-standard-menus?)
(make-object separator-menu-item% menu)))
(super-new)))
(define (add-keybindings-item/update-prefs item)
(when (add-keybindings-item item)
(preferences:set 'drscheme:user-defined-keybindings
(cons item
(preferences:get 'drscheme:user-defined-keybindings)))))
(define (planet-string-spec? p)
(let ([sexp
(with-handlers ([exn:fail:read? (λ (x) #f)])
(read (open-input-string p)))])
(and sexp
(planet-spec? sexp)
sexp)))
(define (planet-spec? p)
(match p
[`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?))) #t]
[`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?) ,(? number?))) #t]
[else #f]))
;; add-keybindings-item : keybindings-item[path or planet spec] -> boolean
;; boolean indicates if the addition happened sucessfully
(define (add-keybindings-item item)
(with-handlers ([exn? (λ (x)
(message-box (string-constant drscheme)
(format (string-constant keybindings-error-installing-file)
(if (path? item)
(path->string item)
(format "~s" item))
(exn-message x)))
#f)])
(keymap:add-user-keybindings-file item)
#t))
(define (remove-keybindings-item item)
(keymap:remove-user-keybindings-file item)
(preferences:set
'drscheme:user-defined-keybindings
(remove item
(preferences:get 'drscheme:user-defined-keybindings))))
;; install-plt-file : (union #f dialog% frame%) -> void
;; asks the user for a .plt file, either from the web or from
;; a file on the disk and installs it.
(define (install-plt-file parent)
(define dialog
(instantiate dialog% ()
(parent parent)
(alignment '(left center))
(label (string-constant install-plt-file-dialog-title))))
(define tab-panel
(instantiate tab-panel% ()
(parent dialog)
(callback (λ (x y) (update-panels)))
(choices (list (string-constant install-plt-web-tab)
(string-constant install-plt-file-tab)))))
(define outer-swapping-panel (instantiate horizontal-panel% ()
(parent tab-panel)
(stretchable-height #f)))
(define spacing-panel (instantiate horizontal-panel% ()
(stretchable-width #f)
(parent outer-swapping-panel)
(min-width 20)))
(define swapping-panel (instantiate panel:single% ()
(parent outer-swapping-panel)
(alignment '(left center))
(stretchable-width #t)
(stretchable-height #f)))
(define file-panel (instantiate horizontal-panel% ()
(parent swapping-panel)
(stretchable-width #t)
(stretchable-height #f)))
(define url-panel (instantiate horizontal-panel% ()
(parent swapping-panel)
(stretchable-height #f)))
(define button-panel (instantiate horizontal-panel% ()
(parent dialog)
(stretchable-height #f)
(alignment '(right center))))
(define file-text-field (instantiate text-field% ()
(parent file-panel)
(callback void)
(min-width 300)
(stretchable-width #t)
(label (string-constant install-plt-filename))))
(define file-button (instantiate button% ()
(parent file-panel)
(label (string-constant browse...))
(callback (λ (x y) (browse)))))
(define url-text-field (instantiate text-field% ()
(parent url-panel)
(label (string-constant install-plt-url))
(min-width 300)
(stretchable-width #t)
(callback void)))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons
button-panel
(λ (x y)
(set! cancel? #f)
(send dialog show #f))
(λ (x y)
(send dialog show #f))))
;; browse : -> void
;; gets the name of a file from the user and
;; updates file-text-field
(define (browse)
(let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename
(send file-text-field set-value (path->string filename)))))
;; from-web? : -> boolean
;; returns #t if the user has selected a web address
(define (from-web?)
(zero? (send tab-panel get-selection)))
(define cancel? #t)
(define (update-panels)
(send swapping-panel active-child
(if (from-web?)
url-panel
file-panel)))
(update-panels)
(send dialog show #t)
(cond
[cancel? (void)]
[(from-web?)
(install-plt-from-url (send url-text-field get-value) parent)]
[else
(parameterize ([error-display-handler drscheme:init:original-error-display-handler])
(run-installer (string->path (send file-text-field get-value))))]))
;; install-plt-from-url : string (union #f dialog%) -> void
;; downloads and installs a .plt file from the given url
(define (install-plt-from-url s-url parent)
(with-handlers ([(λ (x) #f)
(λ (exn)
(message-box (string-constant drscheme)
(if (exn? exn)
(format "~a" (exn-message exn))
(format "~s" exn))))])
(let* ([url (string->url s-url)]
[tmp-filename (make-temporary-file "tmp~a.plt")]
[port (get-impure-port url)]
[header (purify-port port)]
[size (let* ([content-header (extract-field "content-length" header)]
[m (and content-header
(regexp-match "[0-9]+" content-header))])
(and m (string->number (car m))))]
[d (make-object dialog% (string-constant downloading) parent)]
[message (make-object message% (string-constant downloading-file...) d)]
[gauge (if size
(make-object gauge% #f 100 d)
#f)]
[exn #f]
; Semaphores to avoid race conditions:
[wait-to-start (make-semaphore 0)]
[wait-to-break (make-semaphore 0)]
; Thread to perform the download:
[t (thread
(λ ()
(semaphore-wait wait-to-start)
(with-handlers ([exn:fail?
(λ (x)
(set! exn x))]
[exn:break? ; throw away break exceptions
void])
(semaphore-post wait-to-break)
(with-output-to-file tmp-filename
(λ ()
(let loop ([total 0])
(when gauge
(send gauge set-value
(inexact->exact
(floor (* 100 (/ total size))))))
(let ([s (read-string 1024 port)])
(unless (eof-object? s)
(unless (eof-object? s)
(display s)
(loop (+ total (string-length s))))))))
#:mode 'binary #:exists 'truncate))
(send d show #f)))])
(send d center)
(make-object button% (string-constant &stop)
d
(λ (b e)
(semaphore-wait wait-to-break)
(set! tmp-filename #f)
(send d show #f)
(break-thread t)))
; Let thread run only after the dialog is shown
(queue-callback (λ () (semaphore-post wait-to-start)))
(send d show #t)
(when exn (raise exn))
(parameterize ([error-display-handler drscheme:init:original-error-display-handler])
(run-installer tmp-filename
(λ ()
(delete-file tmp-filename)))))))
(define keybindings-dialog%
(class dialog%
(override on-size)
[define on-size
(lambda (w h)
(preferences:set 'drscheme:keybindings-window-size (cons w h))
(super on-size w h))]
(super-instantiate ())))
(define (show-keybindings-to-user bindings frame)
(letrec ([f (instantiate keybindings-dialog% ()
(label (string-constant keybindings-frame-title))
(parent frame)
(width (car (preferences:get 'drscheme:keybindings-window-size)))
(height (cdr (preferences:get 'drscheme:keybindings-window-size)))
(style '(resize-border)))]
[bp (make-object horizontal-panel% f)]
[search-field (new text-field%
[parent f]
[label (string-constant mfs-search-string)]
[callback (λ (a b) (update-bindings))])]
[b-name (make-object button% (string-constant keybindings-sort-by-name)
bp (λ x
(set! by-key? #f)
(update-bindings)))]
[b-key (make-object button% (string-constant keybindings-sort-by-key)
bp (λ x
(set! by-key? #t)
(update-bindings)))]
[lb
(make-object list-box% #f null f void)]
[bp2 (make-object horizontal-panel% f)]
[cancel (make-object button% (string-constant close)
bp2 (λ x (send f show #f)))]
[space (make-object grow-box-spacer-pane% bp2)]
[filter-search
(λ (bindings)
(let ([str (send search-field get-value)])
(if (equal? str "")
bindings
(let ([reg (regexp (regexp-quote str #f))])
(filter (λ (x) (or (regexp-match reg (cadr x))
(regexp-match reg (format "~a" (car x)))))
bindings)))))]
[by-key? #f]
[update-bindings
(λ ()
(let ([format-binding/name
(λ (b) (format "~a (~a)" (cadr b) (car b)))]
[format-binding/key
(λ (b) (format "~a (~a)" (car b) (cadr b)))]
[predicate/key
(λ (a b) (string-ci<=? (format "~a" (car a))
(format "~a" (car b))))]
[predicate/name
(λ (a b) (string-ci<=? (cadr a) (cadr b)))])
(send lb set
(if by-key?
(map format-binding/key (sort (filter-search bindings) predicate/key))
(map format-binding/name (sort (filter-search bindings) predicate/name))))))])
(send search-field focus)
(send bp stretchable-height #f)
(send bp set-alignment 'center 'center)
(send bp2 stretchable-height #f)
(send bp2 set-alignment 'right 'center)
(update-bindings)
(send f show #t)))
(define <%>
(interface (frame:editor<%> basics<%> frame:text-info<%>)
get-show-menu
update-shown
add-show-menu-items))
(define -mixin
(mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>)
(inherit get-editor get-menu% get-menu-bar)
(define show-menu #f)
(define/public get-show-menu (λ () show-menu))
(define/public update-shown (λ () (void)))
(define/public (add-show-menu-items show-menu) (void))
(super-new)
(set! show-menu (make-object (get-menu%) (string-constant view-menu-label)
(get-menu-bar)))
(add-show-menu-items show-menu)))
(define (create-root-menubar)
(let* ([mb (new menu-bar% (parent 'root))]
[file-menu (new menu%
(label (string-constant file-menu))
(parent mb))]
[help-menu (new menu%
(label (string-constant help-menu))
(parent mb))])
(new menu-item%
(label (string-constant new-menu-item))
(parent file-menu)
(shortcut #\n)
(callback
(λ (x y)
(handler:edit-file #f)
#t)))
(new menu-item%
(label (string-constant open-menu-item))
(parent file-menu)
(shortcut #\o)
(callback
(λ (x y)
(handler:open-file)
#t)))
(new menu%
(label (string-constant open-recent-menu-item))
(parent file-menu)
(demand-callback
(λ (menu)
(handler:install-recent-items menu))))
(instantiate menu-item% ()
(label (string-constant mfs-multi-file-search-menu-item))
(parent file-menu)
(callback
(λ (_1 _2)
(drscheme:multi-file-search:multi-file-search))))
(unless (current-eventspace-has-standard-menus?)
(new separator-menu-item% (parent file-menu))
(new menu-item%
(label (string-constant quit-menu-item-others))
(parent file-menu)
(shortcut #\q)
(callback
(λ (x y)
(when (exit:user-oks-exit)
(exit:exit))
#t))))
(make-help-desk-menu-item help-menu)))
(define (make-help-desk-menu-item help-menu)
(make-object menu-item%
(string-constant help-desk)
help-menu
(λ (item evt)
(help:help-desk)
#t)))

84
collects/drscheme/private/get-extend.ss
View File

@ -1,84 +0,0 @@
#lang scheme/unit
(require scheme/class
"drsig.ss")
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:debug: drscheme:debug^])
(export drscheme:get/extend^)
(define make-extender
(λ (get-base% name)
(let ([extensions (λ (x) x)]
[built-yet? #f]
[built #f]
[verify
(λ (f)
(λ (%)
(let ([new% (f %)])
(if (and (class? new%)
(subclass? new% %))
new%
(error 'extend-% "expected output of extension to create a subclass of its input, got: ~a"
new%)))))])
(values
(letrec ([add-extender
(case-lambda
[(extension) (add-extender extension #t)]
[(extension before?)
(when built-yet?
(error 'extender "cannot build a new extension of ~a after initialization"
name))
(set! extensions
(if before?
(compose (verify extension) extensions)
(compose extensions (verify extension))))])])
add-extender)
(λ ()
(unless built-yet?
(set! built-yet? #t)
(set! built (extensions (get-base%))))
built)))))
(define (get-base-tab%)
(drscheme:debug:test-coverage-tab-mixin
(drscheme:debug:profile-tab-mixin
drscheme:unit:tab%)))
(define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%))
(define (get-base-interactions-canvas%)
drscheme:unit:interactions-canvas%)
(define-values (extend-interactions-canvas get-interactions-canvas)
(make-extender get-base-interactions-canvas% 'interactions-canvas%))
(define (get-base-definitions-canvas%)
drscheme:unit:definitions-canvas%)
(define-values (extend-definitions-canvas get-definitions-canvas)
(make-extender get-base-definitions-canvas% 'definitions-canvas%))
(define (get-base-unit-frame%)
(drscheme:debug:profile-unit-frame-mixin
drscheme:unit:frame%))
(define-values (extend-unit-frame get-unit-frame)
(make-extender get-base-unit-frame% 'drscheme:unit:frame))
(define (get-base-interactions-text%)
(drscheme:debug:test-coverage-interactions-text-mixin
drscheme:rep:text%))
(define-values (extend-interactions-text get-interactions-text)
(make-extender get-base-interactions-text% 'interactions-text%))
(define (get-base-definitions-text%)
(drscheme:debug:test-coverage-definitions-text-mixin
(drscheme:debug:profile-definitions-text-mixin
(drscheme:unit:get-definitions-text%))))
(define-values (extend-definitions-text get-definitions-text)
(make-extender get-base-definitions-text% 'definitions-text%))

77
collects/drscheme/private/help-desk.ss
View File

@ -1,77 +0,0 @@
#lang scheme/unit
(require scheme/gui/base
browser/external
framework
scheme/class
net/url
setup/dirs
help/search
help/private/buginfo
"drsig.ss")
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
(export drscheme:help-desk^)
(define (-add-help-desk-font-prefs b) '(add-help-desk-font-prefs b))
;; : -> string
(define (get-computer-language-info)
(let* ([language/settings (preferences:get
drscheme:language-configuration:settings-preferences-symbol)]
[language (drscheme:language-configuration:language-settings-language
language/settings)]
[settings (drscheme:language-configuration:language-settings-settings
language/settings)])
(format
"~s"
(list
(send language get-language-position)
(send language marshall-settings settings)))))
(set-bug-report-info! "Computer Language" get-computer-language-info)
(define lang-message%
(class canvas%
(init-field button-release font)
(define/override (on-event evt)
(when (send evt button-up?)
(button-release)))
(field [msg ""])
(define/public (set-msg l) (set! msg l) (on-paint))
(inherit get-dc get-client-size)
(define/override (on-paint)
(let ([dc (get-dc)]
[dots "..."])
(let-values ([(tw th _1 _2) (send dc get-text-extent msg)]
[(dw dh _3 _4) (send dc get-text-extent dots)]
[(cw ch) (get-client-size)])
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc set-font font)
(send dc draw-rectangle 0 0 cw ch)
(cond
[(tw . <= . cw)
(send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))]
[(cw . <= . dw) ;; just give up if there's not enough room to draw the dots
(void)]
[else
(send dc set-clipping-rect 0 0 (- cw dw 2) ch)
(send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))
(send dc set-clipping-region #f)
(send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))]))))
(super-new)))
(define (goto-plt-license)
(send-main-page "license/index.html"))
(define (help-desk [key #f] #:module [mod #f] #:manual [man #f])
(if (or key mod man)
(perform-search (string-append (or key "")
(if mod (format " L:~a" mod) "")
(if man (format " T:~a" man) "")))
(send-main-page)))
;; here for legacy code that should be removed
(define (get-docs) '())

51
collects/drscheme/private/init.ss
View File

@ -1,51 +0,0 @@
#lang scheme/unit
(require string-constants
"drsig.ss"
mzlib/list
mred)
(import)
(export drscheme:init^)
(define original-output-port (current-output-port))
(define original-error-port (current-error-port))
(define primitive-eval (current-eval))
(define primitive-load (current-load))
(define system-custodian (current-custodian))
(define system-eventspace (current-eventspace))
(define system-thread (current-thread))
(define system-namespace (current-namespace))
(define first-dir (current-directory))
(define error-display-eventspace (make-eventspace))
(define original-error-display-handler (error-display-handler))
(define error-display-handler-message-box-title
(make-parameter (string-constant drscheme-internal-error)))
;; override error-display-handler to duplicate the error
;; message in both the standard place (as defined by the
;; current error-display-handler) and in a message box
;; identifying the error as a drscheme internal error.
(error-display-handler
(λ (msg exn)
;; this may raise an exception if the port is gone.
(with-handlers ([exn:fail? (λ (x) (void))])
(original-error-display-handler msg exn))
(let ([title (error-display-handler-message-box-title)])
(let ([text (let ([p (open-output-string)])
(parameterize ([current-error-port p]
[current-output-port p])
(original-error-display-handler msg exn))
(get-output-string p))])
(parameterize ([current-custodian system-custodian])
(parameterize ([current-eventspace error-display-eventspace])
(message-box title text #f '(stop ok))))))))

172
collects/drscheme/private/insert-large-letters.ss
View File

@ -1,172 +0,0 @@
#lang scheme/base
(require mred scheme/class string-constants framework)
(provide insert-large-letters)
(define (insert-large-letters comment-prefix comment-character edit parent)
(let ([str (make-large-letters-dialog comment-prefix comment-character #f)])
(when (and str
(not (equal? str "")))
(render-large-letters comment-prefix comment-character (get-chosen-font) str edit)
(void))))
(preferences:set-default 'drscheme:large-letters-font #f (λ (x) (or (and (pair? x)
(string? (car x))
(number? (cdr x))
(integer? (cdr x))
(<= 1 (cdr x) 255))
(not x))))
(define (get-default-font)
(send (send (editor:get-standard-style-list)
find-named-style
"Standard")
get-font))
(define (get-chosen-font)
(let ([pref-val (preferences:get 'drscheme:large-letters-font)])
(cond
[pref-val
(let ([candidate (send the-font-list find-or-create-font (cdr pref-val) (car pref-val) 'default 'normal 'normal)])
(if (equal? (send candidate get-face) (car pref-val))
candidate
(get-default-font)))]
[else
(get-default-font)])))
(define columns-string "~a columns")
;; make-large-letters-dialog : string char top-level-window<%> -> void
(define (make-large-letters-dialog comment-prefix comment-character parent)
(define dlg (new dialog%
[parent parent]
[width 700]
[label (string-constant large-semicolon-letters)]))
(define text-field (new text-field%
[parent dlg]
[label (string-constant text-to-insert)]
[callback (λ (x y) (update-txt (send text-field get-value)))]))
(define info-bar (new horizontal-panel%
[parent dlg]
[stretchable-height #f]))
(define font-choice (new choice%
[label (string-constant fonts)]
[parent info-bar]
[choices (get-face-list)]
[callback
(λ (x y)
(let ([old (preferences:get 'drscheme:large-letters-font)])
(preferences:set 'drscheme:large-letters-font
(cons (send font-choice get-string-selection)
(if old
(cdr old)
(send (get-default-font) get-point-size))))
(update-txt (send text-field get-value))))]))
(define count (new message% [label (format columns-string 1000)] [parent info-bar]))
(define pane1 (new horizontal-pane% (parent info-bar)))
(define dark-msg (new bitmap-message% [parent info-bar]))
(define pane2 (new horizontal-pane% (parent info-bar)))
(define txt (new scheme:text%))
(define ec (new editor-canvas% [parent dlg] [editor txt]))
(define button-panel (new horizontal-panel%
[parent dlg]
[stretchable-height #f]
[alignment '(right center)]))
(define ok? #f)
(define-values (ok cancel)
(gui-utils:ok/cancel-buttons button-panel
(λ (x y) (set! ok? #t) (send dlg show #f))
(λ (x y) (send dlg show #f))))
(define (update-txt str)
(send txt begin-edit-sequence)
(send txt lock #f)
(send txt delete 0 (send txt last-position))
(let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt)])
(send ec set-line-count (+ 1 (send txt last-paragraph)))
(send txt lock #t)
(send txt end-edit-sequence)
(send count set-label (format columns-string (get-max-line-width txt)))
(send dark-msg set-bm bm)))
(send font-choice set-string-selection (send (get-chosen-font) get-face))
(send txt auto-wrap #f)
(update-txt " ")
(send text-field focus)
(send dlg show #t)
(and ok? (send text-field get-value)))
(define (get-max-line-width txt)
(let loop ([i (+ (send txt last-paragraph) 1)]
[m 0])
(cond
[(zero? i) m]
[else (loop (- i 1)
(max m (- (send txt paragraph-end-position (- i 1))
(send txt paragraph-start-position (- i 1)))))])))
(define bitmap-message%
(class canvas%
(inherit min-width min-height get-dc)
(define bm #f)
(define/override (on-paint)
(when bm
(let ([dc (get-dc)])
(send dc draw-bitmap bm 0 0))))
(define/public (set-bm b)
(set! bm b)
(min-width (send bm get-width))
(min-height (send bm get-height)))
(super-new (stretchable-width #f)
(stretchable-height #f))))
(define (render-large-letters comment-prefix comment-character the-font str edit)
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
(define-values (tw raw-th td ta) (send bdc get-text-extent str the-font))
(define th (let-values ([(_1 h _2 _3) (send bdc get-text-extent "X" the-font)])
(max raw-th h)))
(define tmp-color (make-object color%))
(define (get-char x y)
(send bdc get-pixel x y tmp-color)
(let ([red (send tmp-color red)])
(if (= red 0)
comment-character
#\space)))
(define bitmap
(make-object bitmap%
(max 1 (inexact->exact tw))
(inexact->exact th)
#t))
(define (fetch-line y)
(let loop ([x (send bitmap get-width)]
[chars null])
(cond
[(zero? x) (apply string chars)]
[else (loop (- x 1) (cons (get-char (- x 1) y) chars))])))
(send bdc set-bitmap bitmap)
(send bdc clear)
(send bdc set-font the-font)
(send bdc draw-text str 0 0)
(send edit begin-edit-sequence)
(let ([start (send edit get-start-position)]
[end (send edit get-end-position)])
(send edit delete start end)
(send edit insert "\n" start start)
(let loop ([y (send bitmap get-height)])
(unless (zero? y)
(send edit insert (fetch-line (- y 1)) start start)
(send edit insert comment-prefix start start)
(send edit insert "\n" start start)
(loop (- y 1)))))
(send edit end-edit-sequence)
(send bdc set-bitmap #f)
bitmap)
;(make-large-letters-dialog ";" #\; #f)

19
collects/drscheme/private/key.ss
View File

@ -1,19 +0,0 @@
(module key mzscheme
(provide break-threads)
(define super-cust (current-custodian))
(define first-child (make-custodian))
(current-custodian first-child)
(define (break-threads)
(parameterize ([current-custodian super-cust])
(thread
(λ ()
(let loop ([super-cust super-cust]
[current-cust first-child])
(for-each (λ (man)
(when (thread? man)
(break-thread man))
(when (custodian? man)
(loop current-cust man)))
(custodian-managed-list current-cust super-cust))))))))

28
collects/drscheme/private/label-frame-mred.ss
View File

@ -1,28 +0,0 @@
(module label-frame-mred mzscheme
(require mred
mzlib/class)
(provide (all-from-except mred frame%)
(rename registering-frame% frame%)
lookup-frame-name)
(define (lookup-frame-name frame)
(semaphore-wait label-sema)
(begin0
(hash-table-get label-ht frame (λ () #f))
(semaphore-post label-sema)))
(define label-sema (make-semaphore 1))
(define label-ht (make-hash-table 'weak))
(define registering-frame%
(class frame%
(define/override (set-label x)
(semaphore-wait label-sema)
(hash-table-put! label-ht this x)
(semaphore-post label-sema)
(super set-label x))
(inherit get-label)
(super-instantiate ())
(semaphore-wait label-sema)
(hash-table-put! label-ht this (get-label))
(semaphore-post label-sema))))

1784
collects/drscheme/private/language-configuration.ss
View File

File diff suppressed because it is too large Load Diff

94
collects/drscheme/private/language-object-contract.ss
View File

@ -1,94 +0,0 @@
#reader scribble/reader
#lang scheme/base
(require (for-syntax scheme/base)
scribble/srcdoc
scheme/class
scheme/gui/base
scheme/contract
"recon.ss")
(require/doc scheme/base scribble/manual)
(require (for-meta 2 scheme/base))
(provide language-object-abstraction)
(define-syntax (language-object-abstraction stx)
(syntax-case stx ()
[(_ id provide?)
(let-syntax ([save-srcloc
(λ (s)
(define-struct sloc (inside loc) #:prefab)
(syntax-case s ()
[(_ arg)
(with-syntax ([ans
(let loop ([s #'arg])
(cond
[(syntax? s)
(let ([loc (vector (syntax-source s)
(syntax-line s)
(syntax-column s)
(syntax-position s)
(syntax-span s))])
(make-sloc (loop (syntax-e s)) loc))]
[(pair? s) (cons (loop (car s)) (loop (cdr s)))]
[else s]))])
#'ans)]))])
(let* ([ctc
(save-srcloc
(object-contract
(config-panel (-> (is-a?/c area-container<%>)
(case-> (-> any/c void?)
(-> any/c))))
(create-executable (-> any/c
(or/c (is-a?/c dialog%) (is-a?/c frame%))
path?
void?))
(default-settings (-> any/c))
(default-settings? (-> any/c boolean?))
(front-end/complete-program (-> input-port?
any/c
(-> any/c)))
(front-end/interaction (-> input-port?
any/c
(-> any/c)))
(get-language-name (-> string?))
(get-language-numbers (-> (cons/c number? (listof number?))))
(get-language-position (-> (cons/c string? (listof string?))))
(get-language-url (-> (or/c false/c string?)))
(get-one-line-summary (-> string?))
(get-comment-character (-> (values string? char?)))
(get-style-delta
(-> (or/c false/c
(is-a?/c style-delta%)
(listof
(list/c (is-a?/c style-delta%)
number?
number?)))))
(marshall-settings (-> any/c printable/c))
(on-execute (-> any/c (-> (-> any) any) any))
(render-value (-> any/c
any/c
output-port?
void?))
(render-value/format (-> any/c
any/c
output-port?
(or/c number? (symbols 'infinity))
any))
(unmarshall-settings (-> printable/c any))
(capability-value
(->d ([s (and/c symbol?
drscheme:language:capability-registered?)])
()
[res (drscheme:language:get-capability-contract s)]))))])
#`(begin
(define id (reconstitute #,ctc provide?))
#,@(if (syntax-e #'provide?)
(list
#`(require/doc drscheme/private/recon)
#`(provide/doc
(thing-doc id
contract?
((reconstitute (schemeblock #,ctc) provide?)))))
'()))))]))

1171
collects/drscheme/private/language.ss
View File

File diff suppressed because it is too large Load Diff

50
collects/drscheme/private/launcher-bootstrap.ss
View File

@ -1,50 +0,0 @@
#lang scheme/base
(provide startup)
(require scheme/file)
(define (read-from-string s) (read (open-input-string s)))
(define (startup)
(define argv (current-command-line-arguments))
;; skip first six
(define program-argv (list->vector (cddr (cddddr (vector->list argv)))))
(define init-code (read-from-string (vector-ref argv 0)))
(define program-filename (vector-ref argv 1))
(define language-module-spec (read-from-string (vector-ref argv 2)))
(define transformer-module-spec (read-from-string (vector-ref argv 3)))
(define use-require/copy? (read-from-string (vector-ref argv 4)))
(define init-code-tmp-filename (make-temporary-file "drs-launcher-init~a"))
(define-values (_1 init-code-mod-name _2) (split-path init-code-tmp-filename))
(define stupid-internal-define-syntax2
(set! init-code (cons (car init-code)
(cons (string->symbol (path->string init-code-mod-name))
(cddr init-code)))))
(define stupid-internal-define-syntax1
(call-with-output-file init-code-tmp-filename
(λ (port)
(write init-code port))
#:exists 'truncate #:mode 'text))
(define init-code-proc (dynamic-require init-code-tmp-filename 'init-code))
(namespace-set-variable-value! 'argv program-argv)
(current-command-line-arguments program-argv)
(when language-module-spec
(namespace-require language-module-spec))
(when use-require/copy?
(namespace-require/copy language-module-spec))
(when transformer-module-spec
(namespace-require `(for-syntax ,transformer-module-spec)))
(init-code-proc)
;; safe to do this earlier?
(delete-file init-code-tmp-filename)
(load program-filename))

9
collects/drscheme/private/launcher-mred-bootstrap.ss
View File

@ -1,9 +0,0 @@
#lang scheme/base
(require scheme/gui/base "launcher-bootstrap.ss")
(current-namespace (make-gui-empty-namespace))
(namespace-require 'scheme/gui/base)
(namespace-require 'scheme/class)
(startup)

8
collects/drscheme/private/launcher-mz-bootstrap.ss
View File

@ -1,8 +0,0 @@
#lang scheme/base
(require "launcher-bootstrap.ss")
(current-namespace (make-base-empty-namespace))
(namespace-require 'scheme/base)
(startup)

55
collects/drscheme/private/link.ss
View File

@ -1,55 +0,0 @@
(module link mzscheme
(require "modes.ss"
"font.ss"
"eval.ss"
"module-browser.ss"
"multi-file-search.ss"
"debug.ss"
"module-language.ss"
"tools.ss"
mzlib/unit
"language.ss"
"language-configuration.ss"
"drsig.ss"
"init.ss"
"text.ss"
"app.ss"
"main.ss"
"rep.ss"
"frame.ss"
"unit.ss"
"get-extend.ss"
"help-desk.ss")
(provide drscheme@)
(define-compound-unit/infer drscheme-unit@
(import)
(export drscheme:debug^
drscheme:unit^
drscheme:rep^
drscheme:frame^
drscheme:get/extend^
drscheme:language-configuration^
drscheme:language^
drscheme:help-desk^
drscheme:eval^
drscheme:modes^)
(link init@ tools@ modes@ text@ eval@ frame@ rep@ language@
module-overview@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language@ help-desk@ app@ main@))
(define-unit/new-import-export drscheme@
(import) (export drscheme:tool^)
(((prefix drscheme:debug: drscheme:debug^)
(prefix drscheme:unit: drscheme:unit^)
(prefix drscheme:rep: drscheme:rep^)
(prefix drscheme:frame: drscheme:frame^)
(prefix drscheme:get/extend: drscheme:get/extend^)
(prefix drscheme:language-configuration: drscheme:language-configuration^)
(prefix drscheme:language: drscheme:language^)
(prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:eval: drscheme:eval^)
(prefix drscheme:modes: drscheme:modes^))
drscheme-unit@)))

508
collects/drscheme/private/main.ss
View File

@ -1,508 +0,0 @@
#lang scheme/unit
(require string-constants
mzlib/contract
"drsig.ss"
mred
framework
mzlib/class
mzlib/list
scheme/path
(lib "external.ss" "browser")
(lib "plt-installer.ss" "setup"))
(import [prefix drscheme:app: drscheme:app^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:font: drscheme:font^]
[prefix drscheme:modes: drscheme:modes^]
[prefix drscheme:help-desk: drscheme:help-desk^])
(export)
(application-file-handler
(let ([default (application-file-handler)])
(λ (name)
(if (null? (get-top-level-windows))
(handler:edit-file name)
(default name)))))
(application-quit-handler
(let ([default (application-quit-handler)])
(λ ()
(if (null? (get-top-level-windows))
(when (exit:user-oks-exit)
(exit:exit))
(default)))))
(application-about-handler
(λ ()
(drscheme:app:about-drscheme)))
(drscheme:modes:add-initial-modes)
(namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin)
(finder:default-filters (list* '("Scheme (.ss)" "*.ss")
'("Scheme (.scm)" "*.scm")
(finder:default-filters)))
(application:current-app-name (string-constant drscheme))
(preferences:set-default 'drscheme:toolbar-state
'(#f . top)
(λ (x) (and (pair? x)
(boolean? (car x))
(memq (cdr x) '(left top right)))))
(preferences:set-default 'drscheme:htdp:last-set-teachpacks
'()
(λ (x)
(and (list? x)
(andmap (λ (x)
(and (list? x)
(pair? x)
(eq? (car x) 'lib)
(andmap string? (cdr x))))
x))))
(preferences:set-default 'drscheme:defs/ints-horizontal #f boolean?)
(preferences:set-default 'drscheme:unit-window-max? #f boolean?)
(preferences:set-default 'drscheme:frame:initial-position #f
(λ (x) (or (not x)
(and (pair? x)
(number? (car x))
(number? (cdr x))))))
(preferences:set-default 'drscheme:limit-memory (* 1024 1024 128)
(λ (x) (or (boolean? x)
(integer? x)
(x . >= . (* 1024 1024 100)))))
(preferences:set-default 'drscheme:recent-language-names
null
(λ (x)
(and (list? x)
(andmap
(λ (x)
(and (pair? x)
(string? (car x))))
x))))
(preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?)
(preferences:set-default 'drscheme:open-in-tabs #f boolean?)
(preferences:set-default 'drscheme:toolbar-shown #t boolean?)
(preferences:set-default 'drscheme:user-defined-keybindings
'()
(λ (x) (and (list? x)
(andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x)))
x))))
(preferences:set-un/marshall
'drscheme:user-defined-keybindings
(λ (in) (map (λ (x) (if (path? x) (path->bytes x) x))
in))
(λ (ex) (if (list? ex)
(map (λ (x) (if (bytes? x) (bytes->path x) x)) ex)
'())))
(let ([number-between-zero-and-one?
(λ (x) (and (number? x) (<= 0 x 1)))])
(preferences:set-default 'drscheme:unit-window-size-percentage
1/2
number-between-zero-and-one?)
(preferences:set-default 'drscheme:module-browser-size-percentage
1/5
number-between-zero-and-one?))
(preferences:set-default 'drscheme:module-browser:name-length 1
(λ (x) (memq x '(0 1 2))))
(let ([frame-width 600]
[frame-height 650]
[window-trimming-upper-bound-width 20]
[window-trimming-upper-bound-height 50])
(let-values ([(w h) (get-display-size)])
(set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
(set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))
(preferences:set-default 'drscheme:unit-window-width frame-width number?)
(preferences:set-default 'drscheme:unit-window-height frame-height number?))
(preferences:set-default 'drscheme:backtrace-window-width 400 number?)
(preferences:set-default 'drscheme:backtrace-window-height 300 number?)
(preferences:set-default 'drscheme:backtrace-window-x 0 number?)
(preferences:set-default 'drscheme:backtrace-window-y 0 number?)
(preferences:set-default 'drscheme:profile-how-to-count 'time
(λ (x)
(memq x '(time count))))
(preferences:set-default 'drscheme:profile:low-color
(make-object color% 150 255 150)
(λ (x) (is-a? x color%)))
(preferences:set-default 'drscheme:profile:high-color
(make-object color% 255 150 150)
(λ (x) (is-a? x color%)))
(preferences:set-default 'drscheme:profile:scale
'linear
(λ (x) (memq x '(sqrt linear square))))
(preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?)
;; size is in editor positions
(preferences:set-default 'drscheme:repl-buffer-size
'(#t . 1000)
(λ (x)
(and (pair? x)
(boolean? (car x))
(integer? (cdr x))
(<= 1 (cdr x) 10000))))
(let ([marshall-color
(λ (c)
(list (send c red) (send c green) (send c blue)))]
[unmarshall-color
(λ (l)
(if (and (list? l)
(= 3 (length l))
(andmap (λ (x) (and number? (<= 0 x 255)))
l))
(make-object color% (car l) (cadr l) (caddr l))
(make-object color% 0 0 0)))])
(preferences:set-un/marshall
'drscheme:profile:low-color
marshall-color
unmarshall-color)
(preferences:set-un/marshall
'drscheme:profile:high-color
marshall-color
unmarshall-color))
(preferences:set-default
'drscheme:keybindings-window-size
(cons 200 400)
(λ (x) (and (pair? x)
(number? (car x))
(number? (cdr x)))))
(preferences:set-default
'drscheme:execute-warning-once
#f
(λ (x)
(or (eq? x #t)
(not x))))
(preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?)
(preferences:set-default
'drscheme:default-tools-configuration
'load
(lambda (p)
(memq p '(load skip))))
(preferences:set-default
'drscheme:tools-configuration
null
list?)
(drscheme:font:setup-preferences)
(color-prefs:add-background-preferences-panel)
(scheme:add-preferences-panel)
(scheme:add-coloring-preferences-panel)
(preferences:add-editor-checkbox-panel)
(preferences:add-warnings-checkbox-panel)
(preferences:add-scheme-checkbox-panel)
(let ([make-check-box
(λ (pref-sym string parent)
(let ([q (make-object check-box%
string
parent
(λ (checkbox evt)
(preferences:set
pref-sym
(send checkbox get-value))))])
(preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
(send q set-value (preferences:get pref-sym))))])
(preferences:add-to-editor-checkbox-panel
(λ (editor-panel)
(make-check-box 'drscheme:open-in-tabs
(string-constant open-files-in-tabs)
editor-panel)
(make-check-box 'drscheme:show-interactions-on-execute
(string-constant show-interactions-on-execute)
editor-panel)
(make-check-box 'drscheme:switch-to-module-language-automatically?
(string-constant switch-to-module-language-automatically)
editor-panel)
(make-check-box 'drscheme:defs/ints-horizontal
(string-constant interactions-beside-definitions)
editor-panel)
;; come back to this one.
#;
(letrec ([hp (new horizontal-panel%
(parent editor-panel)
(alignment '(left top))
(stretchable-height #f))]
[cb (new check-box%
(label (string-constant limit-interactions-size))
(parent hp)
(callback (λ (cb v) (cb-callback))))]
[sl (new slider%
(label #f)
(parent hp)
(min-value 1)
(max-value 10000)
(callback
(λ (sl _) (sl-callback))))]
[cb-callback
(λ ()
(preferences:set 'drscheme:repl-buffer-size
(cons (send cb get-value)
(cdr (preferences:get 'drscheme:repl-buffer-size)))))]
[sl-callback
(λ ()
(preferences:set 'drscheme:repl-buffer-size
(cons (car (preferences:get 'drscheme:repl-buffer-size))
(send sl get-value))))]
[update-controls
(λ (v)
(let ([on? (car v)])
(send sl enable on?)
(send cb set-value on?)
(send sl set-value (cdr v))))])
(preferences:add-callback 'drscheme:repl-buffer-size (λ (p v) (update-controls v)))
(update-controls (preferences:get 'drscheme:repl-buffer-size)))))
(preferences:add-to-warnings-checkbox-panel
(λ (warnings-panel)
(make-check-box 'drscheme:execute-warning-once
(string-constant only-warn-once)
warnings-panel)
(make-check-box 'drscheme:test-coverage-ask-about-clearing?
(string-constant test-coverage-ask?)
warnings-panel))))
(drscheme:debug:add-prefs-panel)
(install-help-browser-preference-panel)
(drscheme:tools:add-prefs-panel)
(drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '())
(drscheme:language:register-capability 'drscheme:define-popup
(or/c (cons/c string? string?) false/c)
(cons "(define" "(define ...)"))
(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)
(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)
(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)
(drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)
(drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)
(drscheme:language:register-capability 'drscheme:language-menu-title
(flat-contract string?)
(string-constant scheme-menu-name))
(drscheme:language:register-capability 'drscheme:teachpack-menu-items
(or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?))
#f)
(handler:current-create-new-window
(let ([drscheme-current-create-new-window
(λ (filename)
(drscheme:unit:open-drscheme-window filename))])
drscheme-current-create-new-window))
;; add a catch-all handler to open drscheme files
(handler:insert-format-handler
"Units"
(λ (filename) #t)
drscheme:unit:open-drscheme-window)
;; add a handler to open .plt files.
(handler:insert-format-handler
"PLT Files"
(λ (filename)
(let ([ext (filename-extension filename)])
(and ext
(or (bytes=? #"PLT" ext)
(bytes=? #"plt" ext))
(gui-utils:get-choice
(format (string-constant install-plt-file) filename)
(string-constant install-plt-file/yes)
(string-constant install-plt-file/no)))))
(λ (filename)
(run-installer filename)
#f))
(drscheme:tools:load/invoke-all-tools
(λ () (void))
(λ ()
(drscheme:language-configuration:add-built-in-languages)
(drscheme:module-language:add-module-language)
(drscheme:language-configuration:add-info-specified-languages)))
;; no more extension after this point
(drscheme:get/extend:get-interactions-canvas)
(drscheme:get/extend:get-definitions-canvas)
(drscheme:get/extend:get-unit-frame)
(drscheme:get/extend:get-interactions-text)
(drscheme:get/extend:get-definitions-text)
(drscheme:language-configuration:get-languages)
;; this default can only be set *after* the
;; languages have all be registered by tools
(preferences:set-default
drscheme:language-configuration:settings-preferences-symbol
(drscheme:language-configuration:get-default-language-settings)
drscheme:language-configuration:language-settings?)
;; if the unmarshaller returns #f, that will fail the
;; test for this preference, reverting back to the default.
;; In that case, the default is specified in the pref.ss file
;; of the default collection and may not be the default
;; specified above (of course).
(preferences:set-un/marshall
drscheme:language-configuration:settings-preferences-symbol
(λ (x)
(let ([lang (drscheme:language-configuration:language-settings-language x)]
[settings (drscheme:language-configuration:language-settings-settings x)])
(list (send lang get-language-numbers)
(send lang marshall-settings settings))))
(λ (x)
(and (list? x)
(= 2 (length x))
(let* ([lang-nums (first x)]
[marshalled-settings (second x)]
[lang (ormap
(λ (x)
(and (or (equal? (send x get-language-numbers) lang-nums)
;; this second branch of the `or' corresdponds
;; to preferences saved from earlier versions of
;; drscheme, for a sort of backwards compatibility
(equal? (send x get-language-position) lang-nums))
x))
(drscheme:language-configuration:get-languages))])
(and lang
(let ([settings (send lang unmarshall-settings marshalled-settings)])
(drscheme:language-configuration:make-language-settings
lang
(or settings (send lang default-settings)))))))))
(let ([drs-handler-recent-items-super%
(class (drscheme:frame:basics-mixin
(frame:standard-menus-mixin
frame:basic%))
(define/override (edit-menu:between-select-all-and-find menu)
(void))
(super-new))])
(handler:set-recent-items-frame-superclass drs-handler-recent-items-super%))
(cond
[(current-eventspace-has-menu-root?)
(drscheme:frame:create-root-menubar)
(preferences:set 'framework:exit-when-no-frames #f)]
[else
(preferences:set 'framework:exit-when-no-frames #t)])
(let* ([sl (editor:get-standard-style-list)]
[sd (make-object style-delta%)])
(send sd set-delta-foreground (make-object color% 255 0 0))
(send sl new-named-style
"drscheme:text:ports err"
(send sl find-or-create-style
(send sl find-named-style "text:ports err")
sd)))
(define repl-error-pref 'drscheme:read-eval-print-loop:error-color)
(define repl-out-pref 'drscheme:read-eval-print-loop:out-color)
(define repl-value-pref 'drscheme:read-eval-print-loop:value-color)
(color-prefs:register-color-preference repl-value-pref
"text:ports value"
(make-object color% 0 0 175)
(make-object color% 57 89 216))
(color-prefs:register-color-preference repl-error-pref
"text:ports err"
(let ([sd (make-object style-delta% 'change-italic)])
(send sd set-delta-foreground (make-object color% 255 0 0))
sd))
(color-prefs:register-color-preference repl-out-pref
"text:ports out"
(make-object color% 150 0 150)
(make-object color% 192 46 214))
(color-prefs:add-to-preferences-panel
(string-constant repl-colors)
(λ (parent)
(color-prefs:build-color-selection-panel parent
repl-value-pref
"text:ports value"
(string-constant repl-value-color))
(color-prefs:build-color-selection-panel parent
repl-error-pref
"text:ports err"
(string-constant repl-error-color))
(color-prefs:build-color-selection-panel parent
repl-out-pref
"text:ports out"
(string-constant repl-out-color))))
;; Check for any files lost last time.
;; Ignore the framework's empty frames test, since
;; the autosave information window may appear and then
;; go away (leaving no frames temporarily) but we are
;; not going to be exiting yet.
(autosave:restore-autosave-files/gui)
;; install user's keybindings
(for-each drscheme:frame:add-keybindings-item
(preferences:get 'drscheme:user-defined-keybindings))
;; the initial window doesn't set the
;; unit object's state correctly, yet.
(define (make-basic)
(let* ([frame (drscheme:unit:open-drscheme-window)]
[interactions-edit (send frame get-interactions-text)]
[definitions-edit (send frame get-interactions-text)]
[filename (send definitions-edit get-filename)])
(unless filename
(send frame update-shown)
(send (send frame get-interactions-canvas) focus))
(send frame show #t)))
(define (remove-duplicates files)
(let loop ([files files])
(cond
[(null? files) null]
[else (if (member (car files) (cdr files))
(loop (cdr files))
(cons (car files) (loop (cdr files))))])))
;; NOTE: drscheme-normal.ss sets current-command-line-arguments to
;; the list of files to open, after parsing out flags like -h
(let* ([files-to-open
(if (preferences:get 'drscheme:open-in-tabs)
(vector->list (current-command-line-arguments))
(reverse (vector->list (current-command-line-arguments))))]
[normalized/filtered
(let loop ([files files-to-open])
(cond
[(null? files) null]
[else (let ([file (car files)])
(if (file-exists? file)
(cons (normalize-path file) (loop (cdr files)))
(begin
(message-box
(string-constant drscheme)
(format (string-constant cannot-open-because-dne) file))
(loop (cdr files)))))]))]
[no-dups (remove-duplicates normalized/filtered)]
[frames
(map (λ (f) (handler:edit-file
f
(λ () (drscheme:unit:open-drscheme-window f))))
no-dups)])
(when (null? (filter (λ (x) x) frames))
(make-basic))
(when (and (preferences:get 'drscheme:open-in-tabs)
(not (null? no-dups)))
(handler:edit-file (car no-dups))))

46
collects/drscheme/private/modes.ss
View File

@ -1,46 +0,0 @@
#lang scheme/unit
(require string-constants
mzlib/class
mzlib/list
framework
"drsig.ss")
(import)
(export drscheme:modes^)
(define-struct mode (name surrogate repl-submit matches-language))
(define modes (list))
(define (get-modes) modes)
(define (add-mode name surrogate repl-submit matches-language)
(let ([new-mode (make-mode name
surrogate
repl-submit
matches-language)])
(set! modes (cons new-mode modes))
new-mode))
(define (not-a-language-language? l)
(and (not (null? l))
(equal? (car (last-pair l))
(string-constant no-language-chosen))))
(define (add-initial-modes)
;; must be added first, to make it last in mode list,
;; since predicate matches everything
(add-mode
(string-constant scheme-mode)
(new scheme:text-mode%)
(λ (text prompt-position) (scheme:text-balanced? text prompt-position))
(λ (l) #t))
(add-mode
(string-constant text-mode)
#f
(λ (text prompt-position) #t)
(λ (l)
(and l
(or (not-a-language-language? l)
(ormap (λ (x) (regexp-match #rx"Algol" x)) l))))))

1002
collects/drscheme/private/module-browser.ss
View File

File diff suppressed because it is too large Load Diff

535
collects/drscheme/private/module-language.ss
View File

@ -1,535 +0,0 @@
#lang scheme/unit
(require scheme/unit
scheme/class
scheme/list
mred
compiler/embed
launcher
framework
string-constants
"drsig.ss"
scheme/contract)
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:rep: drscheme:rep^])
(export drscheme:module-language^)
(define module-language<%>
(interface ()
))
;; add-module-language : -> void
;; adds the special module-only language to drscheme
(define (add-module-language)
(define module-language%
(module-mixin
((drscheme:language:get-default-mixin)
(drscheme:language:module-based-language->language-mixin
(drscheme:language:simple-module-based-language->module-based-language-mixin
drscheme:language:simple-module-based-language%)))))
(drscheme:language-configuration:add-language
(new module-language%)))
;; collection-paths : (listof (union 'default string))
;; command-line-args : (vectorof string)
(define-struct (module-language-settings drscheme:language:simple-settings)
(collection-paths command-line-args))
;; module-mixin : (implements drscheme:language:language<%>)
;; -> (implements drscheme:language:language<%>)
(define (module-mixin %)
(class* % (drscheme:language:language<%> module-language<%>)
(define/override (use-namespace-require/copy?) #t)
(field [iteration-number 0])
(define/augment (capability-value key)
(if (eq? key 'drscheme:autocomplete-words)
(drscheme:language-configuration:get-all-scheme-manual-keywords)
(drscheme:language:get-capability-default key)))
;; config-panel : as in super class
;; uses drscheme:language:simple-module-based-language-config-panel and
;; adds a collection paths configuration to it.
(define/override (config-panel parent)
(module-language-config-panel parent))
(define/override (default-settings)
(let ([super-defaults (super default-settings)])
(apply make-module-language-settings
(append (vector->list (drscheme:language:simple-settings->vector
super-defaults))
(list '(default)
#())))))
;; default-settings? : -> boolean
(define/override (default-settings? settings)
(and (super default-settings? settings)
(equal? (module-language-settings-collection-paths settings)
'(default))
(equal? (module-language-settings-command-line-args settings)
#())))
(define/override (marshall-settings settings)
(let ([super-marshalled (super marshall-settings settings)])
(list super-marshalled
(module-language-settings-collection-paths settings)
(module-language-settings-command-line-args settings))))
(define/override (unmarshall-settings marshalled)
(and (pair? marshalled)
(pair? (cdr marshalled))
(pair? (cddr marshalled))
(null? (cdddr marshalled))
(list? (cadr marshalled))
(vector? (caddr marshalled))
(andmap string? (vector->list (caddr marshalled)))
(andmap (λ (x) (or (string? x) (symbol? x)))
(cadr marshalled))
(let ([super (super unmarshall-settings (car marshalled))])
(and super
(apply make-module-language-settings
(append
(vector->list (drscheme:language:simple-settings->vector super))
(list (cadr marshalled)
(caddr marshalled))))))))
(define/override (on-execute settings run-in-user-thread)
(set! iteration-number 0)
(super on-execute settings run-in-user-thread)
(run-in-user-thread
(λ ()
(current-command-line-arguments
(module-language-settings-command-line-args settings))
(let ([default (current-library-collection-paths)])
(current-library-collection-paths
(append-map
(λ (x) (if (symbol? x) default (list x)))
(module-language-settings-collection-paths settings)))))))
(define/override (get-one-line-summary)
(string-constant module-language-one-line-summary))
(inherit get-reader)
(define/override (front-end/interaction port settings)
(if (thread-cell-ref hopeless-repl)
(hopeless-shout)
(super front-end/interaction port settings)))
(define/override (front-end/complete-program port settings)
(let* ([super-thunk (λ () ((get-reader) (object-name port) port))]
[path (get-filename port)]
[module-name #f]
[get-require-module-name
(λ ()
;; "clearing out" the module-name via datum->syntax ensures
;; that check syntax doesn't think the original module name
;; is being used in this require (so it doesn't get turned red)
(datum->syntax #'here (syntax-e module-name)))])
(λ ()
(set! iteration-number (+ iteration-number 1))
(case iteration-number
[(1)
#`(current-module-declare-name
(if #,path
(make-resolved-module-path '#,path)
#f))]
[(2)
(let ([super-result (super-thunk)])
(if (eof-object? super-result)
(hopeless-shout)
(let-values ([(name new-module)
(transform-module path super-result)])
(set! module-name name)
new-module)))]
[(3)
(let ([super-result (super-thunk)])
(if (eof-object? super-result)
#`(current-module-declare-name #f)
(hopeless-shout
"there can only be one expression in the definitions window"
super-result)))]
[(4)
(if path
#`(begin ((current-module-name-resolver)
(make-resolved-module-path #,path))
(call-with-continuation-prompt
(λ () (dynamic-require #,path #f))))
#`(call-with-continuation-prompt
(λ () (dynamic-require ''#,(get-require-module-name) #f))))]
[(5)
(if path
#`(#%app current-namespace (#%app module->namespace #,path))
#`(#%app current-namespace
(#%app module->namespace
''#,(get-require-module-name))))]
[else eof]))))
;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename)
(let* ([executable-specs (drscheme:language:create-executable-gui
parent program-filename #t #t)])
(when executable-specs
(let ([launcher? (eq? 'launcher (car executable-specs))]
[gui? (eq? 'mred (cadr executable-specs))]
[executable-filename (caddr executable-specs)])
(with-handlers ([(λ (x) #f) ;exn:fail?
(λ (x)
(message-box
(string-constant drscheme)
(if (exn? x)
(format "~a" (exn-message x))
(format "uncaught exception: ~s" x))))])
(if (not launcher?)
(let ([short-program-name
(let-values ([(base name dir) (split-path program-filename)])
(path-replace-suffix name #""))])
((if (eq? 'distribution (car executable-specs))
drscheme:language:create-distribution-for-executable
(lambda (executable-filename gui? make)
(make executable-filename)))
executable-filename
gui?
(lambda (exe-name)
(create-embedding-executable
exe-name
#:mred? gui?
#:verbose? #f ;; verbose?
#:modules (list (list #f program-filename))
#:literal-expression
(begin
(parameterize ([current-namespace (make-base-empty-namespace)])
(namespace-require 'scheme/base)
(compile
`(namespace-require '',(string->symbol (path->string short-program-name))))))
#:cmdline null))))
(let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)])
(make-launcher (list "-qt-" (path->string program-filename))
executable-filename))))))))
(super-new
[module #f]
[language-position (list "Module")]
[language-numbers (list -32768)])))
(define hopeless-repl (make-thread-cell #t))
(define (hopeless-shout . error-args)
(let ([t (current-thread)])
(queue-callback
(λ ()
(fprintf (current-error-port) "\n(Further interactions disabled.)\n")
;; special value that will exit the repl but avoid the popup
(exit "NO NEED TO POPUP A TERMINATION EXPLANATION")))
(apply raise-syntax-error '|Module Language|
(if (null? error-args)
(list (string-append
"There must be a valid module in the\n"
"definitions window. Try starting your program with\n"
"\n"
" #lang scheme\n"
"\n"
"and clicking ‘Run’."))
error-args))))
;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void))
(define (module-language-config-panel parent)
(define new-parent
(new vertical-panel%
[parent parent]
[alignment '(center center)]
[stretchable-height #f]
[stretchable-width #f]))
(define simple-case-lambda
(drscheme:language:simple-module-based-language-config-panel new-parent))
(define cp-panel (new group-box-panel%
[parent new-parent]
[label (string-constant ml-cp-collection-paths)]))
(define args-panel (new group-box-panel%
[parent new-parent]
[label (string-constant ml-command-line-arguments)]))
(define args-text-box (new text-field%
[parent args-panel]
[label #f]
[init-value "#()"]
[callback void]))
;; data associated with each item in listbox : boolean
;; indicates if the entry is the default paths.
(define lb (new list-box%
[parent cp-panel]
[choices '("a" "b" "c")]
[label #f]
[callback (λ (x y) (update-buttons))]))
(define button-panel (new horizontal-panel%
[parent cp-panel]
[alignment '(center center)]
[stretchable-height #f]))
(define add-button
(make-object button% (string-constant ml-cp-add) button-panel
(λ (x y) (add-callback))))
(define add-default-button
(make-object button% (string-constant ml-cp-add-default) button-panel
(λ (x y) (add-default-callback))))
(define remove-button
(make-object button% (string-constant ml-cp-remove) button-panel
(λ (x y) (remove-callback))))
(define raise-button
(make-object button% (string-constant ml-cp-raise) button-panel
(λ (x y) (move-callback -1))))
(define lower-button
(make-object button% (string-constant ml-cp-lower) button-panel
(λ (x y) (move-callback +1))))
(define (update-buttons)
(let ([lb-selection (send lb get-selection)]
[lb-tot (send lb get-number)])
(send remove-button enable lb-selection)
(send raise-button enable (and lb-selection (not (= lb-selection 0))))
(send lower-button enable
(and lb-selection (not (= lb-selection (- lb-tot 1)))))))
(define (add-callback)
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
(send parent get-top-level-window))])
(when dir
(send lb append (path->string dir) #f)
(update-buttons))))
(define (add-default-callback)
(cond [(has-default?)
(message-box (string-constant drscheme)
(string-constant ml-cp-default-already-present)
(send parent get-top-level-window))]
[else
(send lb append (string-constant ml-cp-default-collection-path) #t)
(update-buttons)]))
;; has-default? : -> boolean
;; returns #t if the `default' entry has already been added
(define (has-default?)
(let loop ([n (send lb get-number)])
(cond [(= n 0) #f]
[(send lb get-data (- n 1)) #t]
[else (loop (- n 1))])))
(define (remove-callback)
(let ([to-delete (send lb get-selection)])
(send lb delete to-delete)
(unless (zero? (send lb get-number))
(send lb set-selection (min to-delete (- (send lb get-number) 1))))
(update-buttons)))
(define (move-callback d)
(let* ([sel (send lb get-selection)]
[vec (get-lb-vector)]
[new (+ sel d)]
[other (vector-ref vec new)])
(vector-set! vec new (vector-ref vec sel))
(vector-set! vec sel other)
(set-lb-vector vec)
(send lb set-selection new)
(update-buttons)))
(define (get-lb-vector)
(list->vector (for/list ([n (in-range (send lb get-number))])
(cons (send lb get-string n) (send lb get-data n)))))
(define (set-lb-vector vec)
(send lb clear)
(for ([x (in-vector vec)] [n (in-naturals)])
(send lb append (car x))
(send lb set-data n (cdr x))))
(define (get-collection-paths)
(for/list ([n (in-range (send lb get-number))])
(let ([data (send lb get-data n)])
(if data 'default (send lb get-string n)))))
(define (install-collection-paths paths)
(send lb clear)
(for ([cp paths])
(if (symbol? cp)
(send lb append (string-constant ml-cp-default-collection-path) #t)
(send lb append cp #f))))
(define (get-command-line-args)
(let* ([str (send args-text-box get-value)]
[read-res (parameterize ([read-accept-graph #f])
(with-handlers ([exn:fail:read? (λ (x) #())])
(read (open-input-string str))))])
(if (and (vector? read-res) (andmap string? (vector->list read-res)))
read-res
#())))
(define (install-command-line-args vec)
(send args-text-box set-value
(parameterize ([print-vector-length #f]) (format "~s" vec))))
(send lb set '())
(update-buttons)
(case-lambda
[()
(let ([simple-settings (simple-case-lambda)])
(apply make-module-language-settings
(append (vector->list (drscheme:language:simple-settings->vector
simple-settings))
(list (get-collection-paths)
(get-command-line-args)))))]
[(settings)
(simple-case-lambda settings)
(install-collection-paths
(module-language-settings-collection-paths settings))
(install-command-line-args
(module-language-settings-command-line-args settings))
(update-buttons)]))
;; transform-module : (union #f string) syntax
;; -> (values syntax[name-of-module] syntax[module])
;; = User =
;; in addition to exporting everything, the result module's name
;; is the fully path-expanded name with a directory prefix,
;; if the file has been saved
(define (transform-module filename stx)
(syntax-case* stx (module) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(module name lang . rest)
(eq? 'module (syntax-e #'module))
(let ([v-name #'name])
(when filename (check-filename-matches filename v-name stx))
(thread-cell-set! hopeless-repl #f)
(values
v-name
;; rewrite the module to use the scheme/base version of `module'
(let* ([mod (datum->syntax #'here 'module #'form)]
[expr (datum->syntax stx `(,mod ,#'name ,#'lang . ,#'rest) stx)])
;; now expand it, and if there's an error, then use a minimal module
;; that will use the language as usual and report the error, it'll
;; turn to 3d code:
;; (module <name> <lang> (raise <the-stx-exn>))
;; so the repl will have at least the language bindings. (this won't
;; work right with a bad language name -- but that kind of error will
;; be reported anyway.)
(with-handlers
([void (lambda (e)
(fprintf (current-error-port)
(string-append
"*** Module Language: there is a syntax error"
" in your code, so it was not evaluated;\n"
"*** the interactions below have only the"
" language bindings for ‘~s’\n")
(syntax->datum #'lang))
(datum->syntax
stx `(,mod ,#'name ,#'lang ,#`(#%app raise #,e)) stx))])
(expand expr)))))]
[else (hopeless-shout
(string-append "only a module expression is allowed, either\n"
" #lang <language-name>\n or\n"
" (module <name> <language> ...)\n")
stx)]))
;; get-filename : port -> (union string #f)
;; extracts the file the definitions window is being saved in, if any.
(define (get-filename port)
(let ([source (object-name port)])
(cond
[(path? source) source]
[(is-a? source text%)
(let ([canvas (send source get-canvas)])
(and canvas
(let ([frame (send canvas get-top-level-window)])
(and (is-a? frame drscheme:unit:frame%)
(let* ([b (box #f)]
[filename (send (send frame get-definitions-text)
get-filename
b)])
(if (unbox b)
#f
filename))))))]
[else #f])))
;; check-filename-matches : string datum syntax -> void
(define (check-filename-matches filename name unexpanded-stx)
(define datum (syntax-e name))
(unless (symbol? datum)
(hopeless-shout "bad syntax in name position of module"
unexpanded-stx name))
(let-values ([(base name dir?) (split-path filename)])
(let ([expected (string->symbol
(path->string (path-replace-suffix name #"")))])
(unless (equal? expected datum)
(hopeless-shout
(format
"module name doesn't match saved filename, got ~s and expected ~s"
datum
expected)
unexpanded-stx)))))
(define module-language-put-file-mixin
(mixin (text:basic<%>) ()
(inherit get-text last-position get-character get-top-level-window)
(define/override (put-file directory default-name)
(let ([tlw (get-top-level-window)])
(if (and tlw (is-a? tlw drscheme:unit:frame<%>))
(let* ([definitions-text (send tlw get-definitions-text)]
[module-language?
(is-a? (drscheme:language-configuration:language-settings-language
(send definitions-text get-next-settings))
module-language<%>)]
[module-default-filename
(and module-language? (get-module-filename))])
(super put-file directory module-default-filename))
(super put-file directory default-name))))
;; returns the name after "(module " suffixed with .scm
;; in the beginning of the editor
;; or #f if the beginning doesn't match "(module "
(define/private (get-module-filename)
(let ([open-paren (skip-whitespace 0)])
(or (match-paren open-paren "(")
(match-paren open-paren "[")
(match-paren open-paren "{"))))
(define/private (match-paren open-paren paren)
(and (matches open-paren paren)
(let ([module (skip-whitespace (+ open-paren 1))])
(and (matches module "module")
(let* ([end-module (+ module (string-length "module"))]
[filename-start (skip-whitespace end-module)]
[filename-end (skip-to-whitespace filename-start)])
(and (not (= filename-start end-module))
(string-append (get-text filename-start filename-end)
".scm")))))))
(define/private (matches start string)
(let ([last-pos (last-position)])
(let loop ([i 0])
(cond [(and (i . < . (string-length string))
((+ i start) . < . last-pos))
(and (char=? (string-ref string i)
(get-character (+ i start)))
(loop (+ i 1)))]
[(= i (string-length string)) #t]
[else #f]))))
(define/private (skip-whitespace start)
(let ([last-pos (last-position)])
(let loop ([pos start])
(if (pos . >= . last-pos)
last-pos
(let ([char (get-character pos)])
(if (char-whitespace? char)
(loop (+ pos 1))
pos))))))
(define/private (skip-to-whitespace start)
(let ([last-pos (last-position)])
(let loop ([pos start])
(cond [(pos . >= . last-pos) last-pos]
[(char-whitespace? (get-character pos)) pos]
[else (loop (+ pos 1))]))))
(super-new)))

716
collects/drscheme/private/multi-file-search.ss
View File

@ -1,716 +0,0 @@
#lang scheme/unit
(require framework
mzlib/class
mred
scheme/file
scheme/path
mzlib/thread
mzlib/async-channel
string-constants
"drsig.ss")
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^])
(export drscheme:multi-file-search^)
;; multi-file-search : -> void
;; opens a dialog to configure the search and initiates the search
(define (multi-file-search)
(let ([search-info (configure-search)])
(when search-info
(open-search-window search-info))))
;; searcher = (string (string int int int -> void) -> void)
;; this performs a single search.
;; the first argument is the filename to be searched
;; the second argument is called for each match.
;; the arguments are: line-string line-number col-number match-length
;; search-type = (make-search-type string make-searcher (listof (cons string boolean)))
;; the param strings are the labels for checkboxes
;; the param booleans are the default values for the checkboxes
;; these are the available searches
(define-struct search-type (label make-searcher params))
;; search-info = (make-search-info string boolean (union #f regexp) search-type)
(define-struct search-info (dir recur? filter searcher))
;; search-types : (listof search-type)
(define search-types
(list (make-search-type
(string-constant mfs-string-match/graphics)
(λ (info search-string) (exact-match-searcher info search-string))
(list (cons (string-constant mfs-case-sensitive-label) #f)))
(make-search-type
(string-constant mfs-regexp-match/no-graphics)
(λ (info search-string) (regexp-match-searcher info search-string))
(list))))
;; search-entry = (make-search-entry string number number number)
(define-struct search-entry (filename line-string line-number col-number match-length))
;; preferences initialization
(preferences:set-default 'drscheme:multi-file-search:recur? #t boolean?)
(preferences:set-default 'drscheme:multi-file-search:filter? #t boolean?)
(preferences:set-default 'drscheme:multi-file-search:filter-string "\\.(ss|scm)$" string?)
(preferences:set-default 'drscheme:multi-file-search:search-string "" string?)
(preferences:set-default 'drscheme:multi-file-search:search-type
1
(λ (x)
(and (number? x)
(exact? x)
(integer? x)
(<= 0 x)
(< x (length search-types)))))
;; drscheme:mult-file-search:search-check-boxes : (listof (listof boolean))
(preferences:set-default 'drscheme:multi-file-search:search-check-boxes
(map (λ (x) (map cdr (search-type-params x)))
search-types)
(λ (x)
(and (list? x)
(andmap (λ (x)
(and (list? x)
(andmap boolean? x)))
x))))
(preferences:set-default 'drscheme:multi-file-search:percentages
'(1/3 2/3)
(λ (x) (and (list? x)
(= 2 (length x))
(= 1 (apply + x)))))
(preferences:set-default 'drscheme:multi-file-search:frame-size '(300 . 400)
(λ (x) (and (pair? x)
(number? (car x))
(number? (cdr x)))))
(preferences:set-default 'drscheme:multi-file-search:directory
;; The default is #f because
;; filesystem-root-list is expensive under Windows
#f
(lambda (x) (or (not x) (path? x))))
(preferences:set-un/marshall
'drscheme:multi-file-search:directory
(λ (v) (and v (path->string v)))
(λ (p) (if (path-string? p)
(string->path p)
#f)))
;; open-search-window : search-info -> void
;; thread: eventspace main thread
;; opens a window and creates the thread that does the search
(define (open-search-window search-info)
(define frame (make-object search-size-frame% (string-constant mfs-drscheme-multi-file-search)))
(define panel (make-object saved-vertical-resizable% (send frame get-area-container)))
(define button-panel (make-object horizontal-panel% (send frame get-area-container)))
(define open-button (make-object button% (string-constant mfs-open-file) button-panel
(λ (x y) (open-file-callback))))
(define stop-button (make-object button% (string-constant mfs-stop-search) button-panel
(λ (x y) (stop-callback))))
(define grow-box-pane (make-object grow-box-spacer-pane% button-panel))
(define zoom-text (make-object scheme:text%))
(define results-text (make-object results-text% zoom-text))
(define results-ec (instantiate searching-canvas% ()
(parent panel)
(editor results-text)
(frame frame)))
(define zoom-ec (instantiate searching-canvas% ()
(parent panel)
(editor zoom-text)
(frame frame)))
(define (open-file-callback)
(send results-text open-file))
;; sometimes, breaking the other thread puts
;; the break message in the channel behind
;; many many requests. Rather than show those,
;; we use the `broken?' flag as a shortcut.
(define broken? #f)
(define (stop-callback)
(break-thread search-thd)
(set! broken? #t)
(send stop-button enable #f))
;; channel : async-channel[(union 'done search-entry)]
(define channel (make-async-channel 100))
(define search-thd (thread (λ () (do-search search-info channel))))
(send frame set-text-to-search results-text) ;; just to initialize it to something.
(send results-text lock #t)
(send frame reflow-container)
(send panel set-percentages (preferences:get 'drscheme:multi-file-search:percentages))
(send button-panel set-alignment 'right 'center)
(send button-panel stretchable-height #f)
(send frame show #t)
(let loop ()
(let ([match (yield channel)])
(yield)
(cond
[(eq? match 'done)
(send results-text search-complete)
(send stop-button enable #f)]
[(or broken? (eq? match 'break))
(send results-text search-interrupted)]
[else
(send results-text add-match
(search-info-dir search-info)
(search-entry-filename match)
(search-entry-line-string match)
(search-entry-line-number match)
(search-entry-col-number match)
(search-entry-match-length match))
(loop)]))))
(define results-super-text%
(text:hide-caret/selection-mixin
(text:basic-mixin
(editor:standard-style-list-mixin
(editor:basic-mixin
text%)))))
;; results-text% : derived from text%
;; init args: zoom-text
;; zoom-text : (instance-of text%)
;; public-methods:
;; add-match : string string int int int int -> void
;; adds a match to the text
;; search-interrupted : -> void
;; inserts a message saying "search interrupted".
;; search-complete is not expected to be called if this method is called.
;; search-complete : -> void
;; inserts a message saying "no matches found" if none were reported
(define results-text%
(class results-super-text%
(init-field zoom-text)
(inherit insert last-paragraph erase
paragraph-start-position paragraph-end-position
last-position change-style
set-clickback set-position
end-edit-sequence begin-edit-sequence
lock)
[define filename-delta (make-object style-delta% 'change-bold)]
[define match-delta (let ([d (make-object style-delta%)])
(send d set-delta-foreground
(make-object color%
0
160
0))
d)]
[define hilite-line-delta (make-object style-delta% 'change-style 'italic)]
[define unhilite-line-delta (make-object style-delta% 'change-style 'normal)]
[define widest-filename #f]
[define/private indent-all-lines
;; indent-all-lines : number -> void
;; inserts `offset' spaces to the beginning of each line,
;; except the last one. Must be at least one such line in the text.
(λ (offset)
(let ([spaces (make-string offset #\space)])
(let loop ([para (- (last-paragraph) 1)])
(let ([para-start (paragraph-start-position para)])
(insert spaces para-start para-start)
(change-style filename-delta para-start (+ para-start offset)))
(unless (zero? para)
(loop (- para 1))))))]
;; match-shown? : boolean
;; indicates if a match has ever been shown.
;; if not, need to clean out the "searching" message
;; and show a match. Done in `add-match'
[define match-shown? #f]
;; current-file : (union #f string)
;; the name of the currently viewed file, if one if viewed.
;; line-in-current-file and col-in-current-file are linked
[define current-file #f]
[define line-in-current-file #f]
[define col-in-current-file #f]
[define old-line #f]
[define/private hilite-line
(λ (line)
(begin-edit-sequence)
(lock #f)
(when old-line
(change-style unhilite-line-delta
(paragraph-start-position old-line)
(paragraph-end-position old-line)))
(when line
(change-style hilite-line-delta
(paragraph-start-position line)
(paragraph-end-position line)))
(set! old-line line)
(lock #t)
(end-edit-sequence))]
[define/public (open-file)
(when current-file
(let ([f (handler:edit-file current-file)])
(when (and f
(is-a? f drscheme:unit:frame<%>))
(let* ([t (send f get-definitions-text)]
[pos (+ (send t paragraph-start-position line-in-current-file)
col-in-current-file)])
(send t set-position pos)))))]
[define/public add-match
(λ (base-filename full-filename line-string line-number col-number match-length)
(lock #f)
(let* ([new-line-position (last-position)]
[short-filename
(path->string
(find-relative-path
(normalize-path base-filename)
(normalize-path full-filename)))]
[this-match-number (last-paragraph)]
[len (string-length short-filename)]
[insertion-start #f]
[show-this-match
(λ ()
(set! match-shown? #t)
(set! current-file full-filename)
(set! line-in-current-file line-number)
(set! col-in-current-file col-number)
(set-position new-line-position new-line-position)
(send zoom-text begin-edit-sequence)
(send zoom-text lock #f)
(send zoom-text load-file/gui-error full-filename)
(send zoom-text set-position (send zoom-text paragraph-start-position line-number))
(let ([start (+ (send zoom-text paragraph-start-position line-number)
col-number)])
(send zoom-text change-style match-delta start (+ start match-length)))
(send zoom-text lock #t)
(send zoom-text set-caret-owner #f 'global)
(hilite-line this-match-number)
(send zoom-text end-edit-sequence))])
(unless match-shown?
(erase))
(unless widest-filename
(set! widest-filename len))
(if (<= len widest-filename)
(begin
(set! insertion-start (last-position))
(insert (make-string (- widest-filename len) #\space)
(last-position) (last-position)))
(begin
(indent-all-lines (- len widest-filename))
(set! insertion-start (last-position))
(set! widest-filename len)))
(let ([filename-start (last-position)])
(insert short-filename (last-position) (last-position))
(insert ": " (last-position) (last-position))
(change-style filename-delta insertion-start (last-position))
(let ([line-start (last-position)])
(insert line-string (last-position) (last-position))
(change-style match-delta
(+ line-start col-number)
(+ line-start col-number match-length)))
(set-clickback filename-start (last-position)
(λ (_1 _2 _3)
(show-this-match)))
(insert #\newline (last-position) (last-position))
(unless match-shown?
(show-this-match))))
(lock #t))]
(define/public (search-interrupted)
(lock #f)
(insert #\newline (last-position) (last-position))
(insert (string-constant mfs-search-interrupted) (last-position) (last-position))
(lock #t))
(define/public (search-complete)
(unless match-shown?
(lock #f)
(insert #\newline (last-position) (last-position))
(insert (string-constant mfs-no-matches-found) (last-position) (last-position))
(lock #t)))
(inherit get-style-list set-style-list set-styles-sticky)
(super-instantiate ())
(send zoom-text lock #t)
(set-styles-sticky #f)
(insert (string-constant mfs-searching...))))
;; collaborates with search-size-frame%
(define searching-canvas%
(class canvas:basic%
(init-field frame)
(inherit get-editor)
(define/override (on-focus on?)
(when on?
(send frame set-text-to-search (get-editor)))
(super on-focus on?))
(super-instantiate ())))
;; thread: eventspace main thread
(define search-size-frame%
(class (drscheme:frame:basics-mixin
(frame:searchable-mixin
frame:standard-menus%))
(init-field name)
(field [text-to-search #f])
(define/public (set-text-to-search text) (set! text-to-search text))
(define/override (get-text-to-search) text-to-search)
(define/override (on-size w h)
(preferences:set 'drscheme:multi-file-search:frame-size (cons w h))
(super on-size w h))
(let ([size (preferences:get 'drscheme:multi-file-search:frame-size)])
(super-instantiate ()
(label name)
(width (car size))
(height (cdr size))))))
;; this vertical-resizable class just remembers the percentage between the
;; two panels
;; thread: eventspace main thread
(define saved-vertical-resizable%
(class panel:vertical-dragable%
(inherit get-percentages)
(define/augment (after-percentage-change)
(let ([ps (get-percentages)])
(when (= (length ps) 2)
(preferences:set 'drscheme:multi-file-search:percentages ps)))
(inner (void) after-percentage-change))
(super-instantiate ())))
;; configure-search : -> (union #f search-info)
;; thread: eventspace main thread
;; configures the search
(define (configure-search)
(define dialog (make-object dialog% (string-constant mfs-configure-search)
#f 500 #f #f #f '(resize-border)))
(define outer-files-panel (make-object vertical-panel% dialog '(border)))
(define outer-method-panel (make-object vertical-panel% dialog '(border)))
(define button-panel (make-object horizontal-panel% dialog))
(define files-label (make-object message% (string-constant mfs-files-section) outer-files-panel))
(define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel))
(define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel))
(define files-panel (make-object vertical-panel% files-inset-outer-panel))
(define method-label (make-object message% (string-constant mfs-search-section) outer-method-panel))
(define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel))
(define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel))
(define method-panel (make-object vertical-panel% method-inset-outer-panel))
(define dir-panel (make-object horizontal-panel% files-panel))
(define dir-field (make-object text-field% (string-constant mfs-dir) dir-panel
(λ (x y) (dir-field-callback))))
(define dir-button (make-object button% (string-constant browse...) dir-panel
(λ (x y) (dir-button-callback))))
(define recur-check-box (make-object check-box% (string-constant mfs-recur-over-subdirectories) files-panel
(λ (x y) (recur-check-box-callback))))
(define filter-panel (make-object horizontal-panel% files-panel))
(define filter-check-box (make-object check-box% (string-constant mfs-regexp-filename-filter) filter-panel
(λ (x y) (filter-check-box-callback))))
(define filter-text-field (make-object text-field% #f filter-panel
(λ (x y) (filter-text-field-callback))))
(define methods-choice (make-object choice% #f (map search-type-label search-types) method-panel
(λ (x y) (methods-choice-callback))))
(define search-text-field (make-object text-field% (string-constant mfs-search-string) method-panel
(λ (x y) (search-text-field-callback))))
(define active-method-panel (make-object panel:single% method-panel))
(define methods-check-boxess
(let ([pref (preferences:get 'drscheme:multi-file-search:search-check-boxes)])
(map
(λ (search-type prefs-settings)
(let ([p (make-object vertical-panel% active-method-panel)]
[params (search-type-params search-type)])
(send p set-alignment 'left 'center)
(map (λ (flag-pair prefs-setting)
(let ([cb (make-object check-box%
(car flag-pair)
p
(λ (evt chk) (method-callback chk)))])
(send cb set-value prefs-setting)
cb))
params
(if (= (length params) (length prefs-settings))
prefs-settings
(map (λ (x) #f) params)))))
search-types
(if (= (length search-types) (length pref))
pref
(map (λ (x) '()) search-types)))))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons
button-panel
(λ (x y) (ok-button-callback))
(λ (x y) (cancel-button-callback))))
(define spacer (make-object grow-box-spacer-pane% button-panel))
;; initialized to a searcher during the ok button callback
;; so the user can be informed of an error before the dialog
;; closes.
(define searcher #f)
;; initialized to a regexp if the user wants to filter filenames,
;; during the ok-button-callback, so errors can be signalled.
(define filter #f)
;; title for message box that signals error messages
(define message-box-title (string-constant mfs-drscheme-multi-file-search))
(define (ok-button-callback)
(cond
[(with-handlers ([exn:fail:filesystem?
(λ (x) #f)])
(directory-exists? (send dir-field get-value)))
(let ([_searcher
((search-type-make-searcher (list-ref search-types (send methods-choice get-selection)))
(map (λ (cb) (send cb get-value))
(send (send active-method-panel active-child) get-children))
(send search-text-field get-value))])
(if (string? _searcher)
(message-box message-box-title _searcher dialog)
(let ([regexp (with-handlers ([(λ (x) #t)
(λ (exn)
(format "~a" (exn-message exn)))])
(and (send filter-check-box get-value)
(regexp (send filter-text-field get-value))))])
(if (string? regexp)
(message-box message-box-title regexp dialog)
(begin (set! searcher _searcher)
(set! filter regexp)
(set! ok? #t)
(send dialog show #f))))))]
[else
(message-box message-box-title
(format (string-constant mfs-not-a-dir) (send dir-field get-value))
dialog)]))
(define (cancel-button-callback)
(send dialog show #f))
(define (method-callback chk)
(preferences:set
'drscheme:multi-file-search:search-check-boxes
(let loop ([methods-check-boxess methods-check-boxess])
(cond
[(null? methods-check-boxess) null]
[else
(cons (let loop ([methods-check-boxes (car methods-check-boxess)])
(cond
[(null? methods-check-boxes) null]
[else (cons (send (car methods-check-boxes) get-value)
(loop (cdr methods-check-boxes)))]))
(loop (cdr methods-check-boxess)))]))))
(define (dir-field-callback)
(let ([df (send dir-field get-value)])
(when (path-string? df)
(preferences:set 'drscheme:multi-file-search:directory (string->path df)))))
(define (filter-check-box-callback)
(preferences:set 'drscheme:multi-file-search:filter? (send filter-check-box get-value))
(send filter-text-field enable (send filter-check-box get-value)))
(define (filter-text-field-callback)
(preferences:set 'drscheme:multi-file-search:filter-string (send filter-text-field get-value)))
(define (recur-check-box-callback)
(preferences:set 'drscheme:multi-file-search:recur? (send recur-check-box get-value)))
(define (methods-choice-callback)
(preferences:set 'drscheme:multi-file-search:search-type (send methods-choice get-selection))
(send active-method-panel active-child
(list-ref (send active-method-panel get-children)
(send methods-choice get-selection))))
(define (search-text-field-callback)
(preferences:set 'drscheme:multi-file-search:search-string (send search-text-field get-value)))
(define (dir-button-callback)
(let ([d (get-directory)])
(when (and d
(directory-exists? d))
(preferences:set 'drscheme:multi-file-search:directory d)
(send dir-field set-value (path->string d)))))
(define (get-files)
(let ([dir (string->path (send dir-field get-value))])
(and (directory-exists? dir)
(if (send recur-check-box get-value)
(build-recursive-file-list dir filter)
(build-flat-file-list dir filter)))))
(define ok? #f)
(send button-panel set-alignment 'right 'center)
(send dir-panel stretchable-height #f)
(send outer-files-panel stretchable-height #f)
(send outer-files-panel set-alignment 'left 'center)
(send files-inset-panel min-width 20)
(send files-inset-panel stretchable-width #f)
(send files-panel set-alignment 'left 'center)
(send recur-check-box set-value (preferences:get 'drscheme:multi-file-search:recur?))
(send filter-check-box set-value (preferences:get 'drscheme:multi-file-search:filter?))
(send search-text-field set-value (preferences:get 'drscheme:multi-file-search:search-string))
(send filter-text-field set-value (preferences:get 'drscheme:multi-file-search:filter-string))
(send dir-field set-value (path->string
(let ([p (preferences:get 'drscheme:multi-file-search:directory)])
(if (not p)
(let ([p (car (filesystem-root-list))])
(preferences:set 'drscheme:multi-file-search:directory p)
p)
p))))
(send outer-method-panel stretchable-height #f)
(send outer-method-panel set-alignment 'left 'center)
(send method-inset-panel min-width 20)
(send method-inset-panel stretchable-width #f)
(send method-panel set-alignment 'left 'center)
(send filter-panel stretchable-height #f)
(send search-text-field focus)
(send dialog show #t)
(and
ok?
(make-search-info
(send dir-field get-value)
(send recur-check-box get-value)
(and (send filter-check-box get-value)
(regexp (send filter-text-field get-value)))
searcher)))
;; do-search : search-info text -> void
;; thread: searching thread
;; called in a new thread that may be broken (to indicate a stop)
(define (do-search search-info channel)
(let* ([dir (search-info-dir search-info)]
[filter (search-info-filter search-info)]
[searcher (search-info-searcher search-info)]
[get-filenames (if (search-info-recur? search-info)
(build-recursive-file-list dir filter)
(build-flat-file-list dir filter))])
(with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))])
(let loop ()
(let ([filename (get-filenames)])
(when filename
(searcher filename
(λ (line-string line-number col-number match-length)
(async-channel-put
channel
(make-search-entry
filename
line-string
line-number
col-number
match-length))))
(loop))))
(async-channel-put channel 'done))))
;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f))
;; thread: search thread
(define (build-recursive-file-list dir filter)
(letrec ([touched (make-hash)]
[next-thunk (λ () (process-dir dir (λ () #f)))]
[process-dir
; string[dirname] (listof string[filename]) -> (listof string[filename])
(λ (dir k)
(let* ([key (normalize-path dir)]
[traversed? (hash-ref touched key (λ () #f))])
(if traversed?
(k)
(begin
(hash-set! touched key #t)
(process-dir-contents
(map (λ (x) (build-path dir x))
(directory-list dir))
k)))))]
[process-dir-contents
; string[dirname] (listof string[filename]) -> (listof string[filename])
(λ (contents k)
(cond
[(null? contents)
(k)]
[else
(let ([file/dir (car contents)])
(cond
[(and (file-exists? file/dir)
(or (not filter)
(regexp-match filter (path->string file/dir))))
(set! next-thunk
(λ ()
(process-dir-contents (cdr contents) k)))
file/dir]
[(directory-exists? file/dir)
(process-dir-contents
(cdr contents)
(λ ()
(process-dir file/dir k)))]
[else
(process-dir-contents (cdr contents) k)]))]))])
(λ () (next-thunk))))
;; build-flat-file-list : path (union #f regexp) -> (-> (union string #f))
;; thread: searching thread
(define (build-flat-file-list dir filter)
(let ([contents (map (λ (x) (build-path dir x)) (directory-list dir))])
(λ ()
(let loop ()
(cond
[(null? contents)
#f]
[(and filter (regexp-match filter (path->string (car contents))))
(begin0
(car contents)
(set! contents (cdr contents)))]
[else
(set! contents (cdr contents))
(loop)])))))
;; exact-match-searcher : make-searcher
(define (exact-match-searcher params key) ;; thread: main eventspace thread
(let ([case-sensitive? (car params)])
(λ (filename add-entry) ;; thread: searching thread
(let ([text (make-object text:basic%)])
(send text load-file filename)
(let loop ([pos 0])
(let ([found (send text find-string key 'forward pos 'eof #t case-sensitive?)])
(when found
(let* ([para (send text position-paragraph found)]
[para-start (send text paragraph-start-position para)]
[line-string (send text get-text para-start
(send text paragraph-end-position para))]
[line-number para]
[col-number (- found para-start)]
[match-length (string-length key)])
(add-entry line-string line-number col-number match-length)
(loop (+ found 1))))))))))
;; regexp-match-searcher : make-searcher
;; thread: searching thread
(define (regexp-match-searcher parmas key) ;; thread: main eventspace thread
(let ([re:key (with-handlers ([(λ (x) #t)
(λ (exn)
(format "~a" (exn-message exn)))])
(regexp key))])
(if (string? re:key)
re:key
(λ (filename add-entry) ;; thread: searching thread
(call-with-input-file filename
(λ (port)
(let loop ([line-number 0])
(let ([line (read-line port)])
(cond
[(eof-object? line) (void)]
[else
(let ([match (regexp-match-positions re:key line)])
(when match
(let ([pos (car match)])
(add-entry line line-number
(car pos)
(- (cdr pos) (car pos))))))
(loop (+ line-number 1))]))))
#:mode 'text)))))

9
collects/drscheme/private/number-snip.ss
View File

@ -1,9 +0,0 @@
(module number-snip mzscheme
(require mred
mzlib/class
framework)
(provide snip-class)
(define snip-class (make-object number-snip:snip-class%))
(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class))

19
collects/drscheme/private/recon.ss
View File

@ -1,19 +0,0 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide reconstitute)
(begin-for-syntax
(define-struct sloc (inside loc) #:omit-define-syntaxes #:prefab))
(define-syntax (reconstitute orig-stx)
(syntax-case orig-stx ()
[(_ arg src)
(let loop ([stx #'arg])
(cond
[(syntax? stx) (datum->syntax stx (loop (syntax-e stx)))]
[(pair? stx) (cons (loop (car stx)) (loop (cdr stx)))]
[(sloc? stx)
(datum->syntax #'src
(loop (syntax-e (sloc-inside stx)))
(syntax->datum (sloc-loc stx)))]
[else stx]))]))

1840
collects/drscheme/private/rep.ss
View File

File diff suppressed because it is too large Load Diff

341
collects/drscheme/private/stick-figures.ss
View File

@ -1,341 +0,0 @@
(module stick-figures mzscheme
(require mzlib/class
mzlib/pretty
mred)
(define head-size 40)
(define small-bitmap-factor 1/2)
(define small-factor 1/5)
(define line-size 2)
(define waiting-points
'((head 47 2)
(neck 46 15)
(shoulders 38 42)
(left-shoulder 18 39)
(right-shoulder 65 42)
(left-elbow 8 74)
(right-elbow 68 76)
(left-hand 24 79)
(right-hand 56 83)
(waist 37 87)
(left-knee 23 117)
(right-knee 57 117)
(left-ankle 21 149)
(right-ankle 59 148)
(left-toe 3 148)
(right-toe 79 145)))
(define waiting-points/2
'((head 47 2)
(neck 46 15)
(shoulders 38 42)
(left-shoulder 18 39)
(right-shoulder 65 42)
(left-elbow 8 74)
(right-elbow 68 76)
(left-hand 24 79)
(right-hand 56 83)
(waist 37 87)
(left-knee 23 117)
(right-knee 57 117)
(left-ankle 21 149)
(right-ankle 59 148)
(left-toe 3 148)
(right-toe 79 132)))
(define waiting-points/old
'((head 55 0)
(neck 43 18)
(shoulders 37 33)
(left-shoulder 23 34)
(right-shoulder 50 37)
(left-elbow 8 74)
(right-elbow 66 69)
(left-hand 60 78)
(right-hand 68 18)
(waist 37 87)
(left-knee 19 122)
(right-knee 57 117)
(left-ankle 19 154)
(right-ankle 62 155)
(left-toe 0 154)
(right-toe 83 146)))
(define waiting-points/2/old
'((head 55 0)
(neck 43 18)
(shoulders 37 33)
(left-shoulder 23 34)
(right-shoulder 50 37)
(left-elbow 8 74)
(right-elbow 66 69)
(left-hand 60 78)
(right-hand 68 18)
(waist 37 87)
(left-knee 19 122)
(right-knee 57 117)
(left-ankle 19 154)
(left-toe 0 154)
(right-ankle 62 155)
(right-toe 83 154)))
(define running-points
'((head 130 18)
(neck 114 33)
(shoulders 105 44)
(left-shoulder 105 44)
(right-shoulder 105 44)
(left-elbow 71 28)
(right-elbow 115 67)
(left-hand 50 54)
(right-hand 148 53)
(waist 59 78)
(left-knee 41 112)
(right-knee 97 93)
(left-ankle 0 129)
(right-ankle 89 132)
(left-toe 14 146)
(right-toe 109 132)))
(define (get-size-parameters)
(let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)]
[(max-rx max-ry) (get-max/min-x/y max running-points)]
[(min-wx min-wy) (get-max/min-x/y min waiting-points)]
[(max-wx max-wy) (get-max/min-x/y max waiting-points)])
(let* ([running-w (* small-factor (- max-rx min-rx))]
[waiting-w (* small-factor (- max-wx min-wx))]
[running-h (* small-factor (- max-ry min-ry))]
[waiting-h (* small-factor (- max-wy min-wy))]
[w (+ 2 (ceiling (max running-w waiting-w)))]
[h (+ 2 (ceiling (max running-h waiting-h)))]
[running-dx (+ 1 (- (/ w 2) (/ running-w 2)))]
[running-dy (+ 1 (- (/ h 2) (/ running-h 2)))]
[waiting-dx (+ 1 (- (/ w 2) (/ waiting-w 2)))]
[waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))])
(values w h running-dx running-dy waiting-dx waiting-dy))))
(define (get-bitmap points green)
(let-values ([(min-rx min-ry) (get-max/min-x/y min points)]
[(max-rx max-ry) (get-max/min-x/y max points)])
(let* ([margin 2]
[bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))]
[bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))]
[w (ceiling (* bw small-bitmap-factor))]
[h (ceiling (* bh small-bitmap-factor))]
[bm-big (make-object bitmap% bw bh)]
[bm-solid (make-object bitmap% w h)]
[bm-small (make-object bitmap% w h)]
[bdc-big (make-object bitmap-dc% bm-big)]
[bdc-solid (make-object bitmap-dc% bm-solid)]
[bdc-small (make-object bitmap-dc% bm-small)])
(send bdc-big clear)
(draw-callback bdc-big small-factor #f points
(+ margin (- (* small-factor min-rx)))
(+ margin #;(- (* small-factor min-ry)))
3)
(send bdc-small clear)
(send bdc-small set-scale small-bitmap-factor small-bitmap-factor)
(send bdc-small draw-bitmap bm-big 0 0)
(send bdc-small set-scale 1 1)
(send bdc-solid set-brush green 'solid)
(send bdc-solid set-pen green 1 'solid)
(send bdc-solid draw-rectangle 0 0 w h)
(send bdc-solid set-bitmap #f)
(send bdc-small set-bitmap #f)
(send bdc-big set-bitmap #f)
(send bm-solid set-loaded-mask bm-small)
bm-solid)))
(define (get-running-bitmap) (get-bitmap running-points (make-object color% 30 100 30)))
(define (get-waiting-bitmap) (get-bitmap waiting-points (make-object color% 30 100 30)))
(define (normalize points)
(let-values ([(min-x min-y) (get-max/min-x/y min points)])
(map (λ (x) (list (car x)
(+ (- (list-ref x 1) min-x))
(+ (- (list-ref x 2) min-y))))
points)))
(define (get-max/min-x/y choose points)
(values (apply choose
(- (list-ref (assoc 'head points) 1) (/ head-size 2))
(+ (list-ref (assoc 'head points) 1) (/ head-size 2))
(map (λ (x) (list-ref x 1)) points))
(apply choose
(- (list-ref (assoc 'head points) 2) (/ head-size 2))
(+ (list-ref (assoc 'head points) 2) (/ head-size 2))
(map (λ (x) (list-ref x 2)) points))))
(define show-dots? #t)
(define (draw-callback dc factor dots? points dx dy line-size)
(send dc set-smoothing 'aligned)
(let ([points (normalize points)])
(send dc set-pen "orange" 1 'solid)
(send dc set-brush "orange" 'solid)
(when (and dots? show-dots?)
(for-each
(λ (x) (send dc draw-ellipse
(+ dx (- (list-ref x 1) 4))
(+ dy (- (list-ref x 2) 4))
9 9))
points))
(send dc set-pen "black" line-size 'solid)
(send dc set-brush "black" 'transparent)
(draw-points points dc factor dx dy)
(let* ([head (assoc 'head points)]
[hx (list-ref head 1)]
[hy (list-ref head 2)])
(send dc draw-ellipse
(+ dx (* factor (- hx (/ head-size 2))))
(+ dy (* factor (- hy (/ head-size 2))))
(* factor head-size)
(* factor head-size)))))
(define (draw-points points dc factor dx dy)
(connect 'neck 'shoulders points dc factor dx dy)
(connect 'shoulders 'left-shoulder points dc factor dx dy)
(connect 'left-shoulder 'left-elbow points dc factor dx dy)
(connect 'shoulders 'right-shoulder points dc factor dx dy)
(connect 'right-shoulder 'right-elbow points dc factor dx dy)
(connect 'left-elbow 'left-hand points dc factor dx dy)
(connect 'right-elbow 'right-hand points dc factor dx dy)
(connect 'shoulders 'waist points dc factor dx dy)
(connect 'waist 'left-knee points dc factor dx dy)
(connect 'waist 'right-knee points dc factor dx dy)
(connect 'left-knee 'left-ankle points dc factor dx dy)
(connect 'right-knee 'right-ankle points dc factor dx dy)
(connect 'left-ankle 'left-toe points dc factor dx dy)
(connect 'right-ankle 'right-toe points dc factor dx dy))
(define (connect from to points dc factor dx dy)
(let ([from-p (assoc from points)]
[to-p (assoc to points)])
(when (and from-p to-p)
(send dc draw-line
(+ dx (* factor (list-ref from-p 1)))
(+ dy (* factor (list-ref from-p 2)))
(+ dx (* factor (list-ref to-p 1)))
(+ dy (* factor (list-ref to-p 2)))))))
;; Use this thunk to edit the points.
;; Click the 'show' button to print out the points and then
;; copy and paste them back into this file.
(define (edit-points points)
(define c%
(class canvas%
(inherit get-client-size refresh get-dc)
(define clicked-point #f)
(define clicked-x 0)
(define clicked-y 0)
(define orig-x 0)
(define orig-y 0)
(define/override (on-paint)
(draw-callback (get-dc) 1 #t points 0 0 line-size))
(define/override (on-event evt)
(cond
[(send evt button-down? 'left)
(let-values ([(w h) (get-client-size)])
(let ([x (send evt get-x)]
[y (send evt get-y)])
(let ([point (find-point this x y)])
(when point
(set! clicked-x x)
(set! clicked-y y)
(set! clicked-point point)
(let ([orig-point (assoc point points)])
(set! orig-x (list-ref orig-point 1))
(set! orig-y (list-ref orig-point 2)))))))]
[(and clicked-point (send evt moving?))
(set! points
(map (λ (x)
(if (eq? (car x) clicked-point)
(list (list-ref x 0)
(+ orig-x (- (send evt get-x) clicked-x))
(+ orig-y (- (send evt get-y) clicked-y)))
x))
points))
(refresh)
(send csmall refresh)]
[(send evt button-up? 'left)
(set! clicked-point #f)]))
(super-new)))
(define (find-point c x y)
(let loop ([points (normalize points)])
(cond
[(null? points) #f]
[else (let ([point (car points)])
(if (and (<= (- (list-ref point 1) 4)
x
(+ (list-ref point 1) 4))
(<= (- (list-ref point 2) 4)
y
(+ (list-ref point 2) 4)))
(car point)
(loop (cdr points))))])))
(define f (new frame% [label ""] [width 400] [height 400]))
(define cp (new horizontal-panel% [parent f]))
(define cbig (new c% [parent cp]))
(define csmall
(new canvas%
[parent cp]
[paint-callback (λ (c dc)
(draw-callback dc small-factor #f running-points 0 0 line-size)
(draw-callback dc small-factor #f waiting-points 30 0 line-size)
(draw-callback dc small-factor #f points 30 50 line-size)
(draw-callback dc small-factor #f points 0 50 line-size))]))
(define cbitmap (new message% [label (get-bitmap points (send the-color-database find-color "black"))] [parent cp]))
(define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
(new button%
[parent bp]
[label "Show"]
[callback
(λ (x y)
(pretty-print points))])
(new button%
[parent bp]
[label "Toggle dots"]
[callback
(λ (x y)
(set! show-dots? (not show-dots?))
(send cbig refresh))])
(new button%
[parent bp]
[label "Bitmap"]
[callback
(λ (x y)
(send cbitmap set-label (get-bitmap points (send the-color-database find-color "black"))))])
(send f show #t))
(let ()
(define f (new frame% [label ""]))
(define hp (new horizontal-panel% [parent f]))
(define left-column (new vertical-panel% [parent hp]))
(define right-column (new vertical-panel% [parent hp]))
(define green-rb (get-running-bitmap))
(define black (send the-color-database find-color "black"))
(define rb (get-bitmap running-points black))
(define wb (get-bitmap waiting-points black))
(define wb2 (get-bitmap waiting-points/2 black))
(define rm (new message% [label rb] [parent left-column]))
(define grm (new message% [label green-rb] [parent right-column]))
(new message% [label wb] [parent left-column])
(new message% [label wb2] [parent left-column])
(new message% [label wb2] [parent right-column])
(new message% [label wb] [parent right-column])
(new grow-box-spacer-pane% [parent f])
(send green-rb save-file (build-path (collection-path "icons") "run.png") 'png)
(send rb save-file (build-path (collection-path "icons") "b-run.png") 'png)
(send wb save-file (build-path (collection-path "icons") "b-wait.png") 'png)
(send wb2 save-file (build-path (collection-path "icons") "b-wait2.png") 'png)
(send f show #t))
#;(edit-points waiting-points/2)
#;(edit-points running-points))

164
collects/drscheme/private/syncheck-debug.ss
View File

@ -1,164 +0,0 @@
(module syncheck-debug mzscheme
(require mzlib/pretty
mzlib/list
mzlib/class
mred)
(provide debug-origin) ;; : syntax [syntax] -> void
;; creates a frame for examining the
;; origin and source fields of an expanded sexp
;; also the 'bound-in-source syntax property
(define debug-origin
(case-lambda
[(original-object) (debug-origin original-object (expand original-object))]
[(original-object expanded-object)
(define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
(define output-text (make-object text%))
(define output-port (make-text-port output-text))
(define info-text (make-object text%))
(define info-port (make-text-port info-text))
;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
;; this is guaranteed by syntax-object->datum/ht
(define range-start-ht (make-hash-table))
(define range-ht (make-hash-table))
(define original-output-port (current-output-port))
(define (range-pretty-print-pre-hook x v)
(hash-table-put! range-start-ht x (send output-text last-position)))
(define (range-pretty-print-post-hook x v)
(hash-table-put! range-ht x
(cons
(cons
(hash-table-get range-start-ht x)
(send output-text last-position))
(hash-table-get range-ht x (λ () null)))))
(define (make-modern text)
(send text change-style
(make-object style-delta% 'change-family 'modern)
0
(send text last-position)))
(define dummy
(begin (pretty-print (syntax-object->datum original-object) output-port)
(newline output-port)
(parameterize ([current-output-port output-port]
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
[pretty-print-post-print-hook range-pretty-print-post-hook]
[pretty-print-columns 30])
(pretty-print expanded-datum))
(make-modern output-text)))
(define ranges
(sort
(apply append (hash-table-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
(λ (x y)
(<= (- (car (cdr x)) (cdr (cdr x)))
(- (car (cdr y)) (cdr (cdr y)))))))
(define (show-info stx)
(fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
(syntax-object->datum stx)
(syntax-source stx)
(syntax-position stx)
(syntax-span stx)
(syntax-original? stx)
(syntax-property stx 'bound-in-source))
(let loop ([origin (syntax-property stx 'origin)])
(cond
[(pair? origin)
(loop (car origin))
(loop (cdr origin))]
[(syntax? origin)
(display " " info-port)
(display origin info-port)
(newline info-port)
(fprintf info-port
" original? ~a\n datum:\n ~a\n\n"
(and (syntax? origin) (syntax-original? origin))
(and (syntax? origin) (syntax-object->datum origin)))]
[else (void)])))
(for-each
(λ (range)
(let* ([obj (car range)]
[stx (hash-table-get stx-ht obj)]
[start (cadr range)]
[end (cddr range)])
(when (syntax? stx)
(send output-text set-clickback start end
(λ _
(send info-text begin-edit-sequence)
(send info-text erase)
(show-info stx)
(make-modern info-text)
(send info-text end-edit-sequence))))))
ranges)
(newline output-port)
(newline output-port)
(let ([before (send output-text last-position)])
(display "all" output-port)
(send output-text set-clickback
before
(send output-text last-position)
(λ _
(send info-text begin-edit-sequence)
(send info-text erase)
(for-each (λ (rng)
(let ([stx (hash-table-get stx-ht (car rng))])
(when (syntax? stx)
(show-info stx))))
ranges)
(make-modern info-text)
(send info-text end-edit-sequence))))
(let ()
(define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
(define p (make-object horizontal-panel% f))
(make-object editor-canvas% p output-text)
(make-object editor-canvas% p info-text)
(send f show #t))]))
;; build-ht : stx -> hash-table
;; the resulting hash-table maps from the each sub-object's to it's syntax.
(define (syntax-object->datum/ht stx)
(let ([ht (make-hash-table)])
(values (let loop ([stx stx])
(let ([obj (syntax-e stx)])
(cond
[(list? obj)
(let ([res (map loop obj)])
(hash-table-put! ht res stx)
res)]
[(pair? obj)
(let ([res (cons (loop (car obj))
(loop (cdr obj)))])
(hash-table-put! ht res stx)
res)]
[(vector? obj)
(let ([res (list->vector (map loop (vector->list obj)))])
(hash-table-put! ht res stx)
res)]
[else
(let ([res (syntax-object->datum stx)])
(hash-table-put! ht res stx)
res)])))
ht)))
;; make-text-port : text -> port
;; builds a port from a text object.
(define (make-text-port text)
(let-values ([(in out) (make-pipe)])
(thread
(λ ()
(let loop ()
(let ([c (read-char in)])
(unless (eof-object? c)
(send text insert (string c)
(send text last-position)
(send text last-position))
(loop))))))
out)))

34
collects/drscheme/private/text.ss
View File

@ -1,34 +0,0 @@
#lang scheme/unit
(require mzlib/class
"drsig.ss"
framework)
(import)
(export drscheme:text^)
(define text<%>
(interface (scheme:text<%>)
printing-on
printing-off
is-printing?))
(define text%
(class* scheme:text% (text<%>)
(define printing? #f)
(define/public (is-printing?) printing?)
(define/public (printing-on) (set! printing? #t))
(define/public (printing-off) (set! printing? #f))
; (rename [super-on-paint on-paint])
; (inherit get-filename)
; (override
; [on-paint
; (λ (before? dc left top right bottom dx dy draw-caret)
; (super-on-paint before? dc left top right bottom dx dy draw-caret)
; (let ([str (string-append
; (mzlib:date:date->string (seconds->date (current-seconds)))
; " "
; (if (string? (get-filename))
; (get-filename)
; "Untitled"))])
; (send dc draw-text str dx dy)))])
(super-new)))

86
collects/drscheme/private/time-keystrokes.ss
View File

@ -1,86 +0,0 @@
(module time-keystrokes mzscheme
(require (lib "tool.ss" "drscheme")
mzlib/list
mzlib/unit
mzlib/class
mzlib/etc
mred
framework)
(provide tool@)
(define short-str "(abc)")
(define chars-to-test (build-string
400
(λ (i) (string-ref short-str (modulo i (string-length short-str))))))
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))
(define (tool-mixin super%)
(class super%
(inherit get-button-panel)
(super-new)
(let ([button (new button%
(label "Time Keystrokes")
(parent (get-button-panel))
(callback
(lambda (button evt)
(time-keystrokes this))))])
(send (get-button-panel) change-children
(lambda (l)
(cons button (remq button l)))))))
(define (time-keystrokes frame)
(let loop ([n 10])
(when (zero? n)
(error 'time-keystrokes "could not find drscheme frame"))
(let ([front-frame (get-top-level-focus-window)])
(unless (eq? front-frame frame)
(sleep 1/10)
(loop (- n 1)))))
(let ([win (send frame get-definitions-canvas)])
(send win focus)
(time (send-key-events win chars-to-test))))
(define (send-key-events window chars)
(for-each (λ (char)
(send-key-event window (new key-event% (key-code char))))
(string->list chars)))
;; copied from framework/test.ss
(define (send-key-event window event)
(let loop ([l (ancestor-list window #t)])
(cond [(null? l)
(cond
[(method-in-interface? 'on-char (object-interface window))
(send window on-char event)]
[(is-a? window text-field%)
(send (send window get-editor) on-char event)]
[else
(error
'send-key-event
"focused window is not a text-field% and does not have on-char: ~s" window)])]
[(send (car l) on-subwindow-char window event) #f]
[else (loop (cdr l))])))
;; copied from framework/test.ss
(define (ancestor-list window stop-at-top-level-window?)
(let loop ([w window] [l null])
(if (or (not w)
(and stop-at-top-level-window?
(is-a? w top-level-window<%>)))
l
(loop (send w get-parent) (cons w l)))))
(when (getenv "PLTDRKEYS")
(printf "PLTDRKEYS: installing unit frame mixin\n")
(drscheme:get/extend:extend-unit-frame tool-mixin)))))

135
collects/drscheme/private/tool-contract-language.ss
View File

@ -1,135 +0,0 @@
(module tool-contract-language mzscheme
(provide (rename -#%module-begin #%module-begin)
(all-from-except mzscheme #%module-begin))
(require mzlib/contract)
(require-for-syntax mzlib/list)
(define-syntax (-#%module-begin stx)
(define-struct ctc-binding (var arg))
(define-struct def-binding (var arg))
(define (process-case case-stx)
(syntax-case case-stx (define)
[(define name expr)
(identifier? (syntax name))
(make-def-binding (syntax name) (syntax expr))]
[(name type type-names strs ...)
(and (identifier? (syntax name))
(not (string? (syntax-object->datum (syntax type))))
(andmap (λ (x) (string? (syntax-object->datum x))) (syntax->list (syntax (strs ...)))))
(make-ctc-binding (syntax name) (syntax type))]
[else (raise-syntax-error 'tool-contract-language.ss "unknown case" stx case-stx)]))
(syntax-case stx ()
[(_ cases ...)
(let* ([pcases (map process-case (syntax->list (syntax (cases ...))))]
[def-cases (filter def-binding? pcases)]
[ctc-cases (filter ctc-binding? pcases)])
(with-syntax ([(ctc-name ...) (map ctc-binding-var ctc-cases)]
[(ctc ...) (map ctc-binding-arg ctc-cases)]
[(def-name ...) (map def-binding-var def-cases)]
[(def-exp ...) (map def-binding-arg def-cases)]
[wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
(syntax/loc stx
(#%module-begin
(provide wrap-tool-inputs)
(define-syntax wrap-tool-inputs
(λ (in-stx)
(syntax-case in-stx ()
[(_ body tool-name)
(let ([f (λ (in-obj)
(datum->syntax-object
in-stx
(syntax-object->datum in-obj)
in-obj))])
(with-syntax ([(in-type (... ...)) (map f (syntax->list (syntax (ctc ...))))]
[(in-name (... ...)) (map f (syntax->list (syntax (ctc-name ...))))]
[(in-def-name (... ...)) (map f (syntax->list (syntax (def-name ...))))]
[(in-def-exp (... ...)) (map f (syntax->list (syntax (def-exp ...))))])
(syntax/loc in-stx
(let ([in-def-name in-def-exp] (... ...))
(let ([in-name (contract (let ([in-name in-type]) in-name)
in-name
'drscheme
tool-name
(quote-syntax in-name))] (... ...))
body)))))])))))))]
[(_ (name type type-names strs ...) ...)
(begin
(for-each
(λ (str-stx)
(when (string? (syntax-object->datum str-stx))
(raise-syntax-error 'tool-contract-language.ss "expected type name specification"
stx
str-stx)))
(syntax->list (syntax (type-names ...))))
(for-each
(λ (name)
(unless (identifier? name)
(raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
(syntax->list (syntax (name ...))))
(for-each
(λ (str)
(unless (string? (syntax-object->datum str))
(raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))
(define-syntax (-#%module-begin2 stx)
(syntax-case stx ()
[(_ (name type type-names strs ...) ...)
(and (andmap identifier? (syntax->list (syntax (name ...))))
(andmap (λ (x) (not (string? (syntax-object->datum x))))
(syntax->list (syntax (type-names ...))))
(andmap (λ (x) (string? (syntax-object->datum x)))
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))
(with-syntax ([wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
(syntax/loc stx
(#%module-begin
(provide wrap-tool-inputs)
(define-syntax wrap-tool-inputs
(λ (in-stx)
(syntax-case in-stx ()
[(_ body tool-name)
(with-syntax ([(in-type (... ...))
(map (λ (in-type-obj)
(datum->syntax-object
in-stx
(syntax-object->datum in-type-obj)
in-type-obj))
(syntax->list (syntax (type ...))))]
[(in-name (... ...))
(map (λ (in-name-obj)
(datum->syntax-object
in-stx
(syntax-object->datum in-name-obj)
in-name-obj))
(syntax->list (syntax (name ...))))])
(syntax/loc in-stx
(let ([in-name (contract (let ([in-name in-type]) in-name)
in-name
'drscheme
tool-name
(quote-syntax in-name))] (... ...))
body)))]))))))]
[(_ (name type type-names strs ...) ...)
(begin
(for-each
(λ (str-stx)
(when (string? (syntax-object->datum str-stx))
(raise-syntax-error 'tool-contract-language.ss "expected type name specification"
stx
str-stx)))
(syntax->list (syntax (type-names ...))))
(for-each
(λ (name)
(unless (identifier? name)
(raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
(syntax->list (syntax (name ...))))
(for-each
(λ (str)
(unless (string? (syntax-object->datum str))
(raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))])))

582
collects/drscheme/private/tools.ss
View File

@ -1,582 +0,0 @@
#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)))

12
collects/drscheme/private/ts.ss
View File

@ -1,12 +0,0 @@
#reader scribble/reader
#lang scheme/base
(require scribble/decode
scribble/manual)
(define (phase n)
(make-splice
@list{This function can only be called in
phase @(number->string n) (see @secref["implementing-tools"] for details).}))
(provide phase)

3821
collects/drscheme/private/unit.ss
View File

File diff suppressed because it is too large Load Diff

2738
collects/drscheme/syncheck.ss
View File

File diff suppressed because it is too large Load Diff

1383
collects/drscheme/tool-lib.ss
View File

File diff suppressed because it is too large Load Diff

4
collects/drscheme/tool.ss
View File

@ -1,4 +0,0 @@
(module tool mzscheme
(require "private/drsig.ss")
(provide drscheme:tool^
drscheme:tool-exports^))