From b93d242aa57c100171db4248776899d75250a5e6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 18 Jun 2008 04:53:31 +0000 Subject: [PATCH] restore unmodified version svn: r10336 --- collects/drscheme/acks.ss | 82 + collects/drscheme/arrow.ss | 195 + collects/drscheme/default-code-style.ss | 27 + collects/drscheme/doc.icns | Bin 0 -> 33657 bytes collects/drscheme/drscheme.creator | 2 + collects/drscheme/drscheme.filetypes | 20 + collects/drscheme/drscheme.ss | 47 + collects/drscheme/drscheme.utiexports | 15 + collects/drscheme/info.ss | 6 + collects/drscheme/installer.ss | 21 + collects/drscheme/main.ss | 2 + collects/drscheme/pltdoc.icns | Bin 0 -> 43952 bytes collects/drscheme/private/app.ss | 420 ++ collects/drscheme/private/auto-language.ss | 62 + collects/drscheme/private/bindings-browser.ss | 305 ++ collects/drscheme/private/debug.ss | 2005 +++++++++ collects/drscheme/private/drscheme-normal.ss | 280 ++ collects/drscheme/private/drsig.ss | 316 ++ collects/drscheme/private/eval.ss | 221 + collects/drscheme/private/font.ss | 218 + collects/drscheme/private/frame.ss | 595 +++ collects/drscheme/private/get-extend.ss | 84 + collects/drscheme/private/help-desk.ss | 77 + collects/drscheme/private/init.ss | 51 + .../drscheme/private/insert-large-letters.ss | 172 + collects/drscheme/private/key.ss | 19 + collects/drscheme/private/label-frame-mred.ss | 28 + .../private/language-configuration.ss | 1784 ++++++++ .../private/language-object-contract.ss | 94 + collects/drscheme/private/language.ss | 1171 +++++ .../drscheme/private/launcher-bootstrap.ss | 50 + .../private/launcher-mred-bootstrap.ss | 9 + .../drscheme/private/launcher-mz-bootstrap.ss | 8 + collects/drscheme/private/link.ss | 55 + collects/drscheme/private/main.ss | 508 +++ collects/drscheme/private/modes.ss | 46 + collects/drscheme/private/module-browser.ss | 1002 +++++ collects/drscheme/private/module-language.ss | 602 +++ .../drscheme/private/multi-file-search.ss | 716 +++ collects/drscheme/private/number-snip.ss | 9 + collects/drscheme/private/recon.ss | 19 + collects/drscheme/private/rep.ss | 1835 ++++++++ collects/drscheme/private/stick-figures.ss | 341 ++ collects/drscheme/private/syncheck-debug.ss | 164 + collects/drscheme/private/text.ss | 34 + collects/drscheme/private/time-keystrokes.ss | 86 + .../private/tool-contract-language.ss | 135 + collects/drscheme/private/tools.ss | 582 +++ collects/drscheme/private/ts.ss | 12 + collects/drscheme/private/unit.ss | 3821 +++++++++++++++++ collects/drscheme/syncheck.ss | 2738 ++++++++++++ collects/drscheme/tool-lib.ss | 1383 ++++++ collects/drscheme/tool.ss | 4 + 53 files changed, 22478 insertions(+) create mode 100644 collects/drscheme/acks.ss create mode 100644 collects/drscheme/arrow.ss create mode 100644 collects/drscheme/default-code-style.ss create mode 100644 collects/drscheme/doc.icns create mode 100644 collects/drscheme/drscheme.creator create mode 100644 collects/drscheme/drscheme.filetypes create mode 100644 collects/drscheme/drscheme.ss create mode 100644 collects/drscheme/drscheme.utiexports create mode 100644 collects/drscheme/info.ss create mode 100644 collects/drscheme/installer.ss create mode 100644 collects/drscheme/main.ss create mode 100644 collects/drscheme/pltdoc.icns create mode 100644 collects/drscheme/private/app.ss create mode 100644 collects/drscheme/private/auto-language.ss create mode 100644 collects/drscheme/private/bindings-browser.ss create mode 100644 collects/drscheme/private/debug.ss create mode 100644 collects/drscheme/private/drscheme-normal.ss create mode 100644 collects/drscheme/private/drsig.ss create mode 100644 collects/drscheme/private/eval.ss create mode 100644 collects/drscheme/private/font.ss create mode 100644 collects/drscheme/private/frame.ss create mode 100644 collects/drscheme/private/get-extend.ss create mode 100644 collects/drscheme/private/help-desk.ss create mode 100644 collects/drscheme/private/init.ss create mode 100644 collects/drscheme/private/insert-large-letters.ss create mode 100644 collects/drscheme/private/key.ss create mode 100644 collects/drscheme/private/label-frame-mred.ss create mode 100644 collects/drscheme/private/language-configuration.ss create mode 100644 collects/drscheme/private/language-object-contract.ss create mode 100644 collects/drscheme/private/language.ss create mode 100644 collects/drscheme/private/launcher-bootstrap.ss create mode 100644 collects/drscheme/private/launcher-mred-bootstrap.ss create mode 100644 collects/drscheme/private/launcher-mz-bootstrap.ss create mode 100644 collects/drscheme/private/link.ss create mode 100644 collects/drscheme/private/main.ss create mode 100644 collects/drscheme/private/modes.ss create mode 100644 collects/drscheme/private/module-browser.ss create mode 100644 collects/drscheme/private/module-language.ss create mode 100644 collects/drscheme/private/multi-file-search.ss create mode 100644 collects/drscheme/private/number-snip.ss create mode 100644 collects/drscheme/private/recon.ss create mode 100644 collects/drscheme/private/rep.ss create mode 100644 collects/drscheme/private/stick-figures.ss create mode 100644 collects/drscheme/private/syncheck-debug.ss create mode 100644 collects/drscheme/private/text.ss create mode 100644 collects/drscheme/private/time-keystrokes.ss create mode 100644 collects/drscheme/private/tool-contract-language.ss create mode 100644 collects/drscheme/private/tools.ss create mode 100644 collects/drscheme/private/ts.ss create mode 100644 collects/drscheme/private/unit.ss create mode 100644 collects/drscheme/syncheck.ss create mode 100644 collects/drscheme/tool-lib.ss create mode 100644 collects/drscheme/tool.ss diff --git a/collects/drscheme/acks.ss b/collects/drscheme/acks.ss new file mode 100644 index 0000000000..fecf97b005 --- /dev/null +++ b/collects/drscheme/acks.ss @@ -0,0 +1,82 @@ +(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."))) diff --git a/collects/drscheme/arrow.ss b/collects/drscheme/arrow.ss new file mode 100644 index 0000000000..64501ef4ee --- /dev/null +++ b/collects/drscheme/arrow.ss @@ -0,0 +1,195 @@ + +(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)))) diff --git a/collects/drscheme/default-code-style.ss b/collects/drscheme/default-code-style.ss new file mode 100644 index 0000000000..b4ea007e2d --- /dev/null +++ b/collects/drscheme/default-code-style.ss @@ -0,0 +1,27 @@ +(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))))) diff --git a/collects/drscheme/doc.icns b/collects/drscheme/doc.icns new file mode 100644 index 0000000000000000000000000000000000000000..7d726a4974689937338844363a02b48fe0e14b0d GIT binary patch literal 33657 zcmeI52V7NGp2u%{{XHk%u_YNw(mq(Si|8pM*BJa`HEj&x&$^HHR|8wp+_n!B? zziW1Uwr3wfC=Tt|zx4+M@wYn&_!zh!_5@j5r>bRYYT<{xnqO5_Sy@qDj>?`bEh#Q8 zDk>~2D9F#t&B@M4OG%24y&e@28XTEcRG5<+6i3+BQMGk-s20@_)u@W9tf*kipDiop zlpxH8VL^F;^pWLH-wG)3G{+P=dNnZq%|hsG7#TMddtW&8X-} z+}oVnnYU6CW3OKh4GQp!j7u+onxhGaSyb7#Gj82Xh`Aabe8JBzHa0yERM!bdP!YBA zhfcTNhG9*LyB-m8!OuJRmQi$#(B5I|i8{8Hn2@pM&)^D6@cAex$jiB%o{|)E zCG?{2X|Lpr*z~f(te~re({vSrb1^B)&&$qCOOC%57If~EM^M4I>m$a=d$6xt%oUdJ3aYERPeb|?v5p( zy1}U~6Rr8YxF9<{;aaedyGAul8Azxai3U|8)zHwWnW{#$ zmN4%iZ)s6(X7V+iuZKoGsfG2I8x%lzG^!ugYynACMOkrPM)GytIZu0ZV9y>oLad!% zXnfusyp%ZQ1;Vw7YHVz>X=EG7d-o7G8(yk|sg8SEoR@VoCfwgktNd=??j2uz{`vMl z?D%T$e%Ii1kmGC2dE)q^QmD0}G(S5PPUdM>TkC`S_UzudbJy-YU++6`*jjNmE;a>A z{RyJ^WRqfQ-nDhG!m29EigMBut_1sfYSq?p@#xSzZGDjSdSq?e1u!V2>R^M=h+akz8q`ad39=zLs59=TE4bi6*w$ z9pr2S0X-g9S65Y(6x>dUi@M~0+QY@sPNT7vYb16KT4xt`Pfx#uykdXCuEnF7Y-(cR zM6ve>m>8CIwbhlSg}Ja$B7)AJJ>|)IpyS9xeEfu`=c!ZP-XY1i{RyWQSFA#fFd@;s zHFu%fx|*u;qP*Lw@z*0mF2W_7^+kSCUtb>|{L|O(TwInv;nL#N`~#iyH~;eUw|=(m zKaaWGynDC4zP7rmtSC1tHSxx^$ndZbU5GAJ7aAHId?_gKVn9IPg$vgc{R!0S(qh~E zXJtON)+(11N8aKQ6iqYh|NK+0I}o4(>di{KnGhQjEx&FV9ew@Um8i&wuuvUD(Ivys zwxSlYwbi~w*~}~Sxs+7d$Trhe-kV6oUq_RqXv>~--032?q~A)tnVgiI#3sv<5)$HK zV<1vQcxZSu400RQ+ScaKDsN#5D%$!6(U81_y10f${53otL(xy|D1sQpg#|gcvobR? z*i4IzjP$hBn~4c=G0|5qM@IP*_HFj9yq2oFy~AS)gS>_Onqv7Z&yr@o=T-v~tk}3Y z$W!D>va>R8r6j`!A^OS{f5NfNwv}$H>K#>siq3tG7H~RJ@|&_6Sc2tvhrrzgrG;=k z&CW_syO|glea)XB+uOBm%2w*$-4P9z9wG#sR7g`lxP_NfC8{7`b7FyShQ)<>xp1q7 zZApwj!FFid**5A<)0mw>-pZt};Te@y4Ea)09iG+I)o`!pZZ{w;$cL<{NeTXhvV(4K z@93~=CmUNFK}x^R<&^U_G34`UFi-HT#+k>Zcz=+d3Ma{~!?vAh(t?EaXAoEBCWaxm zmKil%wU7@kbH&if+Zk#8ghPj_ov3j#C|c>)DO{hNw~=A!f4+N{TRmJNZuWJUG=EYC^8-&{sIb4^v5zXPx$k6v!BiShH(gWw31w6eK6}8C5v*Bq4GMEwl znm#JO63@OK6=?XCrGe{dK9`C|iH=6;%1{f9Rj7dnDv=rd z<){A($%l&vj3FgD9HongOPpk)b65yt(a-i#xrM!s1_T9)N4mRfigU8ORx==DVRBGH z>&v>!t*y|zNg?PQ^}PQ6;*91o2LsvH3(B#9_Pdn@uuc0%5|0TeC7OuP@bHw zr>7gP6n5J~PLN9P_qW}xD1_Tdbi^+SthJ!YP3OWxLkim`#0)2fNj5<1^#cPcJ$*Uj z&aj3{Z8_A{SW^P2Z$w4fucmnrz>=nZ5gZm8Qrgim5rM`LV7(0}^h|7gQQMe}0re{l zmc!jGb>#(FDe>3Bg9En_AQr*h<|C+FSKNs@7_Q@}nF2X1KZCU z){G7JwBD^M&bgHo6BQbC-uKKqB#js$O_Se0A0DcULS4j^AViZtK@AKJY6tk&!xHlD z^uf&q^&`Wdjg9KNTJCUhVy}c>3h?#zmaik>N=H+?9k?@b>_nh8Tn+AvVvrgb7_=D> zRQg6F<=1tMvIeAoq2F+SSl`{&P+MM@eJkn4)$mJ!=gyou;rT8}<7m&G4i60t>4BAl zmv{%!j@l@gR5+gPpn5vEzr?N#qJTijxPY>yPJ6jv-DogV4P5(-GaKJgA(HuZK9e64{m z47qSmONx)a5((dV&z(K(<>BgRt2lP>MS}P15D24->y`Jg-P~wVFdHFEA3NkU_)4AE z379Bi%uiTfzLN1>7JA2B@!^J@jQ4ai)`k4=m5*=38Ym9^E6xq&& zQ4G<8gF{1hgD(}jxt;V242ifB6Q7ur5O?GH)yv_!O9B4AXHI##Y3)?((SzUY`nMmR zhDc=CEqO1CE9&aP=MU=X)eLC{Ur2D#dYtm{zZe`E9(nn4WJG94P#`Ylgu9cyjl%ly zfvO~NNfwR`p0Reg(hHM7KNnRSQ`-#(M{mz|dFRb%F=L>^z+*NCD zt3*c+?%(spZ+3F|LlRJ*su!-LEZmkL0O-55L+U|MrjNqb!NvW!rx$y2t(WI>Zu7$Z3OC>u9f0 zD_QF!hYozbYx}Q1w-1I{s|!u(SM@15F?1gCcCo`wLyE!Ya>KpRVQW^QQrW0gDy1A9 zI|5txy}LgD@OQ_~hvSnNm4iTw6QgbdOFI?A^w7}ous!HSH$zV-4;(mj`0#h=@R~yh z_J8xoU4QuWqc4>{p;#LhQ>)+-(|D$1tp;TB!Og|+#oG=2>8qW)zuL3w%k97Wc>7nZ zdtf*$`w-oYTD=-Xie3stpy{w5b{s;38)}lnb%DNKPByGHt8qE$7ZM&8rV9y)OsJ4^ z0y!R8e7ttpVTc_R6edPN$HT%=m=M-&NN`9*Y`$7=)35B4Luc@TE?hB8ZBc$=G<%(i zj!!A6l@HkHRgj+Tg%NHaafL(d25q5H4L2wRjYK;;;x?=qvWGQ~Ta|qT*QywyhKEO- z;CKxjujY=&M{A(X4r1V=RsHfl+~zQ%g*FXbfp8n*+MLGQjK>*cx{f$PJX<(UrC0V7 z+;Q%3oGlkmt(W)X$wTg;S7g5fE)*9$JXq189 zNAJr=t=rqux9B=V>&>|l) zsyw+CTQ~;#%tbyq<^pkSM{I_vp&_otd(4?@Q4f>GhO^LM4~M{DaR>OqpY0%#lKV5+ zWjHtH1P!($itz(jgCEyo17pkey-R5z#|&r3v~ZZs2n&ryQakxOdcbZKwE_;@!oF8t z%~Vz5FG%IWQea2$9jB-W6+X$qTR@W>yoJkq$P{=B9f!;R4w^5?ec4~w<5nMOG zgHZPr;*4tN3~}9?Y^Q?M`2bwcCbF?fIbHqV!*IFW?BXyk)!6h9$OY0fJIHkaB#Rcz zaZ$rMOtFAB0LCrG7&jVY+;hu>asBMsMPl5tpy2C?C8jVgJS3eB`0dvwt*3fL`pG9$ma=mo#5*^&wmY1Bo-?rl$gI|A$(WU&Tk7?#TSVs3Mqmpf`ECU zUYmAa>>8|AOKFLO-aQla9fyw?s7{Bzyk`X>u~e#*u~L%%(<%7Z66nT5_!m_QjTm;ZkMG1n3LI{7_-Tf;@EWK!&JdYz}jy#Kcd%cCm0LW4fosd|_0=rYziY2_i znyDXV!^vTJ=+;E1HIBj?pygBjDS;@U!ti7HUh0 zY;9ss-qT{KL`;7=JFSK%mPT4F`j{_-6D;HA<~shqo}Ob+ibTw}N}U6`h9DSS3wA*e zm}D}%LP+tesOO3A3vmXg2|8x}}Hip5AI zqW&Q#dj{Oy0eFyO#gE`_z7W9OeCg%tk?JVzrdGsp`PM1PuO0X4-@}@!95hhsXB-Bq#chHu}~7?i>ZIT zU=D}#jPn7Yi=M;bX=`|V+&}7Xke)8z%82Ab7M_HzrJi#?bHZcJAp9siBjF49k^rQq zT;TztP%e=3*E0Ow-ZK#JadM40Kh(hiaOpN0>LC9$cJhse zoCl@3FVj5Q(ls$D>x2bg0cw^fqt_nQ&I-Kc0Ix_4yv5g^p^3LI>LRbcOR@qbU%`_y z^oJUZxp)8TUz)?*BA;hg9X{)K$^9u>4Kl=tiSHl#?!Y%Y{`psC*tX#O=W2WTzQ1AY z@dF~ta>v2Fzxm65Gzv`MY<{Ndwe@0(vE?c8BPHsM|9tCvpJ0@43Slz|-@ZW7P7I=@ z6lL)ytD6~FBjDYNL4LmfXPYRR)-WtSoOyZIc`!lD!l{`Q-!EU6AWBUmO3JMIt9@rV zwrz?}3rcSUYd`(bW`UBnWTfBw>2`;pNKo-on0NzI1z;+MM;gYT!;qdGAmDiyrPn`T)b{vL43W)aYI5`e zl~zq7)tE{z52dMc^LbZxp-D8?Fc45VVrH4^|t3ZD!l>wtdm%Ho`io3U3TLITg9j>abA5_2ZwsaRUk@^pO#*u9eDu0;d~ z_?`8soRio1VKBY6xxT#MHfQs?bl&H*M=s}DHElYcfla^C-BeqemvJ)=ULd;Yf99lf zCU#&NvFxMvV?_sQC$asQH=Rzu+|f{31h0+6z-R{ep7wOeg?WWn!UHohys$B8Mt+n~ zzueziUj~K1Xu>;CXHU30Ru~Df(TO`drGBZqvAPI50%!+?(v;~)#C=_Y@=^^W?20qj7DK5^d%f-hR;biM|lx`00an+ z8{9bq>osj{-Ay&c*{Lu~AQJS-$@cgZW3v(3PBAvmK&@BzHrJNqf?G0Dck#Thx2Ln_ zNVXZH^P}YYh1NQ-nI=YG#`-fSTv?s%|Ug@chVd^KaTyRF;tZ9qCZ#>-5u4()M+#NrNQ9X z+tb_A!?^)xz}j6L)jhtLa4Xs?kM4DhoMz3Q8Fp`Z1a@a6 z$HJS1{%22nx;xt`zT0CL`G{BBB=COyA>e&00Va4L^z68slSY1cw^PK-?rl@d`_Cts zcS_u~aC|ieSE_^B`r9wv-~|^WRm4v4sb+2y-21r)+&k$8o}Bp1x!5U>{^<*E;8QcZ zyUn2QXN~9^&Rc*VjJKPUt^B)hK060qZ8K(XQ}p}!N%{@L?gO*a#X)6#@Q+^yn)H5~ z=HKfk`1d84QMfXV;>e%AJcvRmlSXhe1pMi70?y5Js0tn0`>_)Mx*0v;W*GQW6Aau3 z&rYqa{K%hne*xZjGsbXp3_KKWhj>ys+rv2R{rxeF49z&hB~uwV(Bi2Ke6<~B;4m2+ z)$DiscYb^tVwv%Un_}RW;|$zIYr`Hnu;-HltSLvh!=QXXG#difD2{%+_Yc4GHthv> zgfK$$2poLZ-|YBMfz7+7OyILI@O?W!`uY+#x|6Q$N%yyQP&Qx=g74e)$@a6RT;Fqn z;JZHlrF zdU*`m*o!(e$U;Y ztsa_=y*0yA4caF-JZ=L$S-e3TWAB9-v>iC4J=LK7DE7vd?J3y%QG@m*_FgK3_WmD# zwTmErF2sM)#{Z-bNilqEqp`GHHTRDtSYE(2B;+&j^6{d2LsC4UZ1wsL8?81!Gw09d z%~n>MHa@lP37J^HP>U&mr1`RS&l(o^xu5u>r&dY$^ujA38PRI1R~MKbWP@LBT)mhA zNS!l|p zJTog`ne!X|_SL6l{KuI8mw&Ozf=`(Sbj#iUZEsjvn!5rlcm8*N@ObmTyLIzp?f-j^ zKmRI$nLEI8pa1u^KJ))N|ND=*|10?)@BCXC|CRB7oY&u#`L{CvR_34SF96HE|5;go zE9-A%{jID&Qv_h;`h)!kOYr>N#1s6L>+j0-cjfxKa{XPo{?0rCEBBw3`_Ib#cV+)! zV*9k{=9T@|%KmF*|FyFJntAs@5G(tSmHo%c{$pkTvFMG4i2y76kGbqW7XAK@iP1M0 z=H~x+tofJV{VS8*H(>vf`Tfrlynkjoytl!a@A&PuH@B=e>whGS@1Oo;+Xo;0e)|_o z`Pu&ak3QJ;lUJ=~GvIRX-@f|hTW@cB_r3StU#ic0@4dV2?YG{1_1SeY^RESxBqOv~ zXSL;(*WTE=w4XO#du5B&Itwsho0)!i2fBdwpXczR^k%D#8`iIu31=~&;{q1&{`c%} tisKi=B_jSD-p(fB|G)`<@izPo;7j^}h`hPIolfEpwe%k@?jzqk{tGC%q7DE6 literal 0 HcmV?d00001 diff --git a/collects/drscheme/drscheme.creator b/collects/drscheme/drscheme.creator new file mode 100644 index 0000000000..8e31ad43ae --- /dev/null +++ b/collects/drscheme/drscheme.creator @@ -0,0 +1,2 @@ +DrSc +(This code is registered with Apple.) diff --git a/collects/drscheme/drscheme.filetypes b/collects/drscheme/drscheme.filetypes new file mode 100644 index 0000000000..c833614f95 --- /dev/null +++ b/collects/drscheme/drscheme.filetypes @@ -0,0 +1,20 @@ +((("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")))) diff --git a/collects/drscheme/drscheme.ss b/collects/drscheme/drscheme.ss new file mode 100644 index 0000000000..fedf1a14d5 --- /dev/null +++ b/collects/drscheme/drscheme.ss @@ -0,0 +1,47 @@ +(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)) diff --git a/collects/drscheme/drscheme.utiexports b/collects/drscheme/drscheme.utiexports new file mode 100644 index 0000000000..7d0c93b5ea --- /dev/null +++ b/collects/drscheme/drscheme.utiexports @@ -0,0 +1,15 @@ +((("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")))))) diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss new file mode 100644 index 0000000000..9f6556b3cd --- /dev/null +++ b/collects/drscheme/info.ss @@ -0,0 +1,6 @@ +#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")) diff --git a/collects/drscheme/installer.ss b/collects/drscheme/installer.ss new file mode 100644 index 0000000000..79c6c2883f --- /dev/null +++ b/collects/drscheme/installer.ss @@ -0,0 +1,21 @@ +(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"))))))) diff --git a/collects/drscheme/main.ss b/collects/drscheme/main.ss new file mode 100644 index 0000000000..f5202c93ea --- /dev/null +++ b/collects/drscheme/main.ss @@ -0,0 +1,2 @@ +(module main scheme/base + (require "drscheme.ss")) diff --git a/collects/drscheme/pltdoc.icns b/collects/drscheme/pltdoc.icns new file mode 100644 index 0000000000000000000000000000000000000000..c90a814c94cfc822c8c29f4c1d3bd57c0f4b3918 GIT binary patch literal 43952 zcmeIb2V4}_8a6(#yX?{hgC)_J+$1--G54mJZZ!51H5wBuQ9%$a*bt;Dv%4(4_uhN& zy?1GfAV}}Mcb2x_JF|d*G!y;j|NTCe@C!5Nyw7>xbKW`U%slg~*CcM;LlEDfYZCW9 zKoI1RT94X@+PK=}qCd-&1J3sd!a-rNwr<@zJTfveJj`N$hTsEdhKEL99AhVtAu4_X zFW-6!9Ylu4uoG}h77;n+jgFok!Hx$9hc=qQ6s*Z4% zmX{ajCVM1Ro6`}V^2&;el1DM_W7P&Ugtxk;x~i(c^G?rLwI&tet*ftZ>g+&2yrgXA z0*B4bO?@m@=bK#(1YwPjPE+Qhxc;l01Yw8uf&!b(E6utwl_9DZ5YFABd&Q@=Ivf9$ts z*6#@X{ThG&+4iqV$iTEsglT&PA8gjcKI|EuIeWx#Yj){$g{@o1=V8v2;|Rk;Tk-k) zMWq+zPyt&Y=2e(g4i!cas4$hqYz%Bhh7VL5K6PsNG-U12@azig;=!-J|9(i#+Z!Fi zDr}v2(LTFe?DQFBo*o{WUdEsrUXB%iuxU`Su(QhtTNdV(ld<9tHX)yO zbaufC1!2s^$IU+w85~rDa-R{1b8h)2++JW4`4m>pggEDx@50JO1U?Xf1+l0b-O66m z*mW@fu<}i0STMJ$6?OZ*T>e7|L?`e;$@6WeeY$;_&{r?;p+5$|(`b(` zERl1|k)aEvUww7(U}@Qn3!}bcP(Eu71bgW53rxwfvKu$bwW!q55%6dZK9mnLB_+$t zE40Q&nar2Vv7N#QlX-#3WS%~~P&usB*!BWjzhO;&seQ=Jt<%M@Y|k%;wSEL!?XfD* z%uD_cj*MUp;2941%=z{R^E9~4gzW+B5um~lGA};nsNeV)l{z*)K0XFjUMk;;J3i$- zY$*_AZvS9?IQVODO@PAH4BGBrmFp|@~1H&j;E+!7DbYlTgM$MD&*&_kiH^teWWuI9g_Y$1ILPs+4{N+M+58KRPaZz2 ztp@X9;i2NF=8=(s)}q7!8wsI()|E{SaDGI1xXwN-ySOkj+SkG8?$2jz>sy)uWJIVm z(c0e2$J^0DTj|;GlRPb9(~= zT`f~%9gpU|UZ_4Ql=CP#G&IP|&%@r%%FN2MaiAZnj|q=vrDQ+#b9HxeurjxEHg~QY z9K_G}B}e&1=4M3r`UHBr8fcl;3=P5gap6uskBpeG*tAC(aUOPdCI-*@vGWtc!v^Me zA2Kv`?#sz4Fbs?>szACc&IMI*K8%7?ZRKbewZ+Y$OGF!|6tA=5A_gtSgC_oo?za zln@oUQn|U=Ce+$`i=T{GHqA{p;r4bVUOs-(?ml#0!U?7F^9u@ce>w4ZPRa@0;1gW4 zh9p@xH|>ObeuVRaZ#nNM4w;>L!tI~(2?&zzp#o|pFVYW|hk=3bc=>rgDENf@b+W>& z3>1>0@N!x?a!}TwwsUeYZY}Z0%B@5)`A4gn92CKB!|KlR=<9Qk$s`eld$W@;UIP7u zgNsBW@4qZFI|-v`JKkTvZo`&?cQxiEp*I7SRZ`bBe<=xlgS;HxXc8*O&Pqa&$;pZ7 zEIa~Pc=pci{|mCPv7z`$cDnuaq=#i8gVtP=7va(MV$Q>}kP9&zug(g$HPD-$^k%Yf zvacw{+s5(5v^SlFlVep0ewN;8Qxo5G7S@l~r}$af#!pRtv$C)u$=6ELrHDNNzR1Fd zb+Ml2sPR*55}cQX5za;`x&`cc@I@A?1=?uH>CMc93Da5lgPozmEgO6$#Ivye{B#!H zr(Tn?YnYk}%aX55W#IwITWSH*Q(ddfSF ziQSMrdF;qBX<1o=+Nr59*VWO^$;FlG%;n8TLynpy8hrdX`%y+pLTqG6fRCGZymTU>4wkhvwjH$^ts-F2p=G4$ zPFagZ_c$*nD*l42u+{XAS;;uECf5q+>gYG`wsD8c(3 zZz3PMFC`&5#NWfk-Y+XbDh@HIr`930)EZ>kgj)6v=2Z#S=Y@p@kMka-r^H4CdOO=$ zr)I}X#Uh6DEl}w17bZ^&@^dm%6QhEBTy4#L3c(}>F~UvI8cH=hGR8-CzD;g+dQxnt zkE@-TX(iZ5MkB^kHq>eX+@`$zMGgr=2IW0UjSKg4wKdZ(0gE`vD8yvO0?UN=AQPr7 zuu$L@Fe5QCz}?nN_faEm5s8>KQ0w6)v6fg<1D>(72Q7PhDwv|eCwZAE(Lo;erg{mT zxQ#>vVzz`0BwWE`@GHd2!AvJ~V9F*OF`u$wck_Gf)W*mDS<%zSxfzKOK2GL3UZc|% zVTi?|7DZ3NtK`T4XA4~$){I3cV%bP-K@R4uwK}N zAXW?8@RvR>hFi?+)YxDTYkhr`MVVVY z&Xf%mt{Y)22g=J!pO+Lp$xV+7^RhS6puI4V3`97Zni!2pli^%DA>6L46z=hJGZVsn z9E=(CS!MwU+N|D$G#fQh8#x*pP<&_+Xm1T>2U8Hll$9Le>u9Q>KFiD>p~Kxht=Ry~ zHZ?TV*EiI|6N93s#if;1Rggl(h53(?qWql9v>CIk{18Sn(!^-yY-(!O28v-*Lq)nH z_3j_Lf7r2e*O3eII>EVR&!0WXNsS6{HrLj8VJYQ{m^U+;zG^Iww`8a>w2T-R|I5Qg zA#?Ms{bY}%LuNsCYIK0Br7n8^)-4)}QgvJc6AS9Gi$cl=F=^p!Zf>DBlN(ASt$o9C zOVCo%^C#glBAhg?EoAQZ4ygtt#Rj`s8>p+?les1(DS1Wu+RZz1CVr2=+#9iIL7Ue$ z)f8qwu59Y;>F@9B>1=B%L`8^HE|j#Hy!NXbuA!cGCR%EW_io8tzkWmJ*4=yemDT8u z32{Ik9H&oG#)tYk^Tf$qWGWYx#4GfJqMM7Qfrgs0f*g8}PfqT> zlIlaMy0*Ssw6rHeZ#8NmH`hL|>>3%Lgx;7O9cT;uFDIF8OWydKfxVf&CY}0F6@9>` zriRkgHMRAOjO`;Ycp!{cq=nk5)k12jsc0LT)Mb&!hAZxJb796b5|6-l3YO-^`a0U$ zS~P8L9X$ghV>3%jmv|3Er%kh!*j!!JH*Ub<8t)DN1aFTHw~qh5Zf$ExHAgK_b8ZVO zOG{f@dwc&-cf_!bidzg!8nFly6_*Gow4qKSzJJxh#f9pOy6`zWJ2_$hIlH(f>~%wo z+eod=)zw3jCM;5)gAm-tQn?tU_3z7g`Um(21O@~K`uX|#czJtzdU<$6JGmifyI~t= zea(;=;OFn)!0_oLB9Zi=QV2C#FeV1>2f{-`f&v4;E+EDYp|_)L9PRClHbQG%^?(J7 z(4oQ2g_2S5ibNoPZJ3fmP32EXN=k^21%gaMD6IyxBbgy!1zNw679{Fp!m z8>}S)&rwfmjzD(yqs)x7iua5qG^gW67Lt*;xiVsX}9C1TYfa3bL?nI!rX z-u&F0tn^e^cw-_W+z|Z^Vtac-^?)^tFzEdbk?jr_MDeA~Gg#vJieOgD&wZ4cmYfh1 z<%V!{cItHyT5D>@ZCIRT=K!073&7U_I{)P)SUa#4s;J-ztbee!$GRcZE}c%!=IVZ1 z7NOUE;}kwh6#m@06ranRbar-i(K-q3H8ta4GWPfwj2q^@2(%z5 zoe7f-wi1+p5iDmJscwi4JbB}6u4=bq5hvP=-hvLrJ%T1k+uecYgrx(f8JGkf=VfQQ zA$nbej{34etag9e9`I+nHes{sV_2Q=tqRPuSaml9>Cx>bbkvqH?O5F7gOzGLkf~U_ zfKK2$$arIf?cgnNY7cSGns zXg5bs54D@nT-t`)^tV4b442`Q4dG+Oz&w1R#oWS-Al@EgcUOH;r#*{%thcR7em!xf z_S@H;qMl>RA2ugr)gcvn2;FrB-S#XlW^YTa=XMg-m*5RSSk%rd3-)JImCH(CZ2S7O zdkNjOxt(?_p2?B!rs|Aq!lWrzIQdRkJ4ZgR!1ja9{u zvr-Z~Px29|5DPRUe8%3@*(FJgImMnqE;qKBg5Z54iprt%IsXL z9~zNLAa4;x&E4F>im9z6wk>4Tu+|Wz=c#Yhqvx$dllrW66Qli|U<}W#QWK&>1H9dx z9gTkzAfVti57#$0ADX(k$5yttp{+z50#a<40MB`cX+zwDwV?sAIi)Q_6FRK*6Qe^t zZH={M&}(T4G2sC|9xe`c)^b}>aD;c`N#zH|ZeD5i@L(TpC16N!oefimxVy4o$<8Tl z=pEHyZJrz(8R+R~s;hkdG#_G#4iED2gvTsamU_np3E&Vv*B94R9~im%6|{EXNSuHK z-7%y${Q1yeg{MbILiV$oj=>S;=-Alk$nZdKcYAYvRatRCE~E{>!BZk9I~xl#6Pb@_ z1Obr~3Mwl4uA#*pooqOc7Cx)4_fiO(?9{~ANI>&+bF#OwG&9!MR=>EJlR(^fLP=3cLDR3e6YU~)c64C9hQ&!A z;RJ4rG5k|&YMh;|i+^}rT28@pYzBtyVIemErY6DdUT`2FI@?2_#`;=x^!C>zPLZ$0 z6y+7=HKOXfyU{MB6G)b}Rvc4ngg(5ZB{{=V*UH&DFg!jbEAPouY)Q(=OixXWi-`;k z^7Dp%v$wG_Gt$+ht0~JJ65{**kf`|S>+%LUSpTpAIojL6$3b0S0(LegWj?&5ZEol8 z9TXlNpOT)HnVFWFm>3%!85$hm>*WrkYGYw)sG~u9s3d>qkAHn7_S?zd_lhc574^OV zMB1^K^+$djtWL>w)6&y5wsdgw@(T)!h>DAkgS9v!Gzh>TRLBu?BV8?ZR8>*#melWu zB=7!y`ntFb!?6hM<(zR4^G<(cdw*HdlkBum15JH1YkMa*FK<8pprGKOpg=#sa&>mJ zwK6w00MFD^6z<);a{k;6#ru~e6crh!u8;euz%4PUHb7-+j|le`CFN&kMQEDp zYwMd>TH84~xzOA`bai!dvcilA0FI** zN24U5ggLls5nIBD^-r!U`CQc?ss6+QGK3VjjP z3fpMFBVc#{*Q?K5*Or==nPMrInV1wG=4hm=rXa7Rs`>z>s=fD6RYh4rUiQ`v=}V{2 zh}~Aeu@q4~8-3B+klLXQ)P4lOH~|dSir!H@rbtVCR$8Lo{j9`<`1mMa3mpdS{@vTM zDD1Jf$liusx|G=2bEl-_m6Vh*u!lNkHg-lAu31?a`_@OZRYldXqXZ; z5i^t_7_HFB_#%EcqPWf#zaR(Mnr_7A>?3R7YCoPz#!C*+ug=Un_*~XY3G32 z3))&+Sy`A{Q13EKjf`w^`l$o7e%Rb#V0xqcz4=k;iHXt9p3rYmk!Zwcp`jrm!NGxn zKHdQlaY+f$!7la=&d!dG_73*80A*=uZf>GZH83_bwoLD%0Twa^^=|j0$kh1wxQK{^ zs3_d2P`FToVaM<5>*ea=ggU&g94x==Hdaf}}7kx=`5u2L-~dgRif*x2K1PJHP>sgS{Q@5&)T6*_av|8R#1s zM05-e(g#q$LOQ8qTBAGKbT&DFzg;AFd)DmuzcX|1;c{q01E4M+$m#g zcLyBIKrg5X9aJAca4`B9=jiAdeRM}lbOPL5#6(3E^j5_LhCq~o7@Uu*r@>U}&hXr>EszO9SsP-?Ybmgx3-3LsI}MGBP~kSx-%Ze_${kq>qo6 z7v>oj=2VoB59X%ECXS(D_7J8Xs>{i6siY6ma4g-ipP5xbY3yVOi74o9%?kGM^T#3t zAWsih7d%KTM$9J*6JraXgcwIdJ$*f0U2R>4ZOMQ-?5QxfbjQ9KE(u75w2FYf3J!VH z-1|Ji-^<(E2XH*y-CUeqoSYpUpyQ#pEX+*JU82&X9SrrrBeIUR7Tx0M;1FYw-DA3A zy9WvaQlcUw!r;~~Bq$*Md3*EIIDdB+H+K(k%EbxK2Eej{RIqdoPD%>2GJxoG;htAh zL)|22U}#8v5SempQ(sO%B6j8A85-ahl=8f(vGh^2zpJx@BV;-Oa4b=?4OaFp-a*kZ zL5{`-h6eijx`3t0U>KzJQHN-_XPlkmk+$e#_|IE@(74Z%`Ye}uc@!A!M36C-Zmx% z`p|Feo`W^w-pL)u6*T->1{p)_%Ts534YMIAz*X$RZT~=je@F~(FVu4rWUI5itsN|b zZeBiKp3b(GCWZ!vM$m2G7^=;$rKzdGP`G&VoIK5=4gZk>tUBW(#12TuPfe&y_E z+rHnqXaB)pjvhbp`yXe{U$`J9F8bro`+qvJ?Z~!c+jj5Rvt#e}U$00=UcG)59#e^n z{wXc}yL@u%0KOfZg8Oo`JL}G|i{jEUV&87xckl>6ojP+?^v_FT;^LRDT>NS8ultUF zcl4WIzumVBes=sOC2@szo#&d=Luvhn^z#XiAZJG%GR?~Z*9cs~Q)PbVNoF|7dA3sT~j zq;5%_H+bGVg6)bBY?IVYn`BJv9v^(J`^z~o$*Y%l{QJM3f4lSGu|Lk7W5+59vFa7QZZxUZ#p8mr?koit}8SxFU7+u3>89;0S|> zhu5P!Nn*AahS}&_Xlv=vwK;UO={jU>Z3DZAr)@(TOa$ArLnZQPUtNAeL`bknkWC;t zG(Nuu260q}jklp%$Aw(=XC0Bt0u@=o}cK!mfthjNT-1Y;>rvhu&?{rQfO1 zLF(-38yaEKMyXR33?`8Yt#RWqy-`gj$0$={l#|KC1GJwsn$R298q*l%V4rY=6T0{b zHncMw>%ioyK8hW4^srnf4dH|qtefl#RF(^VMstidiYG~rI*VhH|gIWhOeGqH|q@q9eC9M*PGJ&8qX!cscnFl~Y$t))};MwWb~5 z16wUVl$YbPVCt*!b{cKOJW+lM56Y*(PvYa_<=Lc9do>P^t6Xa>g@=!i#*Yfn_=$Wx zYo+?ZiIq}%Tunj$rcn6!P<{;ol%K#W_(v=4C4!Iog#YoAxfGv42UmN(7&o+x@@rz2 zd;*8-!1WdLedGqGjTCM^K7OhIT@V!@@$>Tu9IU0UoB-s?KTn~+JIttn2G|q%`Gn54 z(_e`YqUXaNF&cf&B`#J z@O!LNqty|m5aANXkQk6G z!hbZdiuRDHynNgn?zeX?%XRAX@$}-(V3!+QZ|Z_v{96NAeGVd2co(0C_ow8JMY&Hb zs>(`?%OrRCZ-lv-7cO|J08Nm>w?UrCs``_HN5n(fti2c^Iz?{cgeavq?mt{GTe2q{ zt{qQUBVqsI#@(RsAJ3^=mLMg7gkVr>fRwY71f7fWQTb^CWWLS%pe2^2PmC}o#Krq>PZo?e<`2rvN9O*@BX2og6>xM1c?R0-`7s!51%$O&`0@a2 zGJhu*EG;}dRBizZ*9O`2<#<+LOZA2*1F2u(4)H)Jd;s^qC>E>JK#-f43N8s!C}f`9 z0dXtiT?u6pBrcSK@=$rXdEUAWYkJWE5`;$O=Ackec&&&Qy#flB*k%vJKL&&HQh2`3 z0QITGS_E_S15%>=H6-pFFme+ zjwLne@&OL`1&i6vA{MLPX#<%K7*w(V7wIjvcq=V8~@sAF$OkjXGU`=0dow7S1f;-*pP@EXt-(l;~*jNe=d|0>iLe2NI( zz*`@i4O$wT9!qf1DC%Sy*9PK7NlUAh)2?e})W z;%6W;;@RUK869W;HGx4^2aLA~Yk$|!TnVizgwd+*=;(F086r+Z_Qyl{jD_ao%(Do0p+9;Xq;~oh?I@n&dDiZT%zIzsqzQ*t)sd znj0ILSy-Djw?wDLD#`g8NlpQrV|f!CXL0o8d)O!Ug_OMku= zs`J1R^rYbLzaBa93S1{5MtwD^(-x>sZ5`S_Pj%{!YQ0Q#>H?EFi|RDSnM{o-CKIDN zG3t{|b#lUUCpP){TDZPfd{u=ZT1Q_cIaf)}MI?!<^1|0AFH~;?jp3{63ptvbt^c~X zkPnlAuvIq2rJ!u)gD3t=iwpIdwtxtvwz~LfMtWLm>Z1%$BS*w#=9UyKsVuB1&WG3C z^YTEmg}po<2X7XJheT)RFQqKRh|O;r>q<*2D@v;Bsw&`R{sK@2fW#m&6qB(_Xl=vC zPI{UM+Aeq#@Wu&NY5>4DMjPLZ0I^rUo}@_LaO-4P>@f!I#`?Nnua_= z7tuK`NQ#P#546{pKLx2zG-R8Xo3o9%k)}<`0^&z<`$E*{`pH2|@C|D27*OSay}hNe zu69u2VuHwp2~ryC<4I;01e2eY91{*h?CxxDWum8UnT9DC7tl#AOq2c_lzTOxcT0%_ z^^~`}i-WbPftE&K$;KO?{s`z1e{Z;wZ7q#;)KzWr z7SvxZ#h$)Eie`IcV`-wxP}T@4WGge-qRDAx=6nkEt2q?vY@ghm9WW#fRn&HI(dK+2 z^`m)2D%RO)Scss;V#7U9)D6f(tGU@S(`h~D%XI2jbLrI9+UJ=5Eh+?N2~5{ztgG=* zPQ&qKt>;Um>bCi$YEAKzEJ%Q0UrcId%|@cyc}^)om*G~o&F5CDooq)9V?9k&`KG+J%S)2f#TZx&XPSY<^Bx!b8R{?| zDqNShb)KhFU6zLZWSWMJi@@>%Q<#|;Xwg;WuHCnrC10JQVl|eaVc(mfVPmjm5!d(` z>1j}vWv|HD&(gH6go^!mnu?wA$xxgAQ1RAPC7U@S*Oid5A5W99SUzCFLnA#+s*0SH zgbHBIm%T1c$A0pHj`hTn-ps^MM_oQ9 z3+Q5(B4xMWq-?f`Px}&CMypT#3<7Ia(!pputilgohn`u6nFSE}o0m`gsiN{gNo!F-?Ao?;_pg^> zX4O>WZ%du~MO;-;MNw;E9W1FeEmKZpNoH35j`aC6M=wa8mr*o&S^TO8UkEzfn3nV4 z^QD;CThgMUQXtPbcu~dX*#d%Bp@Evr0$;|dHA^tFr_bDyJ9X~Xl{;Fl&t4X}uIaBx zhdpP&*|!&?W{+G~RlY2xs-k7%`D9v$I$PGdrne-mC^tWjasS@S)a)-`?zyI-s(MdG zQOm;7C1<{nbrv;SkOp5q z$_~&vzJ7+9{pzBks)~w|;sd!mR!$BMNiV5XfttcD^pj{^vxBa?i?(S&Cg7CRf)|=Nx{J4LGl^o zW~FE3;NfO(1zJ99dlw73iYisZ2xO@s`UIt>gYNZ*ww9(&PX_?*g$Q*gv%e@IFC#Nl z&p#a~j06k|6p@kPA?_~z5y3%z{{CL}=K9)Z)^;u+W5lt5deFSDXJcXEkULj|`blp= zTyA<=qNiUncm;A`Op1!pAz?uQVX?_6De>W+u5OrC6Ll4ug0ivFW|&!;Ti9mI5utK- zXUAuQlq@bb6-^-F!t+RKgfOQ1^!LRDj2<9V^Kf@}MV;3`e0K1~aMmWqmgZ&_mPxZU zsD#e6ge)|LH#w&yGbSDcz@T79!+Al1hJA+(F0Dj8Ntk-n)fshM1Cmy2YkNm)5Wbn3 zn?`kjYV?H!bzOT>e0mDR_Nb*U8NL$^pd!L>G1~`#g~|FLHcU7Qv0;4iX8$v{b;0k1y`4O$?95o`Zm6A;D-M;*a{i3sOGJGZ$xEK8ndAokKz#%`i2d zi2=x`XC$Z_FbQfDNK&BJW8$9o)}@7qVY<(d5H#>ZOl}K0K}^z$K>-%%cCD=3V`AJu zaBBj(J{|X264dp~>hNs%-a8n+=$OKu_Pod-%%{LWG=PGARS+(YMO`*vT4FmpYfJl} zv?OYvb=Po7=p)D~EU6+Q^IH4LQ$qqk0UY3u>1+YX1JktPF4=*Q+bba_ z(aqe{)CBX%K-;=-5LBZa1Gs8ecWnK@(~zub5qCsLQh8@bNlK`%mlx_w0DY_{>aoQQ z;&XJcwYG8eiptCicQ7?G1pzRog4D6houfg0r!O}w9W>^#(U|T!JUBeFvZK8sFFw=< zw6RpzEiTR=jkU3LaPbO^N=%7#x57K!7}ufdnx@Z4P~pWKpbp;c&InD8gGch90ETQ2 z4GD}$D{1a&uPMroj|>a+L%rVh^9u}1&CAJ1jt+3KG&O~e#~jns(bds4N}4M{)fnUL zNDPj!*K)yp3qwP{1lhD-Kx}qNLuX%CbA5G1$@8+Rn#Q*7x|~Q)J9A?Q6YnxZT{`S; zwe=$B>remF8WZFpc32uj*tqBx*I;{j`GzNCJ}D}#tZ!(jt0;bwlkD$oNi`Fm>VJKG z9mTWzPCd{GoGm{UW;TR{dPzyig<_eCOR)V=-}UgFA>B`J$fIbHoG>$?;rtLoa4=kO4u+v~)$;C<)RoB$f2ZcKb zoULr_U0}Mf*3!{q7^|DmP1W^v^>qz&EZp62K{N=fZEc*L8S1f3{lg>FS)A+!(4R`5 zkdT(SE3xgz-3N~z|NReK<9YcCdi|rDS3m%{|M%^`|8V+;L;HW(cX;=iySHx3$;->$ zy(=Si_1?V;iu3fRyFq^{f9l%Jdx|nY?K%3}A0Ryy69cmJx{S=tn|Gx59X)mQ+>TQ} zo&M3`{%`rv*CU@b@#B52afJNclXxatNT7bDkFRIhOCmTxbcDl zRQ;1uH}BlLweQm}zxnCFiE|e*_paTLxq0jEwLORbICOgZsUOe$@XLW;4jkQcPWH~d ziy!lDla{?HBdc^r++slis`(#RZ{NFj^YC}ufBgQ(-G@$`y&xtjef|24>o>3LKXT^C zshxj7$XLKf_Mf?VL*~lSohPr~yna(o`POBdc>+{^5TLq?UAQbMcK+yrgNM+AUmQ5} z%dy{1f{OR-nRBO)9Q)(flZSsheDd(|W5L9?-;$l>F9j-U3Mb+!nTwIH~AVIsV7WD-|`?|EKa`^W`@4~(pdd`P~lgP!* z%MW^lH7oxJ3JMDF^YKu)hy;$QFEgG4y7B`KP7;M*c-_W#Hov=N#h-WI-Mo3zI~zoV z_<6`g&cEXT2M3WNAhPh+@Gf(9tRrmy#j00)7KU*x@IT3WPtGV_NGYk2>T z0~|zd;mw~d+Q6~}qqp7>{yPqEka*X9^zE|EEM8$ub@ST4;Q$90|He;uE)KtZ3G>|F zaDao8OW>XV?O(o?C2BCwZ~n_e0PPEI{_^k==qo517v1z%9pK<33%;Oq zzv=+Azh=v}qf3FWq-^5+JHkAF1MK#Xtt7^!>r9CLr5<=~?X&)x1Fx_B zzvjSeY@app=c^CF>umq8IPhBA{|gSh-u7SJf!EyrD?9MI+kaIDUVHnm=)mi5|JCM! zH_-koIq)Xhe-#JbNc*qgz?*3wUyfI_DSbojuh@Y%)jl||qAl4QYo9f?A_v}F`z+=; ztOu64IemlevzQ0p5#lB-?ZBICpVj;EMnMX3$(!Rh+CD4&!*zU1kHDL4pSkZ{VeTb6 z;LWzra{74v(jD-I+pqXy^BT%hk4N5c`^@h?c#CJL0eHjhPwxC=JuhjAE8q>c&)WOh z+x%SrVEYF@-z32G@;^K`^LX%0$A9?C&4NqK0B^eeU%vWh+ds1H-G4OxqyK#SYsgD1 zfp2>Jk8a!Y|8)Du{^9sn+y7_tZ?*qd`~RPue^>KwHUC!gZ}A&|H@*K^z5Z6Ozt!t+ z_4=E+;h*=%>imPffAAXk_eI$G)%kaI{#~7aSLfe()9%dS>ioMp|E{h-tLyI~+lRk> zdUgM?y8l?+f2{65W;Pu2{#f0AtnNQn_aCeKkH5XqSOj2o|FOFNSbqQUxAi}ZWFL#Q zviCp!(e_`1{%Xu*2%cIW=XM~)sn_PRbtj~+R^f9JQKy(hxIv@DRVKi>S&r~mtM z+w1*&`M*y;+AJafFJLc`ehBiH^w%p8YQMYrosH{+`6 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) + (stringstring (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)))]))) diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss new file mode 100644 index 0000000000..d0cc135c12 --- /dev/null +++ b/collects/drscheme/private/auto-language.ss @@ -0,0 +1,62 @@ +(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))))) diff --git a/collects/drscheme/private/bindings-browser.ss b/collects/drscheme/private/bindings-browser.ss new file mode 100644 index 0000000000..aea142053f --- /dev/null +++ b/collects/drscheme/private/bindings-browser.ss @@ -0,0 +1,305 @@ +#| + +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)) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss new file mode 100644 index 0000000000..3fca8ff589 --- /dev/null +++ b/collects/drscheme/private/debug.ss @@ -0,0 +1,2005 @@ +#| + +profile todo: + - use origin fields + - sort out various ways of clearing out the profiling information + +|# + +#lang scheme/base + +(require scheme/unit + errortrace/stacktrace + scheme/class + scheme/path + framework + scheme/gui/base + string-constants + framework/private/bday + "drsig.ss" + "bindings-browser.ss" + (for-syntax scheme/base)) + +(define orig (current-output-port)) + +(provide debug@) +(define-unit debug@ + (import [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix drscheme:init: drscheme:init^]) + (export drscheme:debug^) + + + (define (printf . args) (apply fprintf orig args)) + + + ; + ; + ; ; + ; ; ; + ; ; + ; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;; + ; ;; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ; + ; ; + ; ;;; + ; + + ;; type debug-source = (union symbol (instanceof editor<%>)) + + ;; original-output-port : output-port + ;; for debugging -- be sure to print to here, not the current output port + (define original-output-port (current-output-port)) + + ;; cm-key : symbol + ;; the key used to put information on the continuation + (define cm-key (gensym 'drscheme-debug-continuation-mark-key)) + + (define (get-cm-key) cm-key) + + ;; cms->srclocs : continuation-marks -> (listof srcloc) + (define (cms->srclocs cms) + (map + (λ (x) (make-srcloc (list-ref x 0) + (list-ref x 1) + (list-ref x 2) + (list-ref x 3) + (list-ref x 4))) + (continuation-mark-set->list cms cm-key))) + + ;; error-delta : (instanceof style-delta%) + (define error-delta (make-object style-delta% 'change-style 'italic)) + (send error-delta set-delta-foreground (make-object color% 255 0 0)) + + ;; get-error-color : -> (instanceof color%) + (define get-error-color + (let ([w-o-b (make-object color% 63 0 0)] + [b-o-w (make-object color% "PINK")]) + (λ () + (if (preferences:get 'framework:white-on-black?) + w-o-b + b-o-w)))) + + (define arrow-cursor (make-object cursor% 'arrow)) + (define (clickable-snip-mixin snip%) + (class snip% + (init-rest args) + (inherit get-flags set-flags get-admin get-extent) + + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/public (get-callback) callback) + + (define grabbed? #f) + (define clicked? #f) + (define mouse-x #f) + (define mouse-y #f) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (super draw dc x y left top right bottom dx dy draw-caret) + (when clicked? + (let ([brush (send dc get-brush)] + [pen (send dc get-pen)]) + (let-values ([(w h) (get-w/h dc)]) + (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite)) + (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) + (send dc draw-rectangle x y w h) + (send dc set-pen pen) + (send dc set-brush brush))))) + + (define/override (on-event dc x y editorx editory evt) + (cond + [(send evt button-down? 'left) + (set! grabbed? #t) + (set! clicked? #t) + (set! mouse-x x) + (invalidate dc)] + [(send evt leaving?) + (set! clicked? #f) + (set! mouse-x #f) + (set! mouse-y #f) + (invalidate dc)] + [(send evt button-up? 'left) + (when clicked? + (callback)) + (set! grabbed? #f) + (set! clicked? #f) + (invalidate dc)])) + + (define/private (invalidate dc) + (let ([admin (get-admin)]) + (when admin + (let-values ([(w h) (get-w/h dc)]) + (send admin needs-update this 0 0 w h))))) + + (define/private (get-w/h dc) + (let ([wb (box 0)] + [hb (box 0)]) + ;; know that the snip is the same size everywhere, + ;; so just use (0,0) for its position + (get-extent dc 0 0 wb hb #f #f #f #f) + (values (unbox wb) + (unbox hb)))) + + (define/override (adjust-cursor dc x y editorx editory event) + arrow-cursor) + + (apply super-make-object args) + (set-flags (cons 'handles-events (get-flags))))) + + (define clickable-image-snip% (clickable-snip-mixin image-snip%)) + (define clickable-string-snip% + (class (clickable-snip-mixin string-snip%) + (inherit get-callback set-callback) + (init-field str) + (define/override (copy) + (let ([n (new clickable-string-snip% [str str])]) + (send n set-callback (get-callback)) + n)) + (super-make-object str))) + + ;; make-note% : string -> (union class #f) + (define (make-note% filename flag) + (let ([bitmap (make-object bitmap% + (build-path (collection-path "icons") filename) + flag)]) + (and (send bitmap ok?) + (letrec ([note% + (class clickable-image-snip% + (inherit get-callback) + (define/public (get-image-name) filename) + (define/override (copy) + (let ([n (new note%)]) + (send n set-callback (get-callback)) + n)) + (super-make-object bitmap))]) + note%)))) + + (define bug-note% (make-note% "stop-multi.png" 'png/mask)) + (define mf-note% (make-note% "mf.gif" 'gif)) + (define file-note% (make-note% "stop-22x22.png" 'png/mask)) + + ;; display-stats : (syntax -> syntax) + ;; count the number of syntax expressions & number of with-continuation-marks in an + ;; expanded expression ... except that it counts keywords, too. + ;; returns its argument. + ;(define (display-stats stx) + ; (let ([exps 0] + ; [wcms 0]) + ; (let loop ([stx stx]) + ; (kernel-syntax-case stx () + ; [(#%with-continuation-mark key mark body) + ; (set! wcms (+ wcms 1)) + ; (loop #`body)] + ; [(subexps ...) + ; (set! exps (+ exps 1)) + ; (for-each loop (syntax->list stx))] + ; [exp + ; (set! exps (+ exps 1))])) + ; (fprintf (current-error-port) "exps: ~v\nwcms: ~v\n" exps wcms)) + ; stx) + + ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value + ;; adds debugging information to `sexp' and calls `oe' + (define (make-debug-eval-handler oe) + (let ([debug-tool-eval-handler + (λ (orig-exp) + (if (compiled-expression? (if (syntax? orig-exp) + (syntax-e orig-exp) + orig-exp)) + (oe orig-exp) + (let loop ([exp (if (syntax? orig-exp) + orig-exp + (namespace-syntax-introduce + (datum->syntax #f orig-exp)))]) + (let ([top-e (expand-syntax-to-top-form exp)]) + (syntax-case top-e (begin) + [(begin expr ...) + ;; Found a `begin', so expand/eval each contained + ;; expression one at a time + (let i-loop ([exprs (syntax->list #'(expr ...))] + [last-one (list (void))]) + (cond + [(null? exprs) + (apply values last-one)] + [else + (i-loop (cdr exprs) + (call-with-values + (λ () + (call-with-continuation-prompt + (λ () (loop (car exprs))) + (default-continuation-prompt-tag) + (λ args + (apply + abort-current-continuation + (default-continuation-prompt-tag) + args)))) + list))]))] + [_else + ;; Not `begin', so proceed with normal expand and eval + (let* ([annotated (annotate-top (expand-syntax top-e) #f)]) + (oe annotated))])))))]) + debug-tool-eval-handler)) + + ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void + ;; adds in the bug icon, if there are contexts to display + (define (make-debug-error-display-handler orig-error-display-handler) + (define (debug-error-display-handler msg exn) + (let ([rep (drscheme:rep:current-rep)]) + (cond + [rep + (error-display-handler/stacktrace + msg + exn + (and (exn? exn) + (continuation-mark-set? (exn-continuation-marks exn)) + (cms->srclocs (exn-continuation-marks exn))))] + [else + (orig-error-display-handler msg exn)]))) + debug-error-display-handler) + + ;; error-display-handler/stacktrace : string any (listof srcloc) -> void + (define (error-display-handler/stacktrace msg exn [pre-stack #f]) + (let* ([stack (or pre-stack + (if (exn? exn) + (map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn)))) + '()))] + [src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + (if (null? stack) + '() + (list (car stack))))]) + (unless (null? stack) + (print-bug-to-stderr msg stack)) + (display-srclocs-in-error src-locs) + (display msg (current-error-port)) + (when (exn:fail:syntax? exn) + (show-syntax-error-context (current-error-port) exn)) + (newline (current-error-port)) + (flush-output (current-error-port)) + (let ([rep (drscheme:rep:current-rep)]) + (when (and (is-a? rep drscheme:rep:text<%>) + (eq? (current-error-port) + (send rep get-err-port))) + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback + (λ () + ;; need to make sure that the user's eventspace is still the same + ;; and still running here? + (send rep highlight-errors src-locs stack)))))))) + + (define (print-bug-to-stderr msg cms) + (when (port-writes-special? (current-error-port)) + (let ([note% (if (mf-bday?) mf-note% bug-note%)]) + (when note% + (let ([note (new note%)]) + (send note set-callback (λ () (show-backtrace-window msg cms))) + (write-special note (current-error-port)) + (display #\space (current-error-port))))))) + + ;; display-srclocs-in-error : (listof src-loc) -> void + ;; prints out the src location information for src-to-display + ;; as it would appear in an error message + (define (display-srclocs-in-error srcs-to-display) + (unless (null? srcs-to-display) + (let ([src-to-display (car srcs-to-display)]) + (let* ([src (srcloc-source src-to-display)] + [line (srcloc-line src-to-display)] + [col (srcloc-column src-to-display)] + [pos (srcloc-position src-to-display)] + [do-icon + (λ () + (when file-note% + (when (port-writes-special? (current-error-port)) + (let ([note (new file-note%)]) + (send note set-callback + (λ () (open-and-highlight-in-file srcs-to-display))) + (write-special note (current-error-port)) + (display #\space (current-error-port))))))] + [do-src + (λ () + (cond + [(path? src) + (display (path->string (find-relative-path (current-directory) + (normalize-path src))) + (current-error-port))] + [else + (display "" (current-error-port))]))] + [do-line/col (λ () (fprintf (current-error-port) ":~a:~a" line col))] + [do-pos (λ () (fprintf (current-error-port) "::~a" pos))] + [src-loc-in-defs/ints? + (let ([rep (drscheme:rep:current-rep)]) + (and rep + (is-a? rep drscheme:rep:text<%>) + (let ([defs (send rep get-definitions-text)]) + (or (send rep port-name-matches? src) + (eq? rep src) + (send defs port-name-matches? src) + (eq? defs src)))))]) + (cond + [(and src line col) + (do-icon) + (unless src-loc-in-defs/ints? + (do-src) + (do-line/col) + (display ": " (current-error-port)))] + [(and src pos) + (do-icon) + (unless src-loc-in-defs/ints? + (do-src) + (do-pos) + (display ": " (current-error-port)))]))))) + + ;; find-src-to-display : exn (union #f (listof srcloc)) + ;; -> (listof srclocs) + ;; finds the source location to display, choosing between + ;; the stack trace and the exception record. + (define (find-src-to-display exn cms) + (let ([has-info? + (λ (srcloc) + (ormap (λ (f) (f srcloc)) + (list srcloc-column + srcloc-line + srcloc-position + srcloc-source + #;srcloc-span)))]) ;; don't consider span alone to count as `info' + (cond + [(and (exn:srclocs? exn) + (ormap has-info? ((exn:srclocs-accessor exn) exn))) + ((exn:srclocs-accessor exn) exn)] + [(pair? cms) (list (car cms))] + [else '()]))) + + (define (show-syntax-error-context port exn) + (let ([error-text-style-delta (make-object style-delta%)] + [send-out + (λ (msg f) + (if (port-writes-special? (current-error-port)) + (let ([snp (make-object string-snip% msg)]) + (f snp) + (write-special snp (current-error-port))) + (display msg (current-error-port))))]) + (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) + (let ([show-one + (λ (expr) + (display " " (current-error-port)) + (send-out (format "~s" (syntax->datum expr)) + (λ (snp) + (send snp set-style + (send the-style-list find-or-create-style + (send snp get-style) + error-text-style-delta)))))] + [exprs (exn:fail:syntax-exprs exn)]) + (cond + [(null? exprs) (void)] + [(null? (cdr exprs)) + (send-out " in:" void) + (show-one (car exprs))] + [else + (send-out " in:" void) + (for-each (λ (expr) + (display "\n " (current-error-port)) + (show-one expr)) + exprs)])))) + + + ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void) + ;; inserts `note' and a space at the end of `rep' + ;; also sets a clickback on the inserted `note' (but not the space). + (define (insert/clickback rep note clickback) + (let ([before (send rep last-position)]) + (send rep insert (if (string? note) + note + (send note copy)) + before before) + (let ([after (send rep last-position)]) + (send rep insert #\space after after) + (send rep set-clickback before after + (λ (txt start end) + (clickback)))))) + + ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax + ;; a member of stacktrace-imports^ + ;; guarantees that the continuation marks associated with cm-key are + ;; members of the debug-source type, after unwrapped with st-mark-source + (define (with-mark src-stx expr) + (let ([source (cond + [(path? (syntax-source src-stx)) + (syntax-source src-stx)] + [(is-a? (syntax-source src-stx) editor<%>) + (syntax-source src-stx)] + [else + (let* ([rep (drscheme:rep:current-rep)]) + (and + rep + (let ([defs (send rep get-definitions-text)]) + (cond + [(send rep port-name-matches? (syntax-source src-stx)) + rep] + [(send defs port-name-matches? (syntax-source src-stx)) + defs] + [else #f]))))])] + [position (or (syntax-position src-stx) 0)] + [span (or (syntax-span src-stx) 0)] + [line (or (syntax-line src-stx) 0)] + [column (or (syntax-column src-stx) 0)]) + (if source + (with-syntax ([expr expr] + [mark (list source line column position span)] + [cm-key cm-key]) + (syntax + (with-continuation-mark 'cm-key + 'mark + expr))) + expr))) + + ;; current-backtrace-window : (union #f (instanceof frame:basic<%>)) + ;; the currently visible backtrace window, or #f, if none + (define current-backtrace-window #f) + + ;; reset-backtrace-window : -> void + ;; effect: updates current-backtrace-window + ;; closes the current backtrace window and creates a new (unshown) one + (define (reset-backtrace-window) + (when current-backtrace-window + (send current-backtrace-window close) + (set! current-backtrace-window #f)) + + (set! current-backtrace-window + (make-object backtrace-frame% + (string-constant backtrace-window-title) + #f + (preferences:get 'drscheme:backtrace-window-width) + (preferences:get 'drscheme:backtrace-window-height) + (preferences:get 'drscheme:backtrace-window-x) + (preferences:get 'drscheme:backtrace-window-y)))) + + ;; hide-backtrace-window : -> void + (define (hide-backtrace-window) + (when current-backtrace-window + (send current-backtrace-window close) + (set! current-backtrace-window #f))) + + ;; backtrace-frame% : (extends frame:basic<%>) + (define backtrace-frame% + (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) + (define/override (on-size x y) + (preferences:set 'drscheme:backtrace-window-width x) + (preferences:set 'drscheme:backtrace-window-height y) + (super on-size x y)) + (define/override (on-move x y) + (preferences:set 'drscheme:backtrace-window-x x) + (preferences:set 'drscheme:backtrace-window-y y) + (super on-move x y)) + (define/override (edit-menu:between-find-and-preferences edit-menu) (void)) + (define/override (edit-menu:between-select-all-and-find edit-menu) (void)) + (define/override (file-menu:between-save-as-and-print file-menu) (void)) + (define/augment (on-close) + (set! current-backtrace-window #f) + (inner (void) on-close)) + (super-new))) + + ;; show-backtrace-window : string + ;; (listof srcloc?) + ;; -> + ;; void + (define (show-backtrace-window error-text dis/exn) + (let ([dis (if (exn? dis/exn) + (cms->srclocs (exn-continuation-marks dis/exn)) + dis/exn)]) + (reset-backtrace-window) + (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))] + [mf-bday-note (when (mf-bday?) + (instantiate message% () + (label (string-constant happy-birthday-matthias)) + (parent (send current-backtrace-window get-area-container))))] + [ec (make-object (canvas:color-mixin canvas:wide-snip%) + (send current-backtrace-window get-area-container) + text)] + [di-vec (list->vector dis)] + [index 0] + [how-many-at-once 15] + [show-next-dis + (λ () + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (send text begin-edit-sequence) + (send text set-position (send text last-position)) + (let loop ([n index]) + (cond + [(and (< n (vector-length di-vec)) + (< n (+ index how-many-at-once))) + (show-frame ec text (vector-ref di-vec n)) + (loop (+ n 1))] + [else + (set! index n)])) + + ;; add 'more frames' link + (when (< index (vector-length di-vec)) + (let ([end-of-current (send text last-position)]) + (send text insert #\newline) + (let ([hyper-start (send text last-position)]) + (send text insert + (let* ([num-left + (- (vector-length di-vec) + index)] + [num-to-show + (min how-many-at-once + num-left)]) + (if (= num-left 1) + (string-constant last-stack-frame) + (format (if (num-left . <= . num-to-show) + (string-constant last-stack-frames) + (string-constant next-stack-frames)) + num-to-show)))) + (let ([hyper-end (send text last-position)]) + (send text change-style (gui-utils:get-clickback-delta + (preferences:get 'framework:white-on-black?)) + hyper-start hyper-end) + (send text set-clickback + hyper-start hyper-end + (λ x + (send text begin-edit-sequence) + (send text lock #f) + (send text delete end-of-current (send text last-position)) + (show-next-dis) + (send text set-position + (send text last-position) + (send text last-position)) + (send text lock #t) + (send text end-edit-sequence))) + + (send text insert #\newline) + (send text set-paragraph-alignment (send text last-paragraph) 'center))))) + + (send text set-position start-pos end-pos) + (send text end-edit-sequence)))]) + (send current-backtrace-window set-alignment 'center 'center) + (send current-backtrace-window reflow-container) + (send text auto-wrap #t) + (send text set-autowrap-bitmap #f) + (send text insert error-text) + (send text insert "\n\n") + (send text change-style error-delta 0 (- (send text last-position) 1)) + (show-next-dis) + (send text set-position 0 0) + (send text lock #t) + (send text hide-caret #t) + (send current-backtrace-window show #t)))) + + ;; show-frame : (instanceof editor-canvas%) + ;; (instanceof text%) + ;; st-mark? + ;; -> + ;; void + ;; shows one frame of the continuation + (define (show-frame editor-canvas text di) + (let* ([debug-source (srcloc-source di)] + [line (srcloc-line di)] + [column (srcloc-column di)] + [start (srcloc-position di)] + [span (srcloc-span di)] + [fn (get-filename debug-source)] + [start-pos (send text last-position)]) + + ;; make hyper link to the file + (send text insert (format "~a: ~a:~a" fn line column)) + (let ([end-pos (send text last-position)]) + (send text insert " ") + (send text change-style + (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?)) + start-pos + end-pos) + (send text set-clickback + start-pos end-pos + (λ x + (open-and-highlight-in-file (list (make-srcloc debug-source #f #f start span)))))) + + ;; make bindings hier-list + (let ([bindings (st-mark-bindings di)]) + (when (not (null? bindings)) + (send text insert (render-bindings/snip bindings)))) + (send text insert #\newline) + + (insert-context editor-canvas text debug-source start span) + (send text insert #\newline))) + + ;; insert-context : (instanceof editor-canvas%) + ;; (instanceof text%) + ;; debug-info + ;; number + ;; -> + ;; void + (define (insert-context editor-canvas text file start span) + (let-values ([(from-text close-text) + (cond + [(symbol? file) + ;; can this case happen? + (let ([text (new text:basic%)]) + (if (send text load-file (symbol->string file)) + (values text + (λ () (send text on-close))) + (values #f (λ () (void)))))] + [(path? file) + (let ([file (with-handlers ((exn:fail? (λ (x) #f))) + (normal-case-path (normalize-path file)))]) + (if file + (cond + [(send (group:get-the-frame-group) + locate-file + file) + => + (λ (frame) + (cond + [(is-a? frame drscheme:unit:frame%) + (let loop ([tabs (send frame get-tabs)]) + (cond + [(null? tabs) (values #f void)] + [else + (let* ([tab (car tabs)] + [defs (send tab get-defs)]) + (if (with-handlers ((exn:fail? (λ (x) #f))) + (equal? (normalize-path (normal-case-path (send defs get-filename))) + file)) + (values defs void) + (loop (cdr tabs))))]))] + [(is-a? frame frame:editor<%>) + (values (send frame get-editor) void)] + [else (values #f void)]))] + [(path? file) + (let ([text (new text:basic%)]) + (if (send text load-file file) + (values text + (λ () (send text on-close))) + (values #f (λ () (void)))))] + [else + (values #f void)]) + (values #f void)))] + [(is-a? file editor<%>) + (values file void)] + [else (error 'insert-context "unknown file spec ~e" file)])]) + (when from-text + (let* ([finish (+ start span -1)] + [context-text (copy/highlight-text from-text start finish)]) + (send context-text lock #t) + (send context-text hide-caret #t) + (send text insert " ") + (let ([snip (make-object editor-snip% context-text)]) + (send snip use-style-background #t) + (send editor-canvas add-wide-snip snip) + (let ([p (send text last-position)]) + (send text insert snip p p) + (send text insert #\newline) + (when (preferences:get 'framework:white-on-black?) + (send text change-style white-on-black-style p (+ p 1)))))) + (close-text)))) + + (define white-on-black-style (make-object style-delta%)) + (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white")) + + ;; copy/highlight-text : text number number -> text + ;; copies the range from `start' to `finish', including the entire paragraph at + ;; each end and highlights the characters corresponding the original range, + ;; in the resulting text + (define (copy/highlight-text from-text start finish) + (let* ([to-text (new text:standard-style-list%)] + [para-start-pos (send from-text paragraph-start-position + (send from-text position-paragraph start))] + [para-end-pos (send from-text paragraph-end-position + (send from-text position-paragraph + finish))] + [from-start (- start para-start-pos)] + [from-end (+ from-start (- finish start))]) + (send from-text split-snip para-start-pos) + (send from-text split-snip para-end-pos) + (let loop ([snip (send from-text find-snip para-start-pos 'after-or-none)]) + (when (and snip + (< (send from-text get-snip-position snip) para-end-pos)) + (send to-text insert (send snip copy)) + (loop (send snip next)))) + (send to-text highlight-range (max 0 (- from-start 1)) from-end (get-error-color) #f #f 'high) + to-text)) + + ;; get-filename : debug-source -> string + (define (get-filename file) + (cond + [(symbol? file) (symbol->string file)] + [(path? file) (path->string file)] + [(is-a? file editor<%>) + (get-filename-from-editor file)])) + + ;; get-filename-from-editor : (is-a?/c editor<%>) -> string + (define (get-filename-from-editor editor) + (let* ([untitled (string-constant unknown-debug-frame)] + [canvas (send editor get-canvas)] + [frame (and canvas (send canvas get-top-level-window))]) + (if (is-a? frame drscheme:unit:frame%) + (let ([filename (send (send frame get-definitions-text) get-filename)]) + (cond + [(and filename (eq? editor (send frame get-interactions-text))) + (format (string-constant files-interactions) filename)] + [(eq? editor (send frame get-interactions-text)) + (string-constant current-interactions)] + [filename filename] + [else (string-constant current-definitions)])) + (or (send editor get-filename) + untitled)))) + + ;; open-and-highlight-in-file : srcloc -> void + (define (open-and-highlight-in-file srclocs) + (let ([sources (filter values (map srcloc-source srclocs))]) + (unless (null? sources) + (let* ([debug-source (car sources)] + [same-src-srclocs + (filter (λ (x) (eq? debug-source (srcloc-source x))) + srclocs)] + [frame (cond + [(path? debug-source) (handler:edit-file debug-source)] + [(is-a? debug-source editor<%>) + (let ([canvas (send debug-source get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [else #f])] + [editor (cond + [(path? debug-source) + (cond + [(and frame (is-a? frame drscheme:unit:frame%)) + (send frame get-definitions-text)] + [(and frame (is-a? frame frame:editor<%>)) + (send frame get-editor)] + [else #f])] + [(is-a? debug-source editor<%>) debug-source])] + [rep (and (is-a? frame drscheme:unit:frame%) + (send frame get-interactions-text))]) + (when frame + (send frame show #t)) + (when (and rep editor) + (when (is-a? editor text:basic<%>) + (send rep highlight-errors same-src-srclocs '()) + (send editor set-caret-owner #f 'global))))))) + + + + ; + ; + ; + ; + ; + ; ; ; + ; ;;;; ;;; ;;; ;;;; ;;; ;;; ; ; ;;; ; ; ;;; ;; ; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; + ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;;;; ;; ; ; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; + ; ;; ;;;; ;;; ;; ;;; ;;; ; ;;;; ; ;;;;; ;; ; ;;;; + ; ; + ; ; ; + ; ;;;; + + + (define test-coverage-enabled (make-parameter #f)) + + (define current-test-coverage-info (make-thread-cell #f)) + + (define (initialize-test-coverage-point key expr) + (unless (hash? (thread-cell-ref current-test-coverage-info)) + (let ([rep (drscheme:rep:current-rep)]) + (when rep + (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) + (when (eq? ut (current-thread)) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-test-coverage-info ht) + (send rep set-test-coverage-info ht))))))) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when (hash? ht) + ;; if rep isn't around, we don't do test coverage... + ;; this can happen when check syntax expands, for example + (hash-set! ht key (mcons #f expr))))) + + (define (test-covered key) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point' + (let ([v (hash-ref ht key)]) + (set-mcar! v #t))))) + + (define test-coverage-interactions-text<%> + (interface () + set-test-coverage-info + get-test-coverage-info)) + + (define test-coverage-tab<%> + (interface () + show-test-coverage-annotations ;; hash-table (union #f style) (union #f style) boolean -> void + get-test-coverage-info-visible? + ask-about-clearing-test-coverage?)) + + (define test-coverage-interactions-text-mixin + (mixin (drscheme:rep:text<%> text:basic<%>) (test-coverage-interactions-text<%>) + (inherit get-context) + (field [test-coverage-info #f] + [test-coverage-on-style #f] + [test-coverage-off-style #f] + [ask-about-reset? #f]) + (define/public set-test-coverage-info + (λ (ht [on-style #f] [off-style #f] [ask? #t]) + (set! test-coverage-info ht) + (set! test-coverage-on-style on-style) + (set! test-coverage-off-style off-style) + (set! ask-about-reset? ask?))) + (define/public (get-test-coverage-info) + test-coverage-info) + + (inherit get-top-level-window) + (define/augment (after-many-evals) + (when test-coverage-info + (send (get-context) show-test-coverage-annotations + test-coverage-info + test-coverage-on-style + test-coverage-off-style + ask-about-reset?)) + (inner (void) after-many-evals)) + + (super-new))) + + (define test-coverage-definitions-text-mixin + (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () + (inherit get-canvas get-tab) + + (define/private (clear-test-coverage?) + (if (preferences:get 'drscheme:test-coverage-ask-about-clearing?) + (let ([msg-box-result + (message-box/custom + (string-constant drscheme) + (string-constant test-coverage-clear?) + (string-constant yes) + (string-constant no) + (string-constant test-coverage-clear-and-do-not-ask-again) + (send (get-canvas) get-top-level-window) + '(default=1) + 2)]) + (case msg-box-result + [(1) #t] + [(2) #f] + [(3) + (preferences:set 'drscheme:test-coverage-ask-about-clearing? #f) + #t])) + #t)) + + (define/public (clear-test-coverage) + (let ([tab (get-tab)]) + (when (send tab get-test-coverage-info-visible?) + (send tab clear-test-coverage-display) + (let ([it (send tab get-ints)]) + (when (is-a? it test-coverage-interactions-text<%>) + (send it set-test-coverage-info #f)))))) + + (define/private (can-clear-coverage?) + (let ([tab (get-tab)]) + (or (not tab) + (not (send tab get-test-coverage-info-visible?)) + (not (send tab ask-about-clearing-test-coverage?)) + (clear-test-coverage?)))) + + (define/augment (can-insert? x y) + (and (inner #t can-insert? x y) + (can-clear-coverage?))) + + (define/augment (can-delete? x y) + (and (inner #t can-delete? x y) + (can-clear-coverage?))) + + (define/augment (after-insert x y) + (inner (void) after-insert x y) + (clear-test-coverage)) + + (define/augment (after-delete x y) + (inner (void) after-delete x y) + (clear-test-coverage)) + + (super-new))) + + (define test-covered-style-delta (make-object style-delta%)) + (send test-covered-style-delta set-delta-foreground "forest green") + + (define test-not-covered-style-delta (make-object style-delta%)) + (send test-not-covered-style-delta set-delta-foreground "firebrick") + + (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color)) + + (define test-coverage-tab-mixin + (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) (test-coverage-tab<%>) + + (field [internal-clear-test-coverage-display #f]) + + (define/public (clear-test-coverage-display) + (when internal-clear-test-coverage-display + (internal-clear-test-coverage-display) + (set! internal-clear-test-coverage-display #f))) + + (field [ask-about-reset? #t]) + (define/public (ask-about-clearing-test-coverage?) ask-about-reset?) + + (define/public (get-test-coverage-info-visible?) + (not (not internal-clear-test-coverage-display))) + + (define/public (show-test-coverage-annotations ht on-style off-style ask?) + (set! ask-about-reset? ask?) + (let* ([edit-sequence-ht (make-hasheq)] + [locked-ht (make-hasheq)] + [already-frozen-ht (make-hasheq)] + [actions-ht (make-hash)] + [on/syntaxes (hash-map ht (λ (_ pr) pr))] + + ;; can-annotate : (listof (list boolean srcloc)) + ;; boolean is #t => code was run + ;; #f => code was not run + ;; remove those that cannot be annotated + [can-annotate + (filter values + (map (λ (pr) + (let ([stx (mcdr pr)]) + (and (syntax? stx) + (let ([src (syntax-source stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (and pos + span + (send (get-defs) port-name-matches? src) + (list (mcar pr) (make-srcloc (get-defs) #f #f pos span))))))) + on/syntaxes))] + + ;; filtered : (listof (list boolean srcloc)) + ;; remove redundant expressions + [filtered + (let (;; actions-ht : (list src number number) -> (list boolean syntax) + [actions-ht (make-hash)]) + (for-each + (λ (pr) + (let* ([on? (list-ref pr 0)] + [key (list-ref pr 1)] + [old (hash-ref actions-ht key 'nothing)]) + (cond + [(eq? old 'nothing) (hash-set! actions-ht key on?)] + [old ;; recorded as executed + (void)] + [(not old) ;; recorded as unexected + (when on? + (hash-set! actions-ht key #t))]))) + can-annotate) + (hash-map actions-ht (λ (k v) (list v k))))]) + + ;; if everything is covered *and* no coloring has been done, do no coloring. + (unless (and (andmap car filtered) + (not (get-test-coverage-info-visible?))) + + (let (;; sorted : (listof (list boolean srcloc)) + ;; sorting predicate: + ;; x < y if + ;; x's span is bigger than y's (ie, do larger expressions first) + ;; unless x and y are the same source location. + ;; in that case, color red first and then green + [sorted + (sort + filtered + (λ (x y) + (let* ([x-on (list-ref x 0)] + [y-on (list-ref y 0)] + [x-srcloc (list-ref x 1)] + [y-srcloc (list-ref y 1)] + [x-pos (srcloc-position x-srcloc)] + [y-pos (srcloc-position y-srcloc)] + [x-span (srcloc-span x-srcloc)] + [y-span (srcloc-span y-srcloc)]) + (cond + [(and (= x-pos y-pos) + (= x-span x-span)) + (or y-on + (not x-on))] + [else (>= x-span y-span)]))))]) + + ;; turn on edit-sequences in all editors to be touched by new annotations + ;; also fill in the edit-sequence-ht + (for-each + (λ (pr) + (let ([src (srcloc-source (list-ref pr 1))]) + (hash-ref + edit-sequence-ht + src + (λ () + (hash-set! edit-sequence-ht src #f) + (send src begin-edit-sequence #f) + (when (send src is-locked?) + (hash-set! locked-ht src #t) + (send src lock #f)))))) + sorted) + + ;; clear out old annotations (and thaw colorers) + (when internal-clear-test-coverage-display + (internal-clear-test-coverage-display) + (set! internal-clear-test-coverage-display #f)) + + ;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw) + (hash-for-each + edit-sequence-ht + (λ (src _) + (if (send src is-frozen?) + (hash-set! already-frozen-ht src #t) + (send src freeze-colorer)))) + + ;; set new annotations + (for-each + (λ (pr) + (let ([on? (list-ref pr 0)] + [srcloc (list-ref pr 1)]) + (let* ([src (srcloc-source srcloc)] + [pos (srcloc-position srcloc)] + [span (srcloc-span srcloc)]) + (send src change-style + (if on? + (or on-style test-covered-style-delta) + (or off-style test-not-covered-style-delta)) + (- pos 1) + (+ (- pos 1) span) + #f)))) + sorted) + + ;; relock editors + (hash-for-each + locked-ht + (λ (txt _) (send txt lock #t))) + + ;; end edit sequences + (hash-for-each + edit-sequence-ht + (λ (txt _) (send txt end-edit-sequence))) + + ;; save thunk to reset these new annotations + (set! internal-clear-test-coverage-display + (λ () + (hash-for-each + edit-sequence-ht + (λ (txt _) + (send txt begin-edit-sequence #f))) + (hash-for-each + edit-sequence-ht + (λ (txt _) + (let ([locked? (send txt is-locked?)]) + (when locked? (send txt lock #f)) + (send txt change-style + erase-test-coverage-style-delta + 0 + (send txt last-position) + #f) + (when locked? (send txt lock #t))))) + (hash-for-each + edit-sequence-ht + (λ (txt _) + (unless (hash-ref already-frozen-ht txt #f) + (let ([locked? (send txt is-locked?)]) + (when locked? (send txt lock #f)) + (send txt thaw-colorer) + (when locked? (send txt lock #t)))) + (send txt end-edit-sequence))))))))) + + (inherit get-defs) + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (send (get-defs) clear-test-coverage)) + + (super-new))) + + + + + + ; + ; + ; ;;; ;;; + ; ; ; ; ; + ; ; ; + ; ; ;; ; ;;; ;;; ;;;;;; ;;; ; ;;; ; ;; ;; ; + ; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; + ; ; ;; ; ;;; ; ; ; ; ; ; ;; ; + ; ; ; + ; ; ;;; + ; + + + (define profile-key (gensym)) + + ;; prof-info = + ;; (make-prof-info + ;; boolean ;; protect against nested calls + ;; number[number of calls] + ;; number[time spent in all calls] + ;; (union #f symbol) + ;; expression) + (define-struct prof-info (nest num time name expr) #:mutable) + + ;; copy-prof-info : prof-info -> prof-info + (define (copy-prof-info prof-info) + (make-prof-info (prof-info-nest prof-info) + (prof-info-num prof-info) + (prof-info-time prof-info) + (prof-info-name prof-info) + (prof-info-expr prof-info))) + + ;; any-info? : prof-info -> boolean + (define (any-info? prof-info) + (or (not (zero? (prof-info-num prof-info))) + (not (zero? (prof-info-time prof-info))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; profiling runtime support + + ;; parameter + ;; imported into errortrace + (define profiling-enabled (make-parameter #f)) + + ;; holds a hash-table for the profiling information + (define current-profile-info (make-thread-cell #f)) + + + ;; initialize-profile-point : sym syntax syntax -> void + ;; called during compilation to register this point as + ;; a profile point. + ;; =user= + ;; imported into errortrace + (define (initialize-profile-point key name expr) + (unless (thread-cell-ref current-profile-info) + (let ([rep (drscheme:rep:current-rep)]) + (when rep + (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) + (when (eq? ut (current-thread)) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-profile-info ht) + (send (send rep get-context) add-profile-info ht))))))) + (let ([profile-info (thread-cell-ref current-profile-info)]) + (when profile-info + (hash-set! profile-info + key + (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) + (void)) + + ;; register-profile-start : sym -> (union #f number) + ;; =user= + ;; imported into errortrace + (define (register-profile-start key) + (let ([ht (thread-cell-ref current-profile-info)]) + (when ht + (let ([info (hash-ref ht key)]) + (set-prof-info-num! info (+ (prof-info-num info) 1)) + (if (prof-info-nest info) + #f + (begin + (set-prof-info-nest! info #t) + (current-process-milliseconds))))))) + + ;; register-profile-done : sym (union #f number) -> void + ;; =user= + ;; imported into errortrace + (define (register-profile-done key start) + (when start + (let ([ht (thread-cell-ref current-profile-info)]) + (when ht + (let ([info (hash-ref ht key)]) + (set-prof-info-nest! info #f) + (set-prof-info-time! info + (+ (- (current-process-milliseconds) start) + (prof-info-time info))))))) + (void)) + + (define (get-color-value/pref val max-val drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale) + (let* ([adjust + (case drscheme:profile:scale + [(sqrt) sqrt] + [(square) (λ (x) (* x x))] + [(linear) (λ (x) x)])] + [factor (adjust (if (zero? max-val) 0 (/ val max-val)))] + [get-rgb-value + (λ (sel) + (let ([small (sel drscheme:profile:low-color)] + [big (sel drscheme:profile:high-color)]) + (inexact->exact (floor (+ (* factor (- big small)) small)))))]) + (make-object color% + (get-rgb-value (λ (x) (send x red))) + (get-rgb-value (λ (x) (send x green))) + (get-rgb-value (λ (x) (send x blue)))))) + + ;; get-color-value : number number -> (is-a?/c color%) + ;; returns the profiling color + ;; for `val' if `max-val' is the largest + ;; of any profiling amount. + (define (get-color-value val max-val) + (get-color-value/pref val + max-val + (preferences:get 'drscheme:profile:low-color) + (preferences:get 'drscheme:profile:high-color) + (preferences:get 'drscheme:profile:scale))) + + ;; extract-maximum : (listof prof-info) -> number + ;; gets the maximum value of the currently preferred profiling info. + (define (extract-maximum infos) + (let ([max-value 0] + [sel (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) + prof-info-time + prof-info-num)]) + (for-each + (λ (val) + (set! max-value (max max-value (sel val)))) + infos) + max-value)) + + ;; profile-definitions-mixin : mixin + (define profile-definitions-text-mixin + (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () + (inherit get-canvas get-tab) + + (define/augment (can-insert? x y) + (and (inner #t can-insert? x y) + (can-reset-profile?))) + + (define/augment (can-delete? x y) + (and (inner #t can-delete? x y) + (can-reset-profile?))) + + (define/augment (on-insert x y) + (inner (void) on-insert x y) + (do-reset-profile)) + + (define/augment (on-delete x y) + (inner (void) on-delete x y) + (do-reset-profile)) + + (define/private (can-reset-profile?) + (let ([canvas (get-canvas)]) + (or (not canvas) + (let ([frame (send canvas get-top-level-window)]) + (or (not (send frame get-profile-info-visible?)) + (eq? (message-box (string-constant drscheme) + (string-constant profiling-clear?) + frame + '(yes-no)) + 'yes)))))) + + (define/private (do-reset-profile) + (send (get-tab) reset-profile)) + + (super-new))) + + (define profile-interactions-tab<%> + (interface () + add-profile-info)) + + (define-local-member-name + + ;; tab methods + reset-profile ;; erases profile display & information + hide-profile ;; hides profiling info, but it is still here to be shown again + show-profile ;; shows the profile info, if there is any to show + refresh-profile ;; shows current info in profile window + get-profile-info-text + can-show-profile? + get-sort-mode ;; indicates if the results are currently shown sorted by time, or not + set-sort-mode ;; updates the sort mode flag (only called by the gui control callback) + + ;; frame methods + hide-profile-gui + show-profile-gui + + ;; frame and tab methods + get-profile-info-visible? + ; on frame, indicates if the gui stuff shows up currently + ; on tab, indicates if the user has asked for the gui to show up. + ) + + (define profile-tab-mixin + (mixin (drscheme:unit:tab<%>) (profile-interactions-tab<%>) + (define profile-info-visible? #f) + (define/public (get-profile-info-visible?) profile-info-visible?) + + (define sort-mode (preferences:get 'drscheme:profile-how-to-count)) + (define/public (get-sort-mode) sort-mode) + (define/public (set-sort-mode mode) (set! sort-mode mode)) + + (inherit get-frame is-current-tab? get-defs) + ;; profile-info : (listof hashtable[symbol -o> prof-info]) + (define profile-info '()) + (define/public (add-profile-info ht) (set! profile-info (cons ht profile-info))) + + (define/public (show-profile) + (unless profile-info-visible? + (set! profile-info-visible? #t) + (send (get-frame) show-profile-gui))) + + (define/public (hide-profile) + (when profile-info-visible? + (set! profile-info-visible? #f) + (send profile-info-text clear-profile-display) + (when (is-current-tab?) + (send (get-frame) hide-profile-gui)))) + + (define/public (reset-profile) + (hide-profile) + (set! profile-info '())) + + (define/public (refresh-profile) + (send profile-info-text refresh-profile profile-info (get-defs))) + + ;; can-show-profile? : -> boolean + ;; indicates if there is any profiling information to be shown. + (define/public (can-show-profile?) + (let/ec esc-k + (for-each + (λ (ht) + (hash-for-each + ht + (λ (key v) + (when (any-info? v) + (esc-k #t))))) + profile-info) + #f)) + + (define profile-info-text (new profile-text% (tab this))) + (define/public (get-profile-info-text) profile-info-text) + + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (reset-profile)) + + (super-new))) + + ;; profile-unit-frame-mixin : mixin + ;; adds profiling to the unit frame + (define profile-unit-frame-mixin + (mixin (drscheme:unit:frame<%> drscheme:frame:<%>) () + + (inherit get-interactions-text get-current-tab) + + ;; update-shown : -> void + ;; updates the state of the profile item's show menu + (define/override (update-shown) + (super update-shown) + (send show-profile-menu-item set-label + (if profile-info-visible? + (string-constant profiling-hide-profile) + (string-constant profiling-show-profile)))) + + ;; add-show-menu-items : menu -> void + ;; adds the show profile menu item + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show-profile-menu-item + (instantiate menu:can-restore-menu-item% () + (label (string-constant profiling-hide-profile)) + (parent show-menu) + (callback + (λ (x y) + (show-profile-menu-callback)))))) + + (define show-profile-menu-item #f) + (define profile-gui-constructed? #f) + + ;; get-profile-info-visible? : -> boolean + ;; returns #t when the profiling information is visible in the frame. + (define/public (get-profile-info-visible?) profile-info-visible?) + + (field [profile-info-outer-panel #f]) + (define/override (make-root-area-container % parent) + (set! profile-info-outer-panel + (super make-root-area-container + vertical-panel% + parent)) + (make-object % profile-info-outer-panel)) + + (define/private (show-profile-menu-callback) + (cond + [profile-info-visible? + (send (get-current-tab) hide-profile)] + [(send (get-current-tab) can-show-profile?) + (send (get-current-tab) show-profile) + (send (get-current-tab) refresh-profile)] + [else + (message-box (string-constant drscheme) + (string-constant profiling-no-information-available))])) + + (define/public (hide-profile-gui) + (when profile-gui-constructed? + (when profile-info-visible? + (send profile-info-outer-panel change-children + (λ (l) + (remq profile-info-panel l))) + (set! profile-info-visible? #f) + (update-shown)))) + + (define/public (show-profile-gui) + (unless profile-info-visible? + (construct-profile-gui) + (send profile-info-outer-panel change-children + (λ (l) + (append (remq profile-info-panel l) + (list profile-info-panel)))) + (set! profile-info-visible? #t) + (send profile-info-editor-canvas set-editor (send (get-current-tab) get-profile-info-text)) + (send (get-current-tab) refresh-profile) + (update-shown))) + + (field (profile-info-visible? #f)) + + (define/augment (on-tab-change from-tab to-tab) + (inner (void) on-tab-change from-tab to-tab) + (cond + [(and (not profile-info-visible?) + (send to-tab get-profile-info-visible?)) + (show-profile-gui)] + [(and profile-info-visible? + (not (send to-tab get-profile-info-visible?))) + (hide-profile-gui)]) + (when profile-choice + (send profile-choice set-selection + (profile-mode->selection + (send to-tab get-sort-mode)))) + (when profile-info-editor-canvas + (send profile-info-editor-canvas set-editor + (and (send to-tab can-show-profile?) + (send to-tab get-profile-info-text))))) + + (super-new) + + (define profile-info-panel #f) + (define profile-info-editor-canvas #f) + (define profile-choice #f) + + (inherit begin-container-sequence end-container-sequence) + (define/private (construct-profile-gui) + (unless profile-gui-constructed? + (set! profile-gui-constructed? #t) + (begin-container-sequence) + (let () + (define _2 + (set! profile-info-panel (instantiate horizontal-panel% () + (parent profile-info-outer-panel) + (stretchable-height #f)))) + (define profile-left-side (instantiate vertical-panel% (profile-info-panel))) + (define _3 + (set! profile-info-editor-canvas (new canvas:basic% + (parent profile-info-panel) + (editor (send (get-current-tab) get-profile-info-text))))) + (define profile-message (instantiate message% () + (label (string-constant profiling)) + (parent profile-left-side))) + (define _4 + (set! profile-choice (instantiate radio-box% () + (label #f) + (parent profile-left-side) + (callback + (λ (x y) + (let ([mode (profile-selection->mode (send profile-choice get-selection))]) + (preferences:set 'drscheme:profile-how-to-count mode) + (send (get-current-tab) set-sort-mode mode) + (send (get-current-tab) refresh-profile)))) + (choices (list (string-constant profiling-time) + (string-constant profiling-number)))))) + (define _1 + (send profile-choice set-selection + (case (preferences:get 'drscheme:profile-how-to-count) + [(time) 0] + [(count) 1]))) + (define update-profile-button + (instantiate button% () + (label (string-constant profiling-update)) + (parent profile-left-side) + (callback + (λ (x y) + (send (get-current-tab) refresh-profile))))) + (define hide-profile-button + (instantiate button% () + (label (string-constant profiling-hide-profile)) + (parent profile-left-side) + (callback + (λ (x y) + (send (get-current-tab) hide-profile))))) + (send profile-choice set-selection + (profile-mode->selection (preferences:get 'drscheme:profile-how-to-count))) + + (send profile-left-side stretchable-width #f) + + (let ([wid (max (send update-profile-button get-width) + (send hide-profile-button get-width) + (send profile-choice get-width) + (send profile-message get-width))]) + (send update-profile-button min-width wid) + (send hide-profile-button min-width wid) + (send profile-choice min-width wid)) + (send profile-left-side set-alignment 'left 'center) + + ;; hide profiling info initially, but reflow the container + ;; so that the invisible children get the right size. + (send this reflow-container) + (send profile-info-outer-panel change-children + (λ (l) + (remq profile-info-panel l)))) + (end-container-sequence))))) + + (define (profile-selection->mode sel) + (case sel + [(0) 'time] + [(1) 'count])) + + (define (profile-mode->selection mode) + (case mode + [(time) 0] + [(count) 1])) + + ;; profile-text% : extends text:basic% + ;; this class keeps track of a single thread's + ;; profiling information. these methods are not + ;; to be called directly, but only by the frame class, since + ;; they do not completely implement the abstraction for the + ;; GUI. They only manage the profiling information reported + ;; in the bottom window + (define profile-text% + (class text:basic% + (init-field tab) + + ;; clear-profile-display : -> void + ;; clears out the GUI showing the profile results + (define/public (clear-profile-display) + (begin-edit-sequence) + (let ([locked? (is-locked?)]) + (lock #f) + (clear-old-results) + (erase) + (lock locked?) + (end-edit-sequence))) + + (inherit lock is-locked? + get-canvas hide-caret get-snip-location + begin-edit-sequence end-edit-sequence + erase insert) + + ;; clear-old-results : -> void + ;; removes the profile highlighting + (field [clear-old-results void]) + + ;; refresh-profile : (listof hashtable[...]) text% -> void + ;; does the work to erase any existing profile info + ;; and make new profiling info. + (define/public (refresh-profile profile-info definitions-text) + (begin-edit-sequence) + (lock #f) + (erase) + (clear-old-results) + (let* (;; must copy them here in case the program is still running + ;; and thus updating them. + [infos '()] + [_ (let loop ([profile-info profile-info]) + (cond + [(null? profile-info) (void)] + [else + (let ([ht (car profile-info)]) + (hash-for-each + ht + (λ (key val) + (when (any-info? val) + (set! infos (cons (copy-prof-info val) infos)))))) + (loop (cdr profile-info))]))] + + ;; each editor that gets some highlighting is put + ;; into this table and an edit sequence is begun for it. + ;; after all ranges are updated, the edit sequences are all closed. + [in-edit-sequence (make-hasheq)] + [clear-highlight void] + [max-value (extract-maximum infos)] + [show-highlight + (λ (info) + (let* ([expr (prof-info-expr info)] + [src (and (syntax-source expr) + (send definitions-text port-name-matches? (syntax-source expr)) + definitions-text)] + [pos (syntax-position expr)] + [span (syntax-span expr)]) + (when (and (is-a? src text:basic<%>) + (number? pos) + (number? span)) + (unless (hash-ref in-edit-sequence src (λ () #f)) + (hash-set! in-edit-sequence src #t) + (send src begin-edit-sequence)) + (let* ([color (get-color-value + (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) + (prof-info-time info) + (prof-info-num info)) + max-value)] + [clr (send src highlight-range (- pos 1) (+ pos span -1) color)]) + (let ([old-thnk clear-highlight]) + (set! clear-highlight + (λ () + (clr) + (old-thnk))))))))] + [smaller-range? + (λ (x y) + (let ([x-span (syntax-span (prof-info-expr x))] + [y-span (syntax-span (prof-info-expr y))]) + (if (and x-span y-span) + (< x-span y-span) + #f)))] + + [show-line + (λ (info newline? highlight-line?) + (let* ([expr (prof-info-expr info)] + [expr-src (syntax-source expr)] + [count (prof-info-num info)] + [time (prof-info-time info)] + [name (prof-info-name info)]) + (when newline? (send src-loc-editor insert "\n")) + (when highlight-line? (small-blank-line src-loc-editor)) + (let ([before (send src-loc-editor last-position)]) + (insert-profile-src-loc src-loc-editor expr name) + (let ([after (send src-loc-editor last-position)]) + (cond + [(string? expr-src) + (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) + (let ([after (send src-loc-editor last-position)]) + (send src-loc-editor set-clickback + before after + (λ (text start end) + (open-file-and-goto-position expr-src (syntax-position expr)))))] + [(is-a? expr-src editor:basic<%>) + (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) + (send src-loc-editor set-clickback + before after + (λ (text start end) + (let ([window (send expr-src get-top-level-window)] + [pos (syntax-position expr)]) + (when window (send window show #t)) + (when pos (send expr-src set-position (- pos 1))) + (send expr-src set-caret-owner #f 'global))))] + [else (void)]))) + + (when newline? (send time-editor insert "\n")) + (when highlight-line? (small-blank-line time-editor)) + (send time-editor insert (format "~a" time)) + (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right) + + (when newline? (send count-editor insert "\n")) + (when highlight-line? (small-blank-line count-editor)) + (send count-editor insert (format "~a" count)) + (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))] + + [bigger-value? + (λ (x y) + (let ([sel (if (eq? 'count (preferences:get 'drscheme:profile-how-to-count)) + prof-info-num + prof-info-time)]) + (> (sel x) (sel y))))] + + [cleanup-editor + (λ (ed) + (let* ([ed-admin (send ed get-admin)] + [snip (send ed-admin get-snip)] + [bl (box 0)] + [br (box 0)]) + (get-snip-location snip bl #f #f) + (get-snip-location snip br #f #t) + (let ([w (+ (- (unbox br) (unbox bl)) 4)]) + (send ed set-max-width w) + (send ed set-min-width w))) + (send ed hide-caret #t) + (send ed lock #t))] + + [top-infos (top 100 (sort infos bigger-value?))]) + (for-each show-highlight top-infos) + (initialize-editors) + (let loop ([infos top-infos] + [newline? #f] + [highlight-counter 0]) + (cond + [(null? infos) (void)] + [else + (show-line (car infos) newline? (and newline? (zero? highlight-counter))) + (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))])) + (cleanup-editor count-editor) + (cleanup-editor time-editor) + (cleanup-editor src-loc-editor) + + (hash-for-each + in-edit-sequence + (λ (key val) + (send key end-edit-sequence))) + (set! clear-old-results + (λ () + (hash-for-each + in-edit-sequence + (λ (key val) (send key begin-edit-sequence))) + (clear-highlight) + (hash-for-each + in-edit-sequence + (λ (key val) (send key end-edit-sequence))) + (set! clear-old-results void)))) + (lock #t) + (end-edit-sequence) + (let ([canvas (get-canvas)]) + (when canvas + (send canvas scroll-to 0 0 1 1 #t 'start)))) + + + ;; top : number (listof X) -> (listof X) + ;; extracts the first `n' elements from a list. + (define/private (top n lst) + (let loop ([n n] + [lst lst]) + (cond + [(null? lst) null] + [(= 0 n) null] + [else (cons (car lst) (loop (- n 1) (cdr lst)))]))) + + (field (src-loc-editor #f) + (time-editor #f) + (count-editor #f)) + (define/private (clear-editors) + (set! src-loc-editor #f) + (set! time-editor #f) + (set! count-editor #f)) + (define/private (initialize-editors) + (set! src-loc-editor (instantiate text% ())) + (set! time-editor (instantiate text% ())) + (set! count-editor (instantiate text% ())) + (send src-loc-editor set-styles-sticky #f) + (send time-editor set-styles-sticky #f) + (send count-editor set-styles-sticky #f) + (insert (instantiate editor-snip% (time-editor))) + (insert (instantiate editor-snip% (count-editor))) + (insert (instantiate editor-snip% (src-loc-editor))) + (insert-title (string-constant profiling-col-function) src-loc-editor) + (insert-title (string-constant profiling-col-time-in-msec) time-editor) + (insert-title (string-constant profiling-col-calls) count-editor)) + + (define/private (insert-title str txt) + (send txt insert str) + (send txt insert "\n") + (send txt change-style bold-delta 0 (- (send txt last-position) 1)) + (send txt set-paragraph-alignment 0 'center)) + + (super-new) + (hide-caret #t))) + + ;; format-percentage : number[0 <= n <= 1] -> string + ;; formats the number as a percentage string with trailing zeros, + ;; to 3 decimal places. + (define (format-percentage n) + (let* ([number-of-places 3] + [whole-part (floor (* n 100))] + [decimal-part (- (* n 100) whole-part)] + [truncated/moved-decimal-part (floor (* (expt 10 number-of-places) decimal-part))] + [pad + (λ (str) + (if ((string-length str) . < . number-of-places) + (string-append (make-string (- number-of-places (string-length str)) #\0) + str) + str))]) + (string-append (format "~a" whole-part) + "." + (pad (format "~a" truncated/moved-decimal-part))))) + + (define (small-blank-line txt) + (let ([before (send txt last-position)]) + (send txt insert "\n") + (let ([after (send txt last-position)]) + (send txt change-style small-font-style before after)))) + + (define small-font-style (make-object style-delta% 'change-size 6)) + + ;; bold-delta : style-delta + (define bold-delta (make-object style-delta% 'change-bold)) + + ;; insert-profile-src-loc : syntax name -> string + (define (insert-profile-src-loc editor stx name) + (cond + [name + (let ([before (send editor last-position)]) + (send editor insert (format "~a" name)))] + [else + (let* ([src (syntax-source stx)] + [filename + (cond + [(string? src) src] + [(is-a? src editor<%>) (get-filename-from-editor src)] + [else (string-constant profiling-unknown-src)])] + [col (syntax-column stx)] + [line (syntax-line stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)] + [src + (cond + [(and col line) + (format "~a: ~a.~a" filename line col)] + [pos + (format "~a: ~a" filename pos)] + [else + filename])]) + (send editor insert src))])) + + ;; open-file-and-goto-position : string (union #f number) -> void + (define (open-file-and-goto-position filename pos) + (let ([frame (handler:edit-file filename)]) + (when (and frame + pos + (is-a? frame drscheme:unit:frame%)) + (let ([defs (send frame get-definitions-text)]) + (send defs set-position (- pos 1)))))) + + ;; get-src-filename : tst -> (union #f string) + (define (get-src-filename src) + (cond + [(string? src) src] + [(is-a? src text%) + (send src get-filename)] + [else #f])) + + ;; get-src-loc : syntax -> string + (define (get-src-loc expr) + (cond + [(and (number? (syntax-line expr)) + (number? (syntax-column expr)) + (number? (syntax-span expr))) + (format " ~a.~a [~a]" + (syntax-line expr) + (syntax-column expr) + (syntax-span expr))] + [(and (number? (syntax-position expr)) + (number? (syntax-span expr))) + (format " ~a-~a" + (syntax-position expr) + (syntax-span expr))] + [else ""])) + + (define (add-prefs-panel) + (preferences:add-panel + (string-constant profiling) + (λ (s-parent) + (letrec ([parent (make-object vertical-panel% s-parent)] + [msg (make-object message% + (string-constant profiling-color-config) + parent)] + [hp (make-object horizontal-pane% parent)] + [low (make-object button% (string-constant profiling-low-color) hp + (λ (x y) (color-callback #t)))] + [color-bar (make-object color-bar% hp)] + [high (make-object button% (string-constant profiling-high-color) hp + (λ (x y) (color-callback #f)))] + + [scale (instantiate radio-box% () + (label (string-constant profiling-scale)) + (parent parent) + (callback (λ (x y) (scale-callback))) + (choices + (list (string-constant profiling-sqrt) + (string-constant profiling-linear) + (string-constant profiling-square))))] + + [color-callback + (λ (low?) + (let ([color (get-color-from-user + (if low? + (string-constant profiling-choose-low-color) + (string-constant profiling-choose-high-color)) + #f + (preferences:get + (if low? + 'drscheme:profile:low-color + 'drscheme:profile:high-color)))]) + (when color + (preferences:set + (if low? 'drscheme:profile:low-color 'drscheme:profile:high-color) + color))))] + [scale-callback + (λ () + (preferences:set + 'drscheme:profile:scale + (case (send scale get-selection) + [(0) 'sqrt] + [(1) 'linear] + [(2) 'square])))]) + (preferences:add-callback + 'drscheme:profile:scale + (λ (p v) + (send scale set-selection + (case v + [(sqrt) 0] + [(linear) 1] + [(square) 2])))) + (send parent set-alignment 'left 'center) + (send hp stretchable-height #f) + parent)))) + + (define color-bar% + (class canvas% + (inherit get-client-size get-dc) + (field [pen (make-object pen% "black" 1 'solid)] + [in-on-paint? #f]) + (define/override (on-paint) + (set! in-on-paint? #t) + (let* ([dc (get-dc)] + [dummy-pen (send dc get-pen)] + [drscheme:profile:low-color (preferences:get 'drscheme:profile:low-color)] + [drscheme:profile:high-color (preferences:get 'drscheme:profile:high-color)] + [drscheme:profile:scale (preferences:get 'drscheme:profile:scale)]) + (let-values ([(w h) (get-client-size)]) + (let loop ([n 0]) + (when (n . <= . w) + (send pen set-color + (get-color-value/pref n w drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale)) + (send dc set-pen pen) + (send dc draw-line n 0 n h) + (send dc set-pen dummy-pen) + (loop (+ n 1)))) + (let-values ([(tw th ta td) (send dc get-text-extent + (string-constant profiling-example-text))]) + (send dc draw-text + (string-constant profiling-example-text) + (floor (- (/ w 2) (/ tw 2))) + (floor (- (/ h 2) (/ th 2))))))) + (set! in-on-paint? #f)) + + ;; queue callbacks here so that the preferences + ;; values are actually set by the time on-paint + ;; is called. + (preferences:add-callback + 'drscheme:profile:scale + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + (preferences:add-callback + 'drscheme:profile:low-color + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + (preferences:add-callback + 'drscheme:profile:high-color + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + + (super-instantiate ()))) + + + + (define-values/invoke-unit/infer stacktrace@)) \ No newline at end of file diff --git a/collects/drscheme/private/drscheme-normal.ss b/collects/drscheme/private/drscheme-normal.ss new file mode 100644 index 0000000000..be42f76008 --- /dev/null +++ b/collects/drscheme/private/drscheme-normal.ss @@ -0,0 +1,280 @@ + +(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)) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss new file mode 100644 index 0000000000..53fb85803a --- /dev/null +++ b/collects/drscheme/private/drsig.ss @@ -0,0 +1,316 @@ + +(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^))))) + diff --git a/collects/drscheme/private/eval.ss b/collects/drscheme/private/eval.ss new file mode 100644 index 0000000000..87b5ad3f6e --- /dev/null +++ b/collects/drscheme/private/eval.ss @@ -0,0 +1,221 @@ + +(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))]))))) diff --git a/collects/drscheme/private/font.ss b/collects/drscheme/private/font.ss new file mode 100644 index 0000000000..6fe8d85e8d --- /dev/null +++ b/collects/drscheme/private/font.ss @@ -0,0 +1,218 @@ +(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)))))) diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss new file mode 100644 index 0000000000..12b55a20ee --- /dev/null +++ b/collects/drscheme/private/frame.ss @@ -0,0 +1,595 @@ + +#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))) diff --git a/collects/drscheme/private/get-extend.ss b/collects/drscheme/private/get-extend.ss new file mode 100644 index 0000000000..faa82d7040 --- /dev/null +++ b/collects/drscheme/private/get-extend.ss @@ -0,0 +1,84 @@ +#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%)) diff --git a/collects/drscheme/private/help-desk.ss b/collects/drscheme/private/help-desk.ss new file mode 100644 index 0000000000..b3ff09f57a --- /dev/null +++ b/collects/drscheme/private/help-desk.ss @@ -0,0 +1,77 @@ +#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) '()) diff --git a/collects/drscheme/private/init.ss b/collects/drscheme/private/init.ss new file mode 100644 index 0000000000..8127337e68 --- /dev/null +++ b/collects/drscheme/private/init.ss @@ -0,0 +1,51 @@ + +#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)))))))) diff --git a/collects/drscheme/private/insert-large-letters.ss b/collects/drscheme/private/insert-large-letters.ss new file mode 100644 index 0000000000..1ca789aa28 --- /dev/null +++ b/collects/drscheme/private/insert-large-letters.ss @@ -0,0 +1,172 @@ +#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) diff --git a/collects/drscheme/private/key.ss b/collects/drscheme/private/key.ss new file mode 100644 index 0000000000..2aedf9a5c9 --- /dev/null +++ b/collects/drscheme/private/key.ss @@ -0,0 +1,19 @@ +(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)))))))) diff --git a/collects/drscheme/private/label-frame-mred.ss b/collects/drscheme/private/label-frame-mred.ss new file mode 100644 index 0000000000..1f890364f2 --- /dev/null +++ b/collects/drscheme/private/label-frame-mred.ss @@ -0,0 +1,28 @@ +(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)))) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss new file mode 100644 index 0000000000..0ce1a6e989 --- /dev/null +++ b/collects/drscheme/private/language-configuration.ss @@ -0,0 +1,1784 @@ + +(module language-configuration mzscheme + (require mzlib/unit + (lib "hierlist.ss" "hierlist") + mzlib/class + mzlib/contract + mzlib/kw + mzlib/string + mzlib/struct + "drsig.ss" + string-constants + mred + framework + mzlib/list + mzlib/etc + mzlib/file + (lib "getinfo.ss" "setup") + syntax/toplevel) + + (define original-output (current-output-port)) + (define (printfo . args) (apply fprintf original-output args)) + + (provide language-configuration@) + + (define-unit language-configuration@ + (import [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:init: drscheme:init^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:app: drscheme:app^] + [prefix drscheme:tools: drscheme:tools^] + [prefix drscheme:help-desk: drscheme:help-desk^]) + (export drscheme:language-configuration/internal^) + + ;; settings-preferences-symbol : symbol + ;; this pref used to depend on `version', but no longer does. + (define settings-preferences-symbol 'drscheme:language-settings) + + ;; get-settings-preferences-symbol : -> symbol + (define (get-settings-preferences-symbol) settings-preferences-symbol) + + ;; default-language-position : (listof string) + ;; if a language is registered with this position, it is + ;; considered the default language + (define initial-language-position + (list (string-constant initial-language-category) + (string-constant no-language-chosen))) + + ;; languages : (listof (instanceof language<%>)) + ;; all of the languages supported in DrScheme + (define languages null) + + ;; add-language : (instanceof language%) -> void + ;; only allows addition on phase2 + ;; effect: updates `languages' + (define add-language + (opt-lambda (language [front? #f]) + + (drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2) + (for-each + (λ (i<%>) + (unless (is-a? language i<%>) + (error 'drscheme:language:add-language "expected language ~e to implement ~e, forgot to use drscheme:language:get-default-mixin ?" language i<%>))) + (drscheme:language:get-language-extensions)) + + (ensure-no-duplicate-numbers language languages) + (set! languages + (if front? + (cons language languages) + (append languages (list language)))))) + + (define (ensure-no-duplicate-numbers l1 languages) + (for-each + (λ (l2) + (when (equal? (send l1 get-language-numbers) + (send l2 get-language-numbers)) + (error 'drscheme:language-configuration:add-language + "found two languages with the same result from get-language-numbers: ~s, ~s and ~s" + (send l1 get-language-numbers) + (send l1 get-language-position) + (send l2 get-language-position)))) + languages)) + + ;; get-languages : -> (listof languages) + (define (get-languages) + (drscheme:tools:only-in-phase + 'drscheme:language-configuration:get-languages + 'init-complete) + languages) + + ;; get-default-language-settings : -> language-settings + ;; uses `default-language-position' to find the default language. + ;; if that language is not available, just takes the first language. + ;; if there are no languages defined yet, signal an error -- drscheme is in trouble. + (define (get-default-language-settings) + (when (null? languages) + (error 'get-default-language-settings "no languages registered!")) + (let ([lang (or (ormap (λ (x) + (and (equal? (send x get-language-position) + initial-language-position) + x)) + (get-languages)) + (first (get-languages)))]) + (make-language-settings lang (send lang default-settings)))) + + ;; type language-settings = (make-language-settings (instanceof language<%>) settings) + (define-struct language-settings (language settings)) + + + ; + ; + ; + ; ; ; ; ; + ; ; ; ; + ; ; ; ; + ; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; ;; ; ; ;;; ; ;;; ;; ; + ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; ; ; ; ;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; ;; ; ; ;;;;; ; ;;; ;; ; + ; ; ; ; + ; ; ; ; ; ; ; + ; ;;;; ;;;; ;;;; + + + ;; language-dialog : (boolean language-setting -> (union #f language-setting)) + ;; (boolean language-setting (union #f (instanceof top-level-window%)) + ;; -> + ;; (union #f language-setting)) + ;; allows the user to configure their language. The input language-setting is used + ;; as the defaults in the dialog and the output language setting is the user's choice + ;; todo: when button is clicked, ensure language is selected + (define language-dialog + (opt-lambda (show-welcome? language-settings-to-show [parent #f]) + (define ret-dialog% + (class dialog% + (define/override (on-subwindow-char receiver evt) + (case (send evt get-key-code) + [(escape) (cancel-callback)] + [(#\return numpad-enter) (enter-callback)] + [else (super on-subwindow-char receiver evt)])) + (super-instantiate ()))) + + (define dialog (instantiate ret-dialog% () + (label (if show-welcome? + (string-constant welcome-to-drscheme) + (string-constant language-dialog-title))) + (parent parent) + (style '(resize-border)))) + (define welcome-before-panel (instantiate horizontal-pane% () + (parent dialog) + (stretchable-height #f))) + (define language-dialog-meat-panel (make-object vertical-pane% dialog)) + + (define welcome-after-panel (instantiate vertical-pane% () + (parent dialog) + (stretchable-height #f))) + + (define button-panel (instantiate horizontal-pane% () + (parent dialog) + (stretchable-height #f))) + + ;; initialized below + (define ok-button #f) + (define cancel-button #f) + + ;; cancelled? : boolean + ;; flag that indicates if the dialog was cancelled. + (define cancelled? #t) + + ;; enter-callback : -> bool + ;; returns #f if no language is selected (so the event will be + ;; processed by the hierlist widget, which will toggle subtrees) + (define (enter-callback) + (cond [(get-selected-language) + (set! cancelled? #f) + (send dialog show #f)] + [else #f])) + + ;; ok-callback : -> void + ;; similar to the above, but shows an error dialog if no language os + ;; selected + (define (ok-callback) + (unless (enter-callback) + (message-box (string-constant drscheme) + (string-constant please-select-a-language)))) + + ;; cancel-callback : -> void + (define (cancel-callback) + (send dialog show #f)) + + ;; a handler for "ok"-related stuff + (define ok-handler + ;; this is called before the buttons are made: keep track of state + ;; in that case + (let ([enabled? #t]) + (define (enable! state) + (set! enabled? state) + (when ok-button (send ok-button enable state))) + (λ (msg) + (case msg + [(disable) (enable! #f)] + [(enable) (enable! #t)] + [(enable-sync) (enable! enabled?)] + [(execute) (enter-callback) (void)] + [else (error 'ok-handler "internal error (~e)" msg)])))) + + (define-values (get-selected-language get-selected-language-settings) + (fill-language-dialog language-dialog-meat-panel + button-panel + language-settings-to-show + #f + ok-handler)) + + ;; create ok/cancel buttons + (make-object horizontal-pane% button-panel) + (set!-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons button-panel + (λ (x y) (ok-callback)) + (λ (x y) (cancel-callback)))) + (ok-handler 'enable-sync) ; sync enable status now + (make-object grow-box-spacer-pane% button-panel) + + (when show-welcome? + (add-welcome dialog welcome-before-panel welcome-after-panel)) + + (send dialog stretchable-width #f) + (send dialog stretchable-height #t) + + (unless parent + (send dialog center 'both)) + (send dialog show #t) + (if cancelled? + #f + (make-language-settings + (get-selected-language) + (get-selected-language-settings))))) + + ;; fill-language-dialog : (vertical-panel panel language-setting -> language-setting) + ;; (union dialog #f) [...more stuff...] + ;; -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result]) + ;; allows the user to configure their language. The input language-setting is used + ;; as the defaults in the dialog and the output language setting is the user's choice + ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. + (define fill-language-dialog + (opt-lambda (parent show-details-parent language-settings-to-show + [re-center #f] + [ok-handler void]) ; en/disable button, execute it + + (define-values (language-to-show settings-to-show) + (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) + (cond + [(equal? initial-language-position (send request-lang-to-show get-language-position)) + (values (first (get-languages)) + (send (first (get-languages)) default-settings)) + (values #f #f)] + [else (values request-lang-to-show + (language-settings-settings language-settings-to-show))]))) + + ;; hier-list items that implement this interface correspond to + ;; actual language selections + (define hieritem-language<%> + (interface (hierarchical-list-item<%>) + selected)) + + (define selectable-hierlist% + (class hierarchical-list% + (init parent) + + (inherit get-selected) + (define/override (on-char evt) + (let ([code (send evt get-key-code)]) + (case code + [(up) (select-next sub1)] + [(down) (select-next add1)] + ;; right key is fine, but nicer to close after a left + [(left) (super on-char evt) + (cond [(get-selected) + => (λ (i) + (when (is-a? i hierarchical-list-compound-item<%>) + (send i close)))])] + [else (super on-char evt)]))) + + (inherit get-items) + + ;; select-next : (num -> num) -> void + ;; finds the next/prev leaf after the selected child on the open + ;; fringe using `inc' for a direction. + (define/private (select-next inc) + (define current (get-selected)) + (define (choose item) + (when current (send current select #f)) + (send item select #t) + ;; make it visible + (let loop ([item item]) + (let ([parent (send item get-parent)]) + (if parent + (loop parent) + (send item scroll-to)))) + (send item scroll-to)) + (define (selectable? item) + (and (send item get-allow-selection?) + ;; opened all the way to the top + (let loop ([p (send item get-parent)]) + (or (not p) + (and (send p is-open?) + (loop (send p get-parent))))))) + (let* ([fringe (get-fringe)] + [fringe-len (vector-length fringe)] + [n (if current + (let loop ([i (sub1 (vector-length fringe))]) + (cond [(< i 0) (error 'select-next "item not found in fringe")] + [(eq? current (vector-ref fringe i)) + (min (sub1 fringe-len) (max 0 (inc i)))] + [else (loop (sub1 i))])) + (modulo (inc fringe-len) (add1 fringe-len)))]) + ;; need to choose item n, but go on looking for one that is + ;; selectable and open + (let loop ([n n]) + (when (< -1 n fringe-len) + (let ([item (vector-ref fringe n)]) + (if (selectable? item) + (choose item) + (loop (inc n)))))))) + + (define cached-fringe #f) + (define/public (clear-fringe-cache) (set! cached-fringe #f)) + (define (get-fringe) + (unless cached-fringe + (let ([fringe + (let loop ([items (get-items)]) + (apply append + (map (λ (item) + (if (is-a? item hierarchical-list-compound-item<%>) + (cons item + (loop (send item get-items))) + (list item))) + items)))]) + (set! cached-fringe (list->vector fringe)))) + cached-fringe) + + (define/override (on-select i) + (if (and i (is-a? i hieritem-language<%>)) + (something-selected i) + (nothing-selected))) + ;; this is not used, since all lists are selectable + ;; (define/override (on-click i) + ;; (when (and i (is-a? i hierarchical-list-compound-item<%>)) + ;; (send i toggle-open/closed))) + ;; use this instead + (define/override (on-double-select i) + (when i + (cond [(is-a? i hierarchical-list-compound-item<%>) + (send i toggle-open/closed)] + [(is-a? i hieritem-language<%>) + (something-selected i) + (ok-handler 'execute)]))) + (super-instantiate (parent)))) + + (define outermost-panel (make-object horizontal-pane% parent)) + (define languages-hier-list (make-object selectable-hierlist% outermost-panel)) + (define details-outer-panel (make-object vertical-pane% outermost-panel)) + (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) + (define details-panel (make-object panel:single% details/manual-parent-panel)) + + (define one-line-summary-message (instantiate message% () + (parent parent) + (label "") + (stretchable-width #t))) + + (define no-details-panel (make-object vertical-panel% details-panel)) + + (define languages-table (make-hash-table)) + (define languages (get-languages)) + + ;; selected-language : (union (instanceof language<%>) #f) + ;; invariant: selected-language and get/set-selected-language-settings + ;; match the user's selection in the languages-hier-list. + ;; or #f if the user is not selecting a language. + (define selected-language #f) + ;; get/set-selected-language-settings (union #f (-> settings)) + (define get/set-selected-language-settings #f) + + (define details-computed? #f) + + ;; language-mixin : (implements language<%>) + ;; (-> (implements area-container<%>)) + ;; get/set + ;; -> + ;; ((implements hierlist<%>) -> (implements hierlist<%>)) + ;; a mixin that responds to language selections and updates the details-panel + (define (language-mixin language get-language-details-panel get/set-settings) + (λ (%) + (class* % (hieritem-language<%>) + (init-rest args) + (public selected) + (define (selected) + (let ([ldp (get-language-details-panel)]) + (when ldp + (send details-panel active-child ldp))) + (send one-line-summary-message set-label (send language get-one-line-summary)) + (send revert-to-defaults-button enable #t) + (set! get/set-selected-language-settings get/set-settings) + (set! selected-language language)) + (apply super-make-object args)))) + + ;; nothing-selected : -> void + ;; updates the GUI and selected-language and get/set-selected-language-settings + ;; for when no language is selected. + (define (nothing-selected) + (send revert-to-defaults-button enable #f) + (send details-panel active-child no-details-panel) + (send one-line-summary-message set-label "") + (set! get/set-selected-language-settings #f) + (set! selected-language #f) + (ok-handler 'disable) + (send details-button enable #f)) + + ;; something-selected : item -> void + (define (something-selected item) + (ok-handler 'enable) + (send details-button enable #t) + (send item selected)) + + ;; construct-details : (union (-> void) #f) + (define construct-details void) + + ;; add-language-to-dialog : (instanceof language<%>) -> void + ;; adds the language to the dialog + ;; opens all of the turn-down tags + ;; when `language' matches language-to-show, update the settings + ;; panel to match language-to-show, otherwise set to defaults. + (define (add-language-to-dialog language) + (let ([positions (send language get-language-position)] + [numbers (send language get-language-numbers)]) + + ;; don't show the initial language ... + (unless (equal? positions initial-language-position) + (unless (and (list? positions) + (list? numbers) + (pair? positions) + (pair? numbers) + (andmap number? numbers) + (andmap string? positions) + (= (length positions) (length numbers)) + ((length numbers) . >= . 1)) + (error 'drscheme:language + "languages position and numbers must be lists of strings and numbers, respectively, must have the same length, and must each contain at least one element, got: ~e ~e" + positions numbers)) + + (when (null? (cdr positions)) + (unless (equal? positions (list "Module")) + (error 'drscheme:language + "Only the module language may be at the top level. Other languages must have at least two levels"))) + + (send languages-hier-list clear-fringe-cache) + + #| + + inline the first level of the tree into just items in the hierlist + keep track of the starting (see call to sort method below) by + adding a second field to the second level of the tree that indicates + what the sorting number is for its level above (in the second-number mixin) + + |# + + (let add-sub-language ([ht languages-table] + [hier-list languages-hier-list] + [positions positions] + [numbers numbers] + [first? #t] + [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number + (cond + [(null? (cdr positions)) + (let* ([language-details-panel #f] + [real-get/set-settings + (case-lambda + [() + (cond + [(and language-to-show + settings-to-show + (equal? (send language-to-show get-language-position) + (send language get-language-position))) + settings-to-show] + [else + (send language default-settings)])] + [(x) (void)])] + [get-language-details-panel (lambda () language-details-panel)] + [get/set-settings (lambda x (apply real-get/set-settings x))] + [position (car positions)] + [number (car numbers)] + [mixin (compose + number-mixin + (language-mixin language get-language-details-panel get/set-settings))] + [item + (send hier-list new-item + (if second-number + (compose second-number-mixin mixin) + mixin))] + [text (send item get-editor)] + [delta (send language get-style-delta)]) + + (set! construct-details + (let ([old construct-details]) + (lambda () + (old) + (let-values ([(language-details-panel-real get/set-settings) + (make-details-panel language)]) + (set! language-details-panel language-details-panel-real) + (set! real-get/set-settings get/set-settings)) + + (let-values ([(vis-lang vis-settings) + (cond + [(or (not selected-language) + (eq? selected-language language-to-show)) + (values language-to-show settings-to-show)] + [(and language-to-show settings-to-show) + (values selected-language + (send selected-language default-settings))] + [else (values #f #f)])]) + (cond + [(not vis-lang) (void)] + [(equal? (send vis-lang get-language-position) + (send language get-language-position)) + (get/set-settings vis-settings) + (send details-panel active-child language-details-panel)] + [else + (get/set-settings (send language default-settings))]))))) + + (send item set-number number) + (when second-number + (send item set-second-number second-number)) + (send text insert position) + (when delta + (cond + [(list? delta) + (for-each (λ (x) + (send text change-style + (car x) + (cadr x) + (caddr x))) + delta)] + [(is-a? delta style-delta%) + (send text change-style + (send language get-style-delta) + 0 + (send text last-position))])))] + [else (let* ([position (car positions)] + [number (car numbers)] + [sub-ht/sub-hier-list + (hash-table-get + ht + (string->symbol position) + (λ () + (if first? + (let* ([item (send hier-list new-item number-mixin)] + [x (list (make-hash-table) hier-list item)]) + (hash-table-put! ht (string->symbol position) x) + (send item set-number number) + (send item set-allow-selection #f) + (let* ([editor (send item get-editor)] + [pos (send editor last-position)]) + (send editor insert "\n") + (send editor insert position) + (send editor change-style small-size-delta pos (+ pos 1)) + (send editor change-style section-style-delta + (+ pos 1) (send editor last-position))) + x) + (let* ([new-list (send hier-list new-list + (if second-number + (compose second-number-mixin number-mixin) + number-mixin))] + [x (list (make-hash-table) new-list #f)]) + (send new-list set-number number) + (when second-number + (send new-list set-second-number second-number)) + (send new-list set-allow-selection #t) + (send new-list open) + (send (send new-list get-editor) insert position) + (hash-table-put! ht (string->symbol position) x) + x))))]) + (cond + [first? + (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (caddr sub-ht/sub-hier-list) get-number) + number))] + [else + (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (cadr sub-ht/sub-hier-list) get-number) + number))]) + (add-sub-language (car sub-ht/sub-hier-list) + (cadr sub-ht/sub-hier-list) + (cdr positions) + (cdr numbers) + #f + (if first? number #f)))]))))) + + (define number<%> + (interface () + get-number + set-number)) + + (define second-number<%> + (interface () + get-second-number + set-second-number)) + + ;; number-mixin : (extends object%) -> (extends object%) + ;; adds the get/set-number methods to this class + (define (number-mixin %) + (class* % (number<%>) + (field (number 0)) + (define/public (get-number) number) + (define/public (set-number _number) (set! number _number)) + (super-instantiate ()))) + + ;; second-number-mixin : (extends object%) -> (extends object%) + ;; adds the get/set-number methods to this class + (define (second-number-mixin %) + (class* % (second-number<%>) + (field (second-number 0)) + (define/public (get-second-number) second-number) + (define/public (set-second-number _second-number) (set! second-number _second-number)) + (super-instantiate ()))) + + ;; make-details-panel : ((instanceof language<%>) -> (values panel (case-> (-> settings) (settings -> void)))) + ;; adds a details panel for `language', using + ;; the language's default settings, unless this is + ;; the to-show language. + (define (make-details-panel language) + (let ([panel (instantiate vertical-panel% () + (parent details-panel) + (stretchable-width #f) + (stretchable-height #f))]) + (values + panel + (send language config-panel panel)))) + + ;; close-all-languages : -> void + ;; closes all of the tabs in the language hier-list. + (define (close-all-languages) + (define (close-children list) + (for-each close-this-one (send list get-items))) + (define (close-this-one item) + (cond + [(is-a? item hierarchical-list-compound-item<%>) + (send item close) + (close-children item)] + [else (void)])) + (close-children languages-hier-list)) + + ;; open-current-language : -> void + ;; opens the tabs that lead to the current language + ;; and selects the current language + (define (open-current-language) + (when (and language-to-show settings-to-show) + (let ([language-position (send language-to-show get-language-position)]) + (cond + [(null? (cdr language-position)) + ;; nothing to open here + ;; this should only be the module language + (send (car (send languages-hier-list get-items)) select #t) + (void)] + [else + (let loop ([hi languages-hier-list] + + ;; skip the first position, since it is flattened into the dialog + [first-pos (cadr language-position)] + [position (cddr language-position)]) + (let ([child + ;; know that this `car' is okay by construction of the dialog + (car + (filter (λ (x) + (equal? (send (send x get-editor) get-text) + first-pos)) + (send hi get-items)))]) + (cond + [(null? position) + (send child select #t)] + [else + (send child open) + (loop child (car position) (cdr position))])))])))) + + ;; docs-callback : -> void + (define (docs-callback) + (void)) + + ;; details-shown? : boolean + ;; indicates if the details are currently visible in the dialog + (define details-shown? (and language-to-show + settings-to-show + (not (send language-to-show default-settings? settings-to-show)))) + + ;; details-callback : -> void + ;; flips the details-shown? flag and resets the GUI + (define (details-callback) + (do-construct-details) + (set! details-shown? (not details-shown?)) + (when re-center + (send re-center begin-container-sequence)) + (update-show/hide-details) + (when re-center + (send re-center center 'both) + (send re-center end-container-sequence))) + + ;; do-construct-details : -> void + ;; construct the details panels, if they have not been constructed + (define (do-construct-details) + (when construct-details + (send details-button enable #f) + (construct-details) + (set! construct-details #f) + (send details-button enable #t))) + + ;; show/hide-details : -> void + ;; udpates the GUI based on the details-shown? flag + (define (update-show/hide-details) + (send details-button set-label + (if details-shown? hide-details-label show-details-label)) + (send parent begin-container-sequence) + (send revert-to-defaults-outer-panel change-children + (λ (l) + (if details-shown? (list revert-to-defaults-button) null))) + (send details-outer-panel change-children + (λ (l) + (if details-shown? (list details/manual-parent-panel) null))) + (send parent end-container-sequence)) + + ;; revert-to-defaults-callback : -> void + (define (revert-to-defaults-callback) + (when selected-language + (get/set-selected-language-settings + (send selected-language default-settings)))) + + (define show-details-label (string-constant show-details-button-label)) + (define hide-details-label (string-constant hide-details-button-label)) + (define details-button (make-object button% + (if (show-details-label . system-font-space->= . hide-details-label) + show-details-label + hide-details-label) + show-details-parent + (λ (x y) + (details-callback)))) + + (define revert-to-defaults-outer-panel (make-object horizontal-panel% show-details-parent)) + (define revert-to-defaults-button (make-object button% + (string-constant revert-to-language-defaults) + revert-to-defaults-outer-panel + (λ (_1 _2) + (revert-to-defaults-callback)))) + + (send revert-to-defaults-outer-panel stretchable-width #f) + (send revert-to-defaults-outer-panel stretchable-height #f) + (send outermost-panel set-alignment 'center 'center) + + (update-show/hide-details) + + (for-each add-language-to-dialog languages) + (send languages-hier-list sort + (λ (x y) + (cond + [(and (x . is-a? . second-number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-second-number) + (send y get-second-number)) + (< (send x get-number) (send y get-number))] + [else + (< (send x get-second-number) + (send y get-second-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-number) + (send y get-second-number)) + #t] + [else + (< (send x get-number) + (send y get-second-number))])] + [(and (x . is-a? . second-number<%>) + (y . is-a? . number<%>)) + (cond + [(= (send x get-second-number) + (send y get-number)) + #f] + [else (< (send x get-second-number) + (send y get-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . number<%>)) + (< (send x get-number) (send y get-number))] + [else #f]))) + + ;; remove the newline at the front of the first inlined category (if there) + ;; it won't be there if the module language is at the top. + (let ([t (send (car (send languages-hier-list get-items)) get-editor)]) + (when (equal? "\n" (send t get-text 0 1)) + (send t delete 0 1))) + + (send details-outer-panel stretchable-width #f) + (send details/manual-parent-panel change-children + (λ (l) + (list details-panel))) + + (send languages-hier-list stretchable-width #t) + (send languages-hier-list stretchable-height #t) + (send parent reflow-container) + (close-all-languages) + (open-current-language) + (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) + (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) + (when get/set-selected-language-settings + (get/set-selected-language-settings settings-to-show)) + (when details-shown? + (do-construct-details)) + (send languages-hier-list focus) + (values + (λ () selected-language) + (λ () + (and get/set-selected-language-settings + (get/set-selected-language-settings)))))) + + (define panel-background-editor-canvas% + (class editor-canvas% + (inherit get-dc get-client-size) + (define/override (on-paint) + (let-values ([(cw ch) (get-client-size)]) + (let* ([dc (get-dc)] + [old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (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 draw-rectangle 0 0 cw ch) + (send dc set-pen old-pen) + (send dc set-brush old-brush))) + (super on-paint)) + (super-new))) + + (define panel-background-text% + (class text% + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (when before? + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (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 draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top)) + (send dc set-pen old-pen) + (send dc set-brush old-brush))) + (super on-paint before? dc left top right bottom dx dy draw-caret)) + (super-new))) + + (define section-style-delta (make-object style-delta% 'change-bold)) + (send section-style-delta set-delta-foreground "medium blue") + (define small-size-delta (make-object style-delta% 'change-size 9)) + + (define (add-welcome dialog welcome-before-panel welcome-after-panel) + (let* ([outer-pb% + (class pasteboard% + (define/override (can-interactive-move? evt) + #f) + (super-instantiate ()))] + [outer-pb (make-object outer-pb%)] + [bitmap + (make-object bitmap% + (build-path (collection-path "icons") + "plt-small-shield.gif"))] + [image-snip + (make-object image-snip% + (build-path (collection-path "icons") + "plt-small-shield.gif"))] + [before-text (make-object text%)] + [before-snip (make-object editor-snip% before-text #f)] + [before-ec% + (class editor-canvas% + (inherit get-client-size) + (define/private (update-size) + (let-values ([(cw ch) (get-client-size)]) + (unless (or (zero? cw) + (zero? ch)) + (let ([image-l-box (box 0)] + [image-r-box (box 0)]) + (send before-text get-snip-location image-snip image-l-box #f #f) + (send before-text get-snip-location image-snip image-r-box #f #t) + (let* ([image-w (send bitmap get-width)] + [before-snip-space (- cw image-w)] + [before-snip-w (- before-snip-space + 5 5 ;; space before and after inside snip + 2 ;; space at end of outer editor + 1 ;; space at beginning of outer editor + 1 ;; space between image and snip + -5 ;; unknown space + )]) + (send before-text set-max-width (max 0 before-snip-w))))))) + (define/override (on-superwindow-show shown?) + (update-size) + (super on-superwindow-show shown?)) + (define/override (on-size w h) + (update-size) + (super on-size w h)) + (super-instantiate ()))] + [before-ec (instantiate before-ec% () + (parent welcome-before-panel) + (editor outer-pb) + (stretchable-height #f) + (style '(no-vscroll no-hscroll)))] + [first-line-style-delta (make-object style-delta% 'change-bold)]) + (send first-line-style-delta set-delta-foreground (make-object color% 150 0 150)) + (send before-ec min-width 550) + + (let-values ([(cw ch) (send before-ec get-client-size)] + [(w h) (send before-ec get-size)]) + (send before-ec min-height + (+ (send bitmap get-height) + 8 ;; pasteboards apparently want some space here.... + (- h ch)))) + + (send outer-pb insert image-snip) + (send outer-pb insert before-snip) + (send outer-pb move image-snip 0 0) + (send outer-pb move before-snip (send bitmap get-width) 0) + (send outer-pb set-selection-visible #f) + (send outer-pb lock #t) + + ;(send before-snip set-align-top-line #t) + (send before-text insert + (format (string-constant welcome-to-drscheme-version/language) + (version:version) + (this-language))) + (send before-text insert #\newline) + (send before-text insert (string-constant introduction-to-language-dialog)) + (send before-text change-style + first-line-style-delta + 0 + (send before-text paragraph-end-position 0)) + (send before-text auto-wrap #t) + + (send before-text lock #t) + (send before-text hide-caret #t) + + (for-each (λ (native-lang-string language) + (unless (equal? (this-language) language) + (instantiate button% () + (label native-lang-string) + (parent welcome-after-panel) + (stretchable-width #t) + (callback (λ (x1 x2) (drscheme:app:switch-language-to dialog language)))))) + (string-constants is-this-your-native-language) + (all-languages)))) + + ;; system-font-space->= : string string -> boolean + ;; determines which string is wider, when drawn in the system font + (define (x . system-font-space->= . y) + (let ([bdc (make-object bitmap-dc%)]) + (send bdc set-bitmap (make-object bitmap% 1 1 #t)) + (send bdc set-font (send the-font-list find-or-create-font + 12 'system 'normal 'normal)) + (let-values ([(wx _1 _2 _3) (send bdc get-text-extent x)] + [(wy _4 _5 _6) (send bdc get-text-extent y)]) + (wx . >= . wy)))) + + ;; text-width : (isntanceof text%) -> exact-integer + ;; calculates the width of widest line in the + ;; editor. This only makes sense if auto-wrap + ;; is turned off. Otherwise, you could just use + ;; the admin's width. + (define (text-width text) + (let loop ([n (+ (send text last-line) 1)] + [current-max-width 0]) + (cond + [(zero? n) + (+ + 10 ;; this should be some magic small constant (hopefully less than 10 on all platforms) + (floor (inexact->exact current-max-width)))] + [else (let* ([line-number (- n 1)] + [box (box 0.0)] + [eol-pos (send text line-end-position line-number)] + [eol-snip (send text find-snip eol-pos 'before)]) + (when eol-snip + (send text get-snip-location eol-snip box #f #t)) + (loop (- n 1) + (max current-max-width (unbox box))))]))) + + ;; text-height : (is-a?/c text% -> exact-integer + (define (text-height text) + (let ([y-box (box 0)]) + (send text position-location + (send text last-position) + #f + y-box + #f + #f + #t) + (+ 10 ;; upper bound on some platform specific space I don't know how to get. + (floor (inexact->exact (unbox y-box)))))) + + +; +; +; ; ;;; +; ; +; ;;; ;; ;; ;;;;; ;;; ;;;; ;;;; +; ; ;; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;;; ;;; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;; ; ; ; ; +; ;;;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;;;; +; +; +; +; +; +; +; ;; +; ; +; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; ;;;; +; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ; +; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; +; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; ;;;; +; ; ; +; ;;; ;;; +; +; + + (define (add-info-specified-languages) + (for-each add-info-specified-language + (find-relevant-directories '(drscheme-language-positions)))) + + (define (add-info-specified-language directory) + (let ([info-proc (get-info/full directory)]) + (when info-proc + (let* ([lang-positions (info-proc 'drscheme-language-positions (λ () null))] + [lang-modules (info-proc 'drscheme-language-modules (λ () null))] + [numberss (info-proc 'drscheme-language-numbers + (λ () + (map (λ (lang-position) + (map (λ (x) 0) lang-position)) + lang-positions)))] + [summaries (info-proc 'drscheme-language-one-line-summaries + (λ () + (map (λ (lang-position) "") + lang-positions)))] + [urls (info-proc 'drscheme-language-urls + (λ () + (map (λ (lang-position) "") + lang-positions)))] + [reader-specs + (info-proc 'drscheme-language-readers + (λ () + (map (λ (lang-position) #f) + lang-positions)))]) + (cond + [(and (list? lang-positions) + (andmap (λ (lang-position numbers) + (and (list? lang-position) + (pair? lang-position) + (andmap string? lang-position) + (list? numbers) + (andmap number? numbers) + (= (length numbers) + (length lang-position)))) + lang-positions + numberss) + (list? lang-modules) + (andmap (λ (x) + (or (string? x) + (and (list? x) + (andmap string? x)))) + lang-modules) + (list? summaries) + (andmap string? summaries) + + (list? urls) + (andmap string? urls) + + (list? reader-specs) + (andmap (λ (x) + ;; approximation (no good test, really) + ;; since it depends on the value of a mz + ;; parameter to interpret the module spec + (or (string? x) (eq? x #f) (symbol? x) (pair? x))) + reader-specs) + + (= (length lang-positions) + (length lang-modules) + (length summaries) + (length urls) + (length reader-specs))) + (for-each + (λ (lang-module lang-position lang-numbers one-line-summary url reader-spec) + (let ([% + ((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%)))] + [reader + (if reader-spec + (with-handlers ([exn:fail? + (λ (x) + (message-box (string-constant drscheme) + (if (exn? x) + (exn-message x) + (format "uncaught exception: ~s" x))) + read-syntax/namespace-introduce)]) + (contract + (opt-> () + (any/c port?) + (or/c syntax? eof-object?)) + (dynamic-require + (cond + [(string? reader-spec) + (build-path + directory + (platform-independent-string->path reader-spec))] + [else reader-spec]) + 'read-syntax) + (string->symbol (format "~s" lang-position)) + 'drscheme)) + read-syntax/namespace-introduce)]) + (add-language (instantiate % () + (module (if (string? lang-module) + (build-path + directory + (platform-independent-string->path lang-module)) + `(lib ,@lang-module))) + (language-position lang-position) + (language-id (format "plt:lang-from-module: ~s" lang-module)) + (language-numbers lang-numbers) + (one-line-summary one-line-summary) + (language-url url) + (reader reader))))) + lang-modules + lang-positions + numberss + summaries + urls + reader-specs)] + [else + (message-box + (string-constant drscheme) + (format + "The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers, and drscheme-language-readers specifications aren't correct. Expected (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string), (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same. Got ~e, ~e, ~e, ~e, ~e, and ~e" + lang-positions + lang-modules + numberss + summaries + urls + reader-specs))]))))) + + (define (platform-independent-string->path str) + (apply + build-path + (map (λ (x) + (cond + [(string=? ".." x) 'up] + [(string=? "." x) 'same] + [else x])) + (regexp-split #rx"/" str)))) + + (define read-syntax/namespace-introduce + (opt-lambda (source-name-v [input-port (current-input-port)]) + (let ([v (read-syntax source-name-v input-port)]) + (if (syntax? v) + (namespace-syntax-introduce v) + v)))) + + + +; +; +; ;; ; ;; ; +; ; ; ; +; ; ;; ;; ;; ;;; ; ;;;;; ;;; ;; ;; +; ;; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ;;;;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; ; ; ; ; +; ;;;;; ;; ;; ;;;;; ;;;;; ;;; ;;;;; ;;; ;;; +; +; +; +; +; +; +; ;; +; ; +; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; ;;;; +; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ; +; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; +; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; ;;;; +; ; ; +; ;;; ;;; +; +; + + + ;; add-expand-to-front-end : mixin + ;; overrides front-end to make the language a language that expands its arguments + (define (add-expand-to-front-end %) + (class % + (define/override (front-end/complete-program input settings) + (wrap-front-end (super front-end/complete-program input settings))) + (define/override (front-end/interaction input settings) + (wrap-front-end (super front-end/interaction input settings))) + (define/private (wrap-front-end thnk) + (λ () + (let ([res (thnk)]) + (cond + [(syntax? res) (with-syntax ([res res] + [expand-syntax-top-level-with-compile-time-evals + expand-syntax-top-level-with-compile-time-evals]) + #'(expand-syntax-top-level-with-compile-time-evals + (quote-syntax res)))] + [(eof-object? res) res] + [else `(expand ',res)])))) + (super-instantiate ()))) + + (define-struct (simple-settings+assume drscheme:language:simple-settings) (no-redef?)) + (define simple-settings+assume->vector (make-->vector simple-settings+assume)) + + (define (assume-mixin %) + (class % + (define/override (default-settings) + (extend-simple-settings (super default-settings) #t)) + + (define/override (marshall-settings settings) + (simple-settings+assume->vector settings)) + + (define/override (unmarshall-settings printable) + (and (vector? printable) + (= (vector-length printable) 7) + (let ([base + (super unmarshall-settings + (list->vector + (reverse + (cdr (reverse (vector->list printable))))))]) + (and base + (extend-simple-settings + base + (and (vector-ref printable 6) #t)))))) + + (define/override (config-panel parent) + (let ([p (new vertical-panel% [parent parent])]) + (let ([base-config (super config-panel p)] + [assume-cb (new check-box% + [parent + (new group-box-panel% + [parent p] + [label (string-constant enforce-primitives-group-box-label)] + [stretchable-height #f] + [stretchable-width #f])] + [label (string-constant enforce-primitives-check-box-label)])]) + (case-lambda + [() (extend-simple-settings (base-config) + (send assume-cb get-value))] + [(c) + (base-config c) + (send assume-cb set-value (simple-settings+assume-no-redef? c))])))) + + (define/override (default-settings? x) + (equal? (simple-settings+assume->vector x) + (simple-settings+assume->vector (default-settings)))) + + (define/private (extend-simple-settings s no-redef?) + (make-simple-settings+assume (drscheme:language:simple-settings-case-sensitive s) + (drscheme:language:simple-settings-printing-style s) + (drscheme:language:simple-settings-fraction-style s) + (drscheme:language:simple-settings-show-sharing s) + (drscheme:language:simple-settings-insert-newlines s) + (drscheme:language:simple-settings-annotations s) + no-redef?)) + + (define/override (use-namespace-require/copy-from-setting? s) + (not (simple-settings+assume-no-redef? s))) + + (super-new))) + + (define (r5rs-mixin %) + (class % + (define/override (on-execute setting run-in-user-thread) + (super on-execute setting run-in-user-thread) + (run-in-user-thread + (λ () + (read-square-bracket-as-paren #f) + (read-curly-brace-as-paren #f) + (read-accept-infix-dot #f) + (print-mpair-curly-braces #f) + (print-vector-length #f)))) + (define/override (get-transformer-module) #f) + + (define/override (default-settings) + (make-simple-settings+assume #f 'write 'mixed-fraction-e #f #t 'debug #t)) + + (super-new))) + + (define get-all-scheme-manual-keywords + (let ([words #f]) + (λ () + (unless words + (set! words (text:get-completions/manuals '(scheme/base scheme/contract)))) + words))) + + ;; add-built-in-languages : -> void + (define (add-built-in-languages) + (let* ([words #f] + [extras-mixin + (λ (mred-launcher? one-line-summary) + (λ (%) + (class* % (drscheme:language:language<%>) + (define/override (get-one-line-summary) one-line-summary) + (inherit get-module get-transformer-module get-init-code + use-namespace-require/copy-from-setting?) + (define/augment (capability-value key) + (cond + [(eq? key 'drscheme:autocomplete-words) + (get-all-scheme-manual-keywords)] + [else (drscheme:language:get-capability-default key)])) + (define/override (create-executable setting parent program-filename) + (let ([executable-fn + (drscheme:language:put-executable + parent + program-filename + #t + mred-launcher? + (if mred-launcher? + (string-constant save-a-mred-launcher) + (string-constant save-a-mzscheme-launcher)))]) + (when executable-fn + (drscheme:language:create-module-based-launcher + program-filename + executable-fn + (get-module) + (get-transformer-module) + (get-init-code setting) + mred-launcher? + (use-namespace-require/copy-from-setting? setting))))) + (super-new))))] + [make-simple + (λ (module id position numbers mred-launcher? one-line-summary extra-mixin) + (let ([% + (extra-mixin + ((extras-mixin mred-launcher? one-line-summary) + ((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%)))))]) + (instantiate % () + (module module) + (language-id id) + (language-position position) + (language-numbers numbers))))]) + (add-language + (make-simple '(lib "lang/plt-pretty-big.ss") + "plt:pretty-big" + (list (string-constant legacy-languages) + (string-constant pretty-big-scheme)) + (list -200 3) + #t + (string-constant pretty-big-scheme-one-line-summary) + assume-mixin)) + (add-language + (make-simple '(lib "r5rs/lang.ss") + "plt:r5rs" + (list (string-constant legacy-languages) + (string-constant r5rs-language-name)) + (list -200 -1000) + #f + (string-constant r5rs-one-line-summary) + (lambda (%) (r5rs-mixin (assume-mixin %))))) + + (add-language + (make-simple 'mzscheme + "plt:no-language-chosen" + (list (string-constant initial-language-category) + (string-constant no-language-chosen)) + (list 10000 1000) + #f + "Helps the user choose an initial language" + not-a-language-extra-mixin)))) + + (define (not-a-language-extra-mixin %) + (class* % (not-a-language-language<%>) + (define/override (get-style-delta) drscheme:rep:error-delta) + + (define/override (first-opened) + (not-a-language-message) + (fprintf (current-error-port) "\n")) + + (define/override (front-end/interaction input settings) + (not-a-language-message) + (λ () eof)) + (define/override (front-end/complete-program input settings) + (not-a-language-message) + (λ () eof)) + + (define/augment (capability-value v) + (case v + [(drscheme:check-syntax-button) #f] + [else (drscheme:language:get-capability-default v)])) + + (super-new))) + + ;; used for identification only + (define not-a-language-language<%> + (interface ())) + + + +; +; +; ;; +; ; ; +; ;; ;; ;;; ;;;;; ;;; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; +; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ;;;;; ;;;; ;;;;; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; +; ;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; +; ; ; +; ;;; ;;; +; +; + + + (define (not-a-language-message) + (define (main) + (when (language-still-unchanged?) + (o (green-snip (string-constant must-choose-language))) + (o "\n") + (o (green-snip (string-constant get-guidance-before))) + (o (new link-snip% + [words (string-constant get-guidance-during)] + [callback (lambda (snip) + (not-a-language-dialog (find-parent-from-snip snip)))])) + (o (green-snip (string-constant get-guidance-after))))) + + (define (green-snip str) + (let ([snp (make-object string-snip% str)]) + (send snp set-style green-style) + snp)) + + (define green-style + (let ([list (editor:get-standard-style-list)] + [green-style-delta (make-object style-delta% 'change-family 'default)]) + (send green-style-delta set-delta-foreground "DarkViolet") + (send green-style-delta set-delta 'change-italic) + (send list + find-or-create-style + (send list find-named-style "Standard") + green-style-delta))) + + (define (language-still-unchanged?) + (let ([rep (drscheme:rep:current-rep)]) + (cond + [rep + (let* ([next-settings (send (send rep get-definitions-text) get-next-settings)] + [next-lang (language-settings-language next-settings)]) + (is-a? next-lang not-a-language-language<%>))] + + ;; if we cannot get the REP + ;; (because a tool is processing the progrm like check syntax) + ;; then just assume it has not changed. + [else #t]))) + + (define o + (case-lambda + [(arg) + (cond + [(string? arg) + (fprintf (current-error-port) arg)] + [(is-a? arg snip%) + (write-special arg (current-error-port))])] + [args (apply fprintf (current-error-port) args)])) + + (define arrow-cursor (make-object cursor% 'arrow)) + + (define link-snip% + (class editor-snip% + (init-field words callback) + + (define/override (adjust-cursor dc x y editorx editory event) arrow-cursor) + + (define/override (on-event dc x y editorx editory event) + (when (send event button-up?) + (callback this))) + + (define/override (copy) + (new link-snip% [words words] [callback callback])) + + (define txt (new text:standard-style-list%)) + + (super-new [editor txt] [with-border? #f] + [left-margin 0] + [right-margin 0] + [top-margin 0] + [bottom-margin 0]) + (inherit get-flags set-flags set-style) + (set-flags (cons 'handles-events (get-flags))) + + (send txt insert words) + (send txt change-style link-sd 0 (send txt last-position)))) + + (define link-sd (make-object style-delta% 'change-underline #t)) + (define stupid-internal-define-syntax1 + (begin (send link-sd set-delta-foreground "blue") + (send link-sd set-family 'default))) + + (main)) + + (define (not-a-language-dialog drs-frame) + (define dialog (new dialog% + (parent drs-frame) + (label (string-constant drscheme)))) + (define qa-panel (new vertical-pane% (parent dialog))) + (define button-panel (new horizontal-pane% + (parent dialog) + (stretchable-height #f) + (alignment '(right center)))) + + (define cancel (new button% + (parent button-panel) + (callback (lambda (x y) (send dialog show #f))) + (label (string-constant cancel)))) + + (define language-chosen? #f) + + (define (main) + (insert-text-pls) + (display-plt-schemer) + (display-standard-schemer) + (space-em-out) + (fix-msg-sizes) + (send dialog show #t)) + + (define (insert-red-message) + (new canvas-message% + (parent qa-panel) + (font (get-font #:style 'italic)) + (label (string-constant must-choose-language)) + (color (send the-color-database find-color "red")))) + + (define (space-em-out) + (send qa-panel change-children + (lambda (l) + (cond + [(null? l) l] + [else + (let loop ([x (car l)] + [r (cdr l)]) + (cond + [(null? r) (list x)] + [else (list* x + (new vertical-pane% + (parent qa-panel) + (min-height 5) + (stretchable-height #f)) + (loop (car r) + (cdr r)))]))])))) + + (define (insert-text-pls) + (for-each + display-text-pl + (sort + (apply append (map get-text-pls (find-relevant-directories '(textbook-pls)))) + (λ (x y) + (cond + [(string=? (cadr x) (string-constant how-to-design-programs)) + #t] + [(string=? (string-constant how-to-design-programs) (cadr y)) + #f] + [else + (string<=? (cadr x) (cadr y))]))))) + + (define (display-plt-schemer) + (question/answer (lambda (parent) + (new canvas-message% + (parent parent) + (label (string-constant seasoned-plt-schemer?)))) + (list "Module") + (list "PLT-206-small.png" + "icons"))) + + (define (display-standard-schemer) + (question/answer (lambda (parent) + (new canvas-message% + (parent parent) + (label (string-constant looking-for-standard-scheme?)))) + (list (string-constant legacy-languages) + (string-constant plt) + (string-constant pretty-big-scheme)) + (list "r5rs.png" "icons"))) + + (define (display-text-pl lst) + (let ([icon-lst (car lst)] + [text-name (cadr lst)] + [lang (cddr lst)] + [using-before (string-constant using-a-textbook-before)] + [using-after (string-constant using-a-textbook-after)]) + (question/answer (lambda (parent) + (new canvas-message% + (parent parent) + (label using-before)) + (new canvas-message% + (parent parent) + (font (get-font #:style 'italic)) + (label text-name)) + (new canvas-message% + (parent parent) + (label using-after))) + lang + icon-lst))) + + (define default-font (send the-font-list find-or-create-font + 12 + 'default + 'normal + 'normal)) + + (define/kw (get-font #:key + (point-size (send default-font get-point-size)) + (family (send default-font get-family)) + (style (send default-font get-style)) + (weight (send default-font get-weight)) + (underlined (send default-font get-underlined)) + (smoothing (send default-font get-smoothing))) + (send the-font-list find-or-create-font + point-size + family + style + weight + underlined + smoothing)) + + (define canvas-message% + (class canvas% + (init-field label + [font (get-font)] + [callback void] + [color (send the-color-database find-color "black")]) + + (define/override (on-event evt) + (cond + [(send evt button-up?) + (callback)] + [else + (super on-event evt)])) + + (define/override (on-paint) + (let* ([dc (get-dc)] + [old-font (send dc get-font)] + [old-tf (send dc get-text-foreground)]) + (send dc set-text-foreground color) + (send dc set-font font) + (send dc draw-text label 0 0 #t) + (send dc set-font old-font) + (send dc set-text-foreground old-tf))) + + (super-new [stretchable-width #f] + [stretchable-height #f] + [style '(transparent)]) + + (inherit min-width min-height get-dc) + (let-values ([(w h _1 _2) (send (get-dc) get-text-extent label font #t)]) + (min-width (inexact->exact (floor w))) + (min-height (inexact->exact (floor h)))))) + + (define (question/answer line1 lang icon-lst) + (display-two-line-choice + icon-lst + lang + (λ (panel1 panel2) + (line1 panel1) + (new canvas-message% (parent panel2) (label (string-constant start-with-before))) + (new canvas-message% + (parent panel2) + (label (car (last-pair lang))) + (color (send the-color-database find-color "blue")) + (callback (λ () (change-current-lang-to lang))) + (font (get-font #:underlined #t))) + (new canvas-message% (parent panel2) (label (string-constant start-with-after)))))) + + ;; get-text-pls : path -> (listof (list* string string (listof string)) + ;; gets the questions from an info.ss file. + (define (get-text-pls info-filename) + (let ([proc (get-info/full info-filename)]) + (if proc + (let ([qs (proc 'textbook-pls)]) + (unless (list? qs) + (error 'splash-questions "expected a list, got ~e" qs)) + (for-each + (lambda (pr) + (unless (and (pair? pr) + (pair? (cdr pr)) + (pair? (cddr pr)) + (list? (cdddr pr)) + (let ([icon-lst (car pr)]) + (and (list? icon-lst) + (not (null? icon-lst)) + (andmap string? icon-lst))) + (andmap string? (cdr pr))) + (error + 'splash-questions + "expected a list of lists, with each inner list being at least three elements long and the first element of the inner list being a list of strings and the rest of the elements being strings, got ~e" + pr))) + qs) + qs) + '()))) + + (define msgs '()) + (define (fix-msg-sizes) + (let ([w (apply max (map (λ (x) (send x get-width)) msgs))]) + (for-each (λ (b) (send b min-width w)) + msgs))) + + (define (display-two-line-choice icon-lst lang proc) + (let* ([hp (new horizontal-pane% + (parent qa-panel) + (alignment '(center top)) + (stretchable-height #f))] + [msg (new message% + (label (make-object bitmap% + (build-path (apply collection-path (cdr icon-lst)) + (car icon-lst)) + 'unknown/mask)) + (parent hp))] + [vp (new vertical-pane% + (parent hp) + (alignment '(left top)) + (stretchable-height #f))]) + (set! msgs (cons msg msgs)) + (proc (new horizontal-pane% (parent vp)) + (new horizontal-pane% (parent vp))))) + + ;; change-current-lang-to : (listof string) -> void + ;; closed the guidance dialog and opens the language dialog + (define (change-current-lang-to lang-strings) + (send dialog show #f) + (let ([lang (ormap + (λ (x) + (and (equal? lang-strings (send x get-language-position)) + x)) + (get-languages))]) + (unless lang + (error 'change-current-lang-to "unknown language! ~s" lang-strings)) + + (let ([new-lang + (language-dialog #f + (make-language-settings lang + (send lang default-settings)) + drs-frame)]) + (when new-lang + (set! language-chosen? #t) + (preferences:set settings-preferences-symbol new-lang) + (send (send drs-frame get-definitions-text) set-next-settings new-lang))))) + + (main)) + + ;; find-parent-from-editor : editor -> (union frame #f) + (define (find-parent-from-editor ed) + (cond + [(send ed get-canvas) + => + (λ (c) (send c get-top-level-window))] + [else + (let ([admin (send ed get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (find-parent-from-snip (send admin get-snip))))])) + + ;; find-parent-from-snip : snip -> (union frame #f) + (define (find-parent-from-snip snip) + (let* ([admin (send snip get-admin)] + [ed (send admin get-editor)]) + (find-parent-from-editor ed))))) diff --git a/collects/drscheme/private/language-object-contract.ss b/collects/drscheme/private/language-object-contract.ss new file mode 100644 index 0000000000..dbb6eba60c --- /dev/null +++ b/collects/drscheme/private/language-object-contract.ss @@ -0,0 +1,94 @@ +#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?))))) + '()))))])) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss new file mode 100644 index 0000000000..eb3d691d4e --- /dev/null +++ b/collects/drscheme/private/language.ss @@ -0,0 +1,1171 @@ +;; WARNING: printf is rebound in this module to always use the +;; original stdin/stdout of drscheme, instead of the +;; user's io ports, to aid any debugging printouts. +;; (esp. useful when debugging the users's io) + +#lang scheme/unit +(require "drsig.ss" + string-constants + mzlib/pconvert + mzlib/pretty + mzlib/etc + mzlib/struct + mzlib/class + scheme/file + mzlib/list + compiler/embed + launcher + mred + framework + (lib "syntax-browser.ss" "mrlib") + compiler/distribute + compiler/bundle-dist + "rep.ss") + + (import [prefix drscheme:debug: drscheme:debug^] + [prefix drscheme:tools: drscheme:tools^] + [prefix drscheme:help-desk: drscheme:help-desk^]) + (export drscheme:language^) + + (define original-output-port (current-output-port)) + (define (printf . args) (apply fprintf original-output-port args)) + + (define-struct text/pos (text start end)) + ;; text/pos = (make-text/pos (instanceof text% number number)) + ;; this represents a portion of a text to be processed. + + (define language<%> + (interface () + marshall-settings + unmarshall-settings + default-settings + default-settings? + + front-end/complete-program + front-end/interaction + config-panel + on-execute + extra-repl-information + + first-opened + render-value/format + render-value + + capability-value + + create-executable + + get-reader-module + get-metadata + metadata->settings + get-metadata-lines + + get-language-position + get-language-name + get-style-delta + get-language-numbers + get-one-line-summary + get-language-url + get-comment-character)) + + (define module-based-language<%> + (interface () + marshall-settings + unmarshall-settings + default-settings + default-settings? + + get-module + get-transformer-module + use-namespace-require/copy? + use-namespace-require/copy-from-setting? + config-panel + + get-reader + + on-execute + get-init-code + use-mred-launcher + + render-value/format + render-value + + get-language-position + get-language-numbers + get-one-line-summary + get-language-url)) + + (define simple-module-based-language<%> + (interface () + get-module + get-language-position + get-language-numbers + get-one-line-summary + get-language-url + get-reader)) + + + (define simple-module-based-language% + (class* object% (simple-module-based-language<%>) + (init-field module + language-position + (language-numbers (map (λ (x) 0) language-position)) + (one-line-summary "") + (language-url #f) + (documentation-reference #f) + (reader (λ (src port) + (let ([v (parameterize ([read-accept-reader #t]) + (with-stacktrace-name + (read-syntax src port)))]) + (if (eof-object? v) + v + (namespace-syntax-introduce v))))) + (language-id (if (pair? language-position) + (car (last-pair language-position)) + (error 'simple-module-based-language<%> + "expected non-empty list of strings, got ~e" language-position)))) + (define/public (get-module) module) + (define/public (get-language-position) language-position) + (define/public (get-language-numbers) language-numbers) + (define/public (get-one-line-summary) one-line-summary) + (define/public (get-language-url) language-url) + (define/public (get-reader) reader) + (super-instantiate ()))) + + + + ;; simple-module-based-language->module-based-language : module-based-language<%> + ;; transforms a simple-module-based-language into a module-based-language<%> + (define simple-module-based-language->module-based-language-mixin + (mixin (simple-module-based-language<%>) (module-based-language<%>) + (define/public (get-transformer-module) 'mzscheme) + (define/public (use-namespace-require/copy?) #f) + (define/public (use-namespace-require/copy-from-setting? setting) + (use-namespace-require/copy?)) + (define/public (use-mred-launcher) #t) + + (inherit get-module) + (define/public (marshall-settings settings) + (simple-settings->vector settings)) + (define/public (unmarshall-settings printable) + (and (vector? printable) + (= (vector-length printable) + (procedure-arity make-simple-settings)) + (boolean? (vector-ref printable 0)) + (memq (vector-ref printable 1) '(constructor quasiquote write)) + (memq (vector-ref printable 2) + '(mixed-fraction + mixed-fraction-e + repeating-decimal + repeating-decimal-e)) + (boolean? (vector-ref printable 3)) + (boolean? (vector-ref printable 4)) + (memq (vector-ref printable 5) '(none debug debug/profile test-coverage)) + (apply make-simple-settings (vector->list printable)))) + (define/public (default-settings) + (make-simple-settings #t 'write 'mixed-fraction-e #f #t 'debug)) + (define/public (default-settings? x) + (equal? (simple-settings->vector x) + (simple-settings->vector (default-settings)))) + (define/public (config-panel parent) + (simple-module-based-language-config-panel parent)) + + (define/public (on-execute setting run-in-user-thread) + (initialize-simple-module-based-language setting run-in-user-thread)) + (define/public (get-init-code setting) + (simple-module-based-language-get-init-code setting)) + + (define/public (render-value/format value settings port width) + (simple-module-based-language-render-value/format value settings port width)) + (define/public (render-value value settings port) + (simple-module-based-language-render-value/format value settings port 'infinity)) + (super-instantiate ()))) + + ;; settings for a simple module based language + (define-struct simple-settings (case-sensitive + printing-style + fraction-style + show-sharing + insert-newlines + annotations)) + ;; case-sensitive : boolean + ;; printing-style : (union 'write 'constructor 'quasiquote) + ;; fraction-style : (union 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e) + ;; show-sharing : boolean + ;; insert-newlines : boolean + ;; annotations : (union 'none 'debug 'debug/profile 'test-coverage) + (define simple-settings->vector (make-->vector simple-settings)) + + ;; simple-module-based-language-config-panel : parent -> (case-> (-> settings) (settings -> void)) + (define (simple-module-based-language-config-panel _parent) + (letrec ([parent (instantiate vertical-panel% () + (parent _parent) + (alignment '(center center)))] + + [input-panel (instantiate group-box-panel% () + (label (string-constant input-syntax)) + (parent parent) + (alignment '(left center)))] + + [dynamic-panel (instantiate group-box-panel% () + (label (string-constant dynamic-properties)) + (parent parent) + (alignment '(left center)))] + + [output-panel (instantiate group-box-panel% () + (label (string-constant output-syntax)) + (parent parent) + (alignment '(left center)))] + + [case-sensitive (make-object check-box% + (string-constant case-sensitive-label) + input-panel + void)] + [debugging (instantiate radio-box% () + (label #f) + (choices + (list (string-constant no-debugging-or-profiling) + (string-constant debugging) + (string-constant debugging-and-profiling) + (string-constant test-coverage))) + (parent dynamic-panel) + (callback void))] + [output-style (make-object radio-box% + (string-constant output-style-label) + (list (string-constant constructor-printing-style) + (string-constant quasiquote-printing-style) + (string-constant write-printing-style)) + output-panel + (λ (rb evt) + (let ([on? (not (= (send rb get-selection) 3))]) + (send fraction-style enable on?) + (send show-sharing enable on?) + (send insert-newlines enable on?))))] + [fraction-style + (make-object check-box% (string-constant decimal-notation-for-rationals) + output-panel + void)] + [show-sharing (make-object check-box% + (string-constant sharing-printing-label) + output-panel + void)] + [insert-newlines (make-object check-box% + (string-constant use-pretty-printer-label) + output-panel + void)]) + + (case-lambda + [() + (make-simple-settings + (send case-sensitive get-value) + (case (send output-style get-selection) + [(0) 'constructor] + [(1) 'quasiquote] + [(2) 'write]) + (if (send fraction-style get-value) + 'repeating-decimal-e + 'mixed-fraction-e) + (send show-sharing get-value) + (send insert-newlines get-value) + (case (send debugging get-selection) + [(0) 'none] + [(1) 'debug] + [(2) 'debug/profile] + [(3) 'test-coverage]))] + [(settings) + (send case-sensitive set-value (simple-settings-case-sensitive settings)) + (send output-style set-selection + (case (simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 1] + [(write) 2])) + (send fraction-style set-value (eq? (simple-settings-fraction-style settings) + 'repeating-decimal-e)) + (send show-sharing set-value (simple-settings-show-sharing settings)) + (send insert-newlines set-value (simple-settings-insert-newlines settings)) + (send debugging set-selection + (case (simple-settings-annotations settings) + [(none) 0] + [(debug) 1] + [(debug/profile) 2] + [(test-coverage) 3]))]))) + + ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void + (define (simple-module-based-language-render-value/format value settings port width) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (λ () + (cond + [(simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-print converted-value port)) + (pretty-print converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port)) + (newline port)])) + settings + width))) + + ;; setup-printing-parameters : (-> void) simple-settings number -> void + (define (setup-printing-parameters thunk settings width) + (let ([use-number-snip? + (λ (x) + (and (number? x) + (exact? x) + (real? x) + (not (integer? x))))]) + (parameterize ( + ;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (λ (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (λ (val port) (void))] + [pretty-print-post-print-hook (λ (val port) (void))] + + [pretty-print-columns width] + [pretty-print-size-hook + (λ (value display? port) + (cond + [(not (port-writes-special? port)) #f] + [(is-a? value snip%) 1] + [(use-number-snip? value) 1] + [(syntax? value) 1] + [(to-snip-value? value) 1] + [else #f]))] + [pretty-print-print-hook + (λ (value display? port) + (cond + [(is-a? value snip%) + (write-special value port) + 1] + [(use-number-snip? value) + (write-special + (case (simple-settings-fraction-style settings) + [(mixed-fraction) + (number-snip:make-fraction-snip value #f)] + [(mixed-fraction-e) + (number-snip:make-fraction-snip value #t)] + [(repeating-decimal) + (number-snip:make-repeating-decimal-snip value #f)] + [(repeating-decimal-e) + (number-snip:make-repeating-decimal-snip value #t)]) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value) port)] + [else (write-special (value->snip value) port)]))] + [print-graph + ;; only turn on print-graph when using `write' printing + ;; style because the sharing is being taken care of + ;; by the print-convert sexp construction when using + ;; other printing styles. + (and (eq? (simple-settings-printing-style settings) 'write) + (simple-settings-show-sharing settings))]) + (thunk)))) + + ;; drscheme-inspector : inspector + (define drscheme-inspector (current-inspector)) + + ;; simple-module-based-language-convert-value : TST settings -> TST + (define (simple-module-based-language-convert-value value settings) + (case (simple-settings-printing-style settings) + [(write) value] + [(constructor) + (parameterize ([constructor-style-printing #t] + [show-sharing (simple-settings-show-sharing settings)] + [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) + (print-convert value))] + [(quasiquote) + (parameterize ([constructor-style-printing #f] + [show-sharing (simple-settings-show-sharing settings)] + [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) + (print-convert value))])) + + ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + (to-snip-value? expr)) + expr + (sh expr basic-convert sub-convert))) + + ;; initialize-simple-module-based-language : setting ((-> void) -> void) + (define (initialize-simple-module-based-language setting run-in-user-thread) + (run-in-user-thread + (λ () + (let ([annotations (simple-settings-annotations setting)]) + (when (memq annotations '(debug debug/profile test-coverage)) + (current-eval + (drscheme:debug:make-debug-eval-handler + (current-eval))) + (error-display-handler + (drscheme:debug:make-debug-error-display-handler + (error-display-handler)))) + (drscheme:debug:profiling-enabled (eq? annotations 'debug/profile)) + (drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage))) + (global-port-print-handler + (λ (value port) + (let ([converted-value (simple-module-based-language-convert-value value setting)]) + (setup-printing-parameters + (λ () + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port))) + setting + 'infinity)))) + (current-inspector (make-inspector)) + (read-case-sensitive (simple-settings-case-sensitive setting))))) + + ;; simple-module-based-language-get-init-code : setting -> sexp[module] + (define (simple-module-based-language-get-init-code setting) + `(module mod-name mzscheme + (require mzlib/pconvert + mzlib/pretty) + + (provide init-code) + + (define (executable-error-value->string-handler val size) + (let ([o (open-output-string)]) + (render-value val o) + (let ([s (get-output-string o)]) + (if ((string-length s) . <= . size) + s + (string-append + (substring s 0 (- size 3)) + "..."))))) + + (define (render-value value port) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print (convert-value value) port))) + + (define (convert-value value) + ,(case (simple-settings-printing-style setting) + [(write) `value] + [(constructor) + `(parameterize ([constructor-style-printing #t] + [show-sharing ,(simple-settings-show-sharing setting)]) + (print-convert value))] + [(quasiquote) + `(parameterize ([constructor-style-printing #f] + [show-sharing ,(simple-settings-show-sharing setting)]) + (print-convert value))])) + + ,(if (memq (simple-settings-annotations setting) '(debug debug/profile test-coverage)) + `(require (lib "errortrace.ss" "errortrace")) + `(void)) + + (define (init-code) + (current-inspector (make-inspector)) + (error-value->string-handler executable-error-value->string-handler) + (read-case-sensitive ,(simple-settings-case-sensitive setting))))) + + + ;; module-based-language->language : module-based-language -> language<%> + ;; given a module-based-language, implements a language + (define module-based-language->language-mixin + (mixin (module-based-language<%>) (language<%>) + (inherit get-module get-transformer-module use-namespace-require/copy-from-setting? + get-init-code use-mred-launcher get-reader) + + (define/pubment (capability-value s) + (inner (get-capability-default s) capability-value s)) + + (define/public (first-opened) (void)) + (define/public (get-comment-character) (values "; " #\;)) + + (inherit get-language-position) + (define/public (get-language-name) + (let ([pos (get-language-position)]) + (if (null? pos) + "<>" + (car (last-pair pos))))) + (define/public (get-style-delta) #f) + (define/override (on-execute setting run-in-user-thread) + (super on-execute setting run-in-user-thread) + (initialize-module-based-language (use-namespace-require/copy-from-setting? setting) + (get-module) + (get-transformer-module) + run-in-user-thread)) + (define/public (front-end/complete-program port settings) + (module-based-language-front-end port (get-reader))) + (define/public (front-end/interaction port settings) + (module-based-language-front-end port (get-reader))) + (define/public (create-executable setting parent program-filename) + (create-module-based-language-executable parent + program-filename + (get-module) + (get-transformer-module) + (get-init-code setting) + (use-mred-launcher) + (use-namespace-require/copy-from-setting? setting))) + (define/public (extra-repl-information _1 _2) (void)) + (define/public (get-reader-module) #f) + (define/public (get-metadata a b c) #f) + (define/public (metadata->settings m) #f) + (define/public (get-metadata-lines) #f) + + (super-new))) + + ;; create-module-based-language-executable : + ;; (is-a?/c area-container<%>) string (or #f module-spec) module-spec sexp (union boolean? 'ask) boolean? + ;; -> void + (define (create-module-based-language-executable parent + program-filename + module-language-spec + transformer-module-language-spec + init-code + mred-launcher + use-copy?) + (let ([executable-specs (create-executable-gui parent + program-filename + #t + (if (boolean? mred-launcher) + (if mred-launcher + 'mred + 'mzscheme) + #t))]) + (when executable-specs + (let* ([type (car executable-specs)] + [base (cadr executable-specs)] + [executable-filename (caddr executable-specs)] + [create-executable + (case type + [(launcher) create-module-based-launcher] + [(stand-alone) create-module-based-stand-alone-executable] + [(distribution) create-module-based-distribution])]) + (create-executable + program-filename + executable-filename + module-language-spec + transformer-module-language-spec + init-code + (if (boolean? mred-launcher) + mred-launcher + (eq? base 'mred)) + use-copy?))))) + + + ;; create-executable-gui : (union #f (is-a?/c top-level-area-container<%>)) + ;; (union #f string?) + ;; (union #t 'launcher 'stand-alone 'distribution) + ;; (union #t 'mzscheme 'mred) + ;; -> (union #f (list (union 'no-show 'launcher 'stand-alone 'distribution) + ;; (union 'no-show 'mzscheme 'mred) + ;; string[filename])) + (define (create-executable-gui parent program-filename show-type show-base) + (define dlg (make-object dialog% (string-constant create-executable-title) parent)) + (define filename-panel (make-object horizontal-panel% dlg)) + (define filename-text-field (new text-field% + [label (string-constant filename)] + [parent filename-panel] + [init-value (path->string + (default-executable-filename + program-filename + (if (eq? show-type #t) 'launcher show-type) + #f))] + [min-width 400] + [callback void])) + (define filename-browse-button (instantiate button% () + (label (string-constant browse...)) + (parent filename-panel) + (callback + (λ (x y) (browse-callback))))) + (define type/base-panel (instantiate vertical-panel% () + (parent dlg) + (stretchable-width #f))) + (define type-panel (make-object horizontal-panel% type/base-panel)) + (define type-rb (and (boolean? show-type) + (instantiate radio-box% () + (label (string-constant executable-type)) + (choices (list (string-constant launcher-explanatory-label) + (string-constant stand-alone-explanatory-label) + (string-constant distribution-explanatory-label))) + (parent type-panel) + (callback (lambda (rb e) (reset-filename-suffix)))))) + (define base-panel (make-object horizontal-panel% type/base-panel)) + (define base-rb (and (boolean? show-base) + (instantiate radio-box% () + (label (string-constant executable-base)) + (choices (list "MzScheme" "MrEd")) + (parent base-panel) + (callback (lambda (rb e) (reset-filename-suffix)))))) + + (define (reset-filename-suffix) + (let ([s (send filename-text-field get-value)]) + (unless (string=? s "") + (let ([new-s (default-executable-filename + (string->path s) + (current-mode) + (not (currently-mzscheme-binary?)))]) + (send filename-text-field set-value (path->string new-s)))))) + + (define button-panel (instantiate horizontal-panel% () + (parent dlg) + (alignment '(right center)))) + + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons + button-panel + (λ (x y) + (when (check-filename) + (set! cancelled? #f) + (send dlg show #f))) + (λ (x y) (send dlg show #f)) + (string-constant create) + (string-constant cancel))) + + (define (browse-callback) + (let ([ftf (send filename-text-field get-value)]) + (let-values ([(base name _) + (if (path-string? ftf) + (split-path ftf) + (values (current-directory) "" #f))]) + (let* ([mzscheme? (currently-mzscheme-binary?)] + [mode (current-mode)] + [filename + (put-executable/defaults + dlg + base + name + mode + (not mzscheme?) + (case mode + [(launcher) + (if mzscheme? + (string-constant save-a-mzscheme-launcher) + (string-constant save-a-mred-launcher))] + [(stand-alone) + (if mzscheme? + (string-constant save-a-mzscheme-stand-alone-executable) + (string-constant save-a-mred-stand-alone-executable))] + [(distribution) + (if mzscheme? + (string-constant save-a-mzscheme-distribution) + (string-constant save-a-mred-distribution))]))]) + (when filename + (send filename-text-field set-value (path->string filename))))))) + + (define (currently-mzscheme-binary?) + (cond + [base-rb + (= 0 (send base-rb get-selection))] + [else (eq? show-base 'mzscheme)])) + + (define (current-mode) + (cond + [type-rb + (let ([s (send type-rb get-item-label (send type-rb get-selection))]) + (cond + [(equal? s (string-constant launcher-explanatory-label)) 'launcher] + [(equal? s (string-constant stand-alone-explanatory-label)) 'stand-alone] + [(equal? s (string-constant distribution-explanatory-label)) 'distribution]))] + [else show-type])) + + (define (check-filename) + (let ([filename-str (send filename-text-field get-value)] + [mred? (not (currently-mzscheme-binary?))] + [mode (current-mode)]) + (let-values ([(extension style filters) + (mode->put-file-extension+style+filters mode mred?)]) + (cond + [(string=? "" filename-str) + (message-box (string-constant drscheme) + (string-constant please-specify-a-filename) + dlg) + #f] + [(not (users-name-ok? mode extension dlg (string->path filename-str))) + #f] + [(or (directory-exists? filename-str) + (file-exists? filename-str)) + (ask-user-can-clobber? filename-str)] + [else #t])))) + + ;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean + (define (ask-user-can-clobber? filename) + (eq? (message-box (string-constant drscheme) + (format (string-constant are-you-sure-delete?) filename) + dlg + '(yes-no)) + 'yes)) + + (define cancelled? #t) + + (reset-filename-suffix) + (send dlg show #t) + (cond + [cancelled? #f] + [else + (list + (if type-rb + (current-mode) + 'no-show) + (if base-rb + (case (send base-rb get-selection) + [(0) 'mzscheme] + [(1) 'mred]) + 'no-show) + (send filename-text-field get-value))])) + + (define (normalize-mode mode) + (case mode + [(launcher stand-alone distribution) mode] + ;; Backward compatibility: interpret a boolean + [else (if mode 'launcher 'stand-alone)])) + + ;; put-executable : parent string (union boolean 'launcher 'stand-alone 'distribution) boolean -> (union false? string) + ;; invokes the put-file dialog with arguments specific to building executables + (define (put-executable parent program-filename mode mred? title) + (let-values ([(base name dir) (split-path program-filename)]) + (let ([mode (normalize-mode mode)]) + (let ([default-name (default-executable-filename name mode mred?)]) + (put-executable/defaults + parent + base + default-name + mode + mred? + title))))) + + ;; put-executable/defaults : parent string string symbol boolean -> (union false? string) + (define (put-executable/defaults parent default-dir default-name mode mred? title) + (let-values ([(extension style filters) + (mode->put-file-extension+style+filters mode mred?)]) + (let* ([dir? (case mode + [(launcher) + (if mred? + (mred-launcher-is-directory?) + (mzscheme-launcher-is-directory?))] + [(stand-alone) + (embedding-executable-is-directory? mred?)] + [(distribution) #f])] + [users-name + (if dir? + (get-directory title + parent + default-dir + style) + (put-file title + parent + default-dir + default-name + extension + style + filters))]) + (and users-name + (users-name-ok? mode extension parent users-name) + (or (not dir?) + (gui-utils:get-choice + (format (string-constant warning-directory-will-be-replaced) + users-name) + (string-constant yes) + (string-constant no) + (string-constant drscheme) + #f + parent)) + users-name)))) + + ;; users-name-ok? : symbol string (union #f frame% dialog%) string -> boolean + ;; returns #t if the string is an acceptable name for + ;; a saved executable, and #f otherwise. + (define (users-name-ok? mode extension parent name) + (or (not extension) + (let ([suffix-m (regexp-match #rx"[.][^.]*$" (path->string name))]) + (or (and suffix-m + (string=? (substring (car suffix-m) 1) extension)) + (and + (message-box (string-constant drscheme) + (format + (string-constant ~a-must-end-with-~a) + (case mode + [(launcher) (string-constant launcher)] + [(stand-alone) (string-constant stand-alone)] + [(distribution) (string-constant distribution)]) + name + extension) + parent) + #f))))) + + ;; default-executable-filename : path symbol boolean -> path + (define (default-executable-filename program-filename mode mred?) + (let ([ext (let-values ([(extension style filters) + (mode->put-file-extension+style+filters mode mred?)]) + (if extension + (string->bytes/utf-8 (string-append "." extension)) + #""))]) + (path-replace-suffix program-filename ext))) + + (define (mode->put-file-extension+style+filters mode mred?) + (case mode + [(launcher) + (if mred? + (mred-launcher-put-file-extension+style+filters) + (mzscheme-launcher-put-file-extension+style+filters))] + [(stand-alone) + (embedding-executable-put-file-extension+style+filters mred?)] + [(distribution) + (bundle-put-file-extension+style+filters)])) + + ;; create-module-based-stand-alone-executable : ... -> void (see docs) + (define (create-module-based-stand-alone-executable program-filename + executable-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + + (with-handlers ([(λ (x) #f) ;exn:fail? + (λ (x) + (message-box + (string-constant drscheme) + (format "~a" (exn-message x))) + (void))]) + (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a")) + (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a")) + (let ([init-code-mod-name + (let-values ([(base name dir?) + (split-path init-code-tmp-filename)]) + (string->symbol (path->string name)))]) + + (call-with-output-file bootstrap-tmp-filename + (λ (port) + (write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!) + ,@(if module-language-spec + (if use-copy? + (list + `(namespace-require/copy ',module-language-spec)) + (list + `(namespace-require/constant ',module-language-spec))) + '()) + ,@(if transformer-module-language-spec + (list `(namespace-require `(for-syntax ,transformer-module-language-spec))) + (list)) + ((dynamic-require ',init-code-mod-name 'init-code))) + port)) + #:exists 'truncate + #:mode 'text) + + (let ([new-init-code + (list* + (car init-code) + init-code-mod-name + (cddr init-code))]) + (call-with-output-file init-code-tmp-filename + (λ (port) + (write new-init-code port)) + #:exists 'truncate #:mode 'text))) + + (let* ([pre-to-be-embedded-module-specs0 + (cond + [(and module-language-spec transformer-module-language-spec) + (if (equal? module-language-spec transformer-module-language-spec) + (list module-language-spec) + (list module-language-spec transformer-module-language-spec))] + [module-language-spec + (list module-language-spec)] + [transformer-module-language-spec + (list transformer-module-language-spec)] + [else '()])] + [pre-to-be-embedded-module-specs1 + (if gui? + (cons '(lib "mred/mred.ss") + pre-to-be-embedded-module-specs0) + pre-to-be-embedded-module-specs0)] + [pre-to-be-embedded-module-specs2 + (cons `(file ,(path->string init-code-tmp-filename)) + pre-to-be-embedded-module-specs1)] + [pre-to-be-embedded-module-specs3 + (filter (λ (x) (not (eq? x 'mzscheme))) + pre-to-be-embedded-module-specs2)] + [to-be-embedded-module-specs + (map (λ (x) (list #f x)) + pre-to-be-embedded-module-specs3)]) + + (create-embedding-executable + executable-filename + #:mred? gui? + #:verbose? #f ;; verbose? + #:modules to-be-embedded-module-specs + #:literal-files (list + bootstrap-tmp-filename + program-filename) + #:cmdline (if gui? + (list "-mvqZ") + (list "-mvq")))) + (delete-file init-code-tmp-filename) + (delete-file bootstrap-tmp-filename) + (void))) + + ;; create-module-based-distribution : ... -> void (see docs) + (define (create-module-based-distribution program-filename + distribution-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + (create-distribution-for-executable + distribution-filename + gui? + (lambda (exe-name) + (create-module-based-stand-alone-executable program-filename + exe-name + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?)))) + + ;; create-distribution-for-executable : ... -> void (see docs) + (define (create-distribution-for-executable distribution-filename + gui? + make-executable) + ;; Delete old file, if it exists: + (when (file-exists? distribution-filename) + (delete-file distribution-filename)) + ;; Figure out base name, and create working temp directory: + (let* ([base-name (let-values ([(base name dir?) (split-path distribution-filename)]) + (path-replace-suffix name #""))] + [temp-dir + (make-temporary-file "drscheme-tmp-~a" 'directory)] + [c (make-custodian)] + [dialog (new dialog% + [label (string-constant distribution-progress-window-title)] + [width 400])] + [status-message + (new message% + [label (string-constant creating-executable-progress-status)] + [parent dialog] + [stretchable-width #t])] + [pane (new vertical-pane% + [parent dialog])] + [abort-button + (new button% + [parent pane] + [label (string-constant abort)] + [callback (lambda (_1 _2) + (custodian-shutdown-all c))])] + + [exn #f] + + [worker-thread + (parameterize ([current-custodian c]) + (thread + (λ () + (with-handlers ([exn? (λ (e) (set! exn e))]) + ;; Build the exe: + (make-directory (build-path temp-dir "exe")) + (let ([exe-name (build-path temp-dir "exe" (default-executable-filename base-name 'stand-alone gui?))]) + (make-executable exe-name) + (when (or (file-exists? exe-name) + (directory-exists? exe-name)) + (let ([dist-dir (build-path temp-dir base-name)]) + ;; Assemble the bundle directory: + (queue-callback + (λ () + (send status-message set-label (string-constant assembling-distribution-files-progress-status)))) + (assemble-distribution dist-dir (list exe-name)) + ;; Pack it: + (queue-callback + (λ () + (send status-message set-label (string-constant packing-distribution-progress-status)))) + (bundle-directory distribution-filename dist-dir #t))))))))]) + + ;; create a thread that will trigger hiding the dialog and the return from `show' + ;; when things are done (no matter if there was a kill, or just normal terminiation) + (thread + (λ () + (thread-wait worker-thread) + (queue-callback (λ () (send dialog show #f))))) + + (send dialog show #t) + + ;; Clean up: + (custodian-shutdown-all c) + (delete-directory/files temp-dir) + + (when exn + (raise exn)))) + + + (define (condense-scheme-code-string s) + (let ([i (open-input-string s)] + [o (open-output-string)]) + (let loop () + (let ([c (read-char i)]) + (unless (eof-object? c) + (let ([next (λ () + (display c o) + (loop))]) + (case c + [(#\space) + (if (char=? #\( (peek-char i)) + (loop) + (next))] + [(#\)) + (if (eq? #\space (peek-char i)) + (begin + (display #\) o) + (read-char i) + (loop)) + (next))] + [(#\\) + (begin + (display #\\ o) + (display (read-char i) o) + (loop))] + [(#\" #\|) + (display c o) + (let loop () + (let ([v (read-char i)]) + (cond + [(eq? v c) (next)] + [(eq? v #\\) + (display v o) + (display (read-char i) o) + (loop)] + [else (display v o) + (loop)])))] + [else (next)]))))) + (get-output-string o))) + + (define (create-module-based-launcher program-filename + executable-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + + (with-handlers ([(λ (x) #f) ;exn:fail? + (λ (x) + (message-box + (string-constant drscheme) + (format "~a" (exn-message x))) + (void))]) + + ((if gui? make-mred-launcher make-mzscheme-launcher) + (list + (path->string + (build-path (collection-path "drscheme" "private") + (if gui? + "launcher-mred-bootstrap.ss" + "launcher-mz-bootstrap.ss"))) + (condense-scheme-code-string (format "~s" init-code)) + (path->string program-filename) + (format "~s" module-language-spec) + (format "~s" transformer-module-language-spec) + (format "~s" use-copy?)) + (if (path? executable-filename) + (path->string executable-filename) + executable-filename)))) + + ;; initialize-module-based-language : boolean (or #f module-spec) module-spec ((-> void) -> void) + (define (initialize-module-based-language use-copy? + module-spec + transformer-module-spec + run-in-user-thread) + (run-in-user-thread + (λ () + (with-handlers ([(λ (x) #t) + (λ (x) + (display (exn-message x)) + (newline))]) + (when module-spec + (if use-copy? + (namespace-require/copy module-spec) + (namespace-require/constant module-spec))) + (when transformer-module-spec + (namespace-require `(for-syntax ,transformer-module-spec))))))) + + ;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof))) + ;; type reader = type-spec-of-read-syntax (see mz manual for details) + (define (module-based-language-front-end port reader) + (λ () + (let ([s (reader (object-name port) port)]) + (if (syntax? s) + (namespace-syntax-introduce + (datum->syntax + #f + (cons '#%top-interaction s) + s)) + s)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; snip/value extensions + ;; + + (define to-snips null) + (define-struct to-snip (predicate? >value setup-thunk)) + (define add-snip-value + (opt-lambda (predicate constructor [setup-thunk void]) + (set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips)))) + + (define (value->snip v) + (ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v) + ((to-snip->value to-snip) v))) + to-snips)) + (define (to-snip-value? v) + (ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) + (define (setup-setup-values) + (for-each (λ (t) ((to-snip-setup-thunk t))) to-snips)) + + + (define capabilities '()) + (define (capability-registered? x) (and (assoc x capabilities) #t)) + (define (register-capability name contract default) + (when (capability-registered? name) + (error 'register-capability "already registered capability ~s" name)) + (set! capabilities (cons (list name default contract) capabilities))) + (define (get-capability-default name) + (let ([l (assoc name capabilities)]) + (unless l + (error 'get-capability-default "name not bound ~s" name)) + (cadr l))) + (define (get-capability-contract name) + (let ([l (assoc name capabilities)]) + (unless l + (error 'get-capability-contract "name not bound ~s" name)) + (caddr l))) + + +; +; +; ;;;;;; ; +; ; ; ; +; ; ; ;; ;; ;;;;; ;;; ;; ;; ;;;; ;;; ;;; ;; ;; ;;;; +; ;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; +; ; ; ;; ; ;;;;; ; ; ;;; ; ; ; ; ; ;;; +; ; ;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;;;; ;; ;; ;;; ;;;; ;;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;;; +; +; +; +; + + + + (define language-extensions null) + (define (get-language-extensions) + (drscheme:tools:only-in-phase + 'drscheme:language:get-default-mixin + 'phase2) + language-extensions) + + (define (default-mixin x) x) + (define (get-default-mixin) + (drscheme:tools:only-in-phase + 'drscheme:language:get-default-mixin + 'phase2) + default-mixin) + + (define (extend-language-interface extension<%> default-impl) + (drscheme:tools:only-in-phase + 'drscheme:language:extend-language-interface + 'phase1) + (set! default-mixin (compose default-impl default-mixin)) + (set! language-extensions (cons extension<%> language-extensions))) diff --git a/collects/drscheme/private/launcher-bootstrap.ss b/collects/drscheme/private/launcher-bootstrap.ss new file mode 100644 index 0000000000..d7ce4e81ab --- /dev/null +++ b/collects/drscheme/private/launcher-bootstrap.ss @@ -0,0 +1,50 @@ +#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)) \ No newline at end of file diff --git a/collects/drscheme/private/launcher-mred-bootstrap.ss b/collects/drscheme/private/launcher-mred-bootstrap.ss new file mode 100644 index 0000000000..20820223ab --- /dev/null +++ b/collects/drscheme/private/launcher-mred-bootstrap.ss @@ -0,0 +1,9 @@ +#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) diff --git a/collects/drscheme/private/launcher-mz-bootstrap.ss b/collects/drscheme/private/launcher-mz-bootstrap.ss new file mode 100644 index 0000000000..f591a62c7a --- /dev/null +++ b/collects/drscheme/private/launcher-mz-bootstrap.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(require "launcher-bootstrap.ss") + +(current-namespace (make-base-empty-namespace)) +(namespace-require 'scheme/base) + +(startup) diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss new file mode 100644 index 0000000000..18c9b2f0c3 --- /dev/null +++ b/collects/drscheme/private/link.ss @@ -0,0 +1,55 @@ +(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@))) + diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss new file mode 100644 index 0000000000..bac906ae27 --- /dev/null +++ b/collects/drscheme/private/main.ss @@ -0,0 +1,508 @@ +#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)))) diff --git a/collects/drscheme/private/modes.ss b/collects/drscheme/private/modes.ss new file mode 100644 index 0000000000..973d6275d2 --- /dev/null +++ b/collects/drscheme/private/modes.ss @@ -0,0 +1,46 @@ +#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)))))) diff --git a/collects/drscheme/private/module-browser.ss b/collects/drscheme/private/module-browser.ss new file mode 100644 index 0000000000..5a6a825258 --- /dev/null +++ b/collects/drscheme/private/module-browser.ss @@ -0,0 +1,1002 @@ +#lang scheme/base + +(require mred + scheme/class + syntax/moddep + syntax/toplevel + framework/framework + string-constants + mrlib/graph + "drsig.ss" + scheme/unit + scheme/async-channel) + +(define-struct req (filename key)) +;; type req = (make-req string[filename] (union symbol #f)) + +(provide module-overview@ + process-program-unit + (struct-out req)) + +(define adding-file (string-constant module-browser-adding-file)) +(define unknown-module-name "? unknown module name") + +(define-unit module-overview@ + (import [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:eval: drscheme:eval^] + [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix drscheme:language: drscheme:language^]) + (export drscheme:module-overview^) + + (define filename-constant (string-constant module-browser-filename-format)) + (define font-size-gauge-label (string-constant module-browser-font-size-gauge-label)) + (define progress-label (string-constant module-browser-progress-label)) + (define laying-out-graph-label (string-constant module-browser-laying-out-graph-label)) + (define open-file-format (string-constant module-browser-open-file-format)) + (define lib-paths-checkbox-constant (string-constant module-browser-show-lib-paths)) + + (preferences:set-default 'drscheme:module-overview:label-font-size 12 number?) + (preferences:set-default 'drscheme:module-overview:window-height 500 number?) + (preferences:set-default 'drscheme:module-overview:window-width 500 number?) + (preferences:set-default 'drscheme:module-browser:hide-paths '(lib) + (λ (x) + (and (list? x) + (andmap symbol? x)))) + + (define (set-box/f b v) (when (box? b) (set-box! b v))) + + (define (module-overview parent) + (let ([filename (get-file #f parent)]) + (when filename + (module-overview/file filename parent)))) + + (define (find-label-font size) + (send the-font-list find-or-create-font size 'decorative 'normal 'normal #f)) + + (define module-overview-pasteboard<%> + (interface () + set-label-font-size + get-label-font-size + get-hidden-paths + show-visible-paths + remove-visible-paths + set-name-length + get-name-length)) + + (define boxed-word-snip<%> + (interface () + get-filename + get-word + get-lines + is-special-key-child? + add-special-key-child)) + + ;; make-module-overview-pasteboard : boolean + ;; ((union #f snip) -> void) + ;; -> (union string pasteboard) + ;; string as result indicates an error message + ;; pasteboard as result is the pasteboard to show + (define (make-module-overview-pasteboard vertical? mouse-currently-over) + + (define level-ht (make-hasheq)) + + ;; snip-table : hash-table[sym -o> snip] + (define snip-table (make-hash)) + (define label-font (find-label-font (preferences:get 'drscheme:module-overview:label-font-size))) + (define text-color (make-object color% "blue")) + + (define dark-syntax-pen (send the-pen-list find-or-create-pen "darkorchid" 1 'solid)) + (define dark-syntax-brush (send the-brush-list find-or-create-brush "darkorchid" 'solid)) + (define light-syntax-pen (send the-pen-list find-or-create-pen "plum" 1 'solid)) + (define light-syntax-brush (send the-brush-list find-or-create-brush "plum" 'solid)) + + (define dark-template-pen (send the-pen-list find-or-create-pen "seagreen" 1 'solid)) + (define dark-template-brush (send the-brush-list find-or-create-brush "seagreen" 'solid)) + (define light-template-pen (send the-pen-list find-or-create-pen "springgreen" 1 'solid)) + (define light-template-brush (send the-brush-list find-or-create-brush "springgreen" 'solid)) + + (define dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid)) + (define dark-brush (send the-brush-list find-or-create-brush "blue" 'solid)) + (define light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid)) + (define light-brush (send the-brush-list find-or-create-brush "light blue" 'solid)) + + (define (module-overview-pasteboard-mixin %) + (class* % (module-overview-pasteboard<%>) + + (inherit get-snip-location + begin-edit-sequence + end-edit-sequence + insert + move-to + find-first-snip + dc-location-to-editor-location + find-snip + get-canvas) + + (define name-length 'long) + (define/public (set-name-length nl) + (unless (eq? name-length nl) + (set! name-length nl) + (re-add-snips) + (render-snips))) + (define/public (get-name-length) name-length) + + (field [max-lines #f]) + + ;; controls if the snips should be moved + ;; around when the font size is changed. + ;; set to #f if the user ever moves a + ;; snip themselves. + (define dont-move-snips #f) + + (field (label-font-size (preferences:get 'drscheme:module-overview:label-font-size))) + (define/public (get-label-font-size) label-font-size) + (define/private (get-snip-hspace) (if vertical? + 2 + (* 2 label-font-size))) + (define/private (get-snip-vspace) (if vertical? + 30 + 2)) + (define snip-height #f) + + (define font-label-size-callback-running? #f) + (define new-font-size #f) + (define/public (set-label-font-size size-to-set) + (set! new-font-size size-to-set) + (unless font-label-size-callback-running? + (set! font-label-size-callback-running? #t) + (queue-callback + (λ () + (set! label-font-size new-font-size) + (preferences:set 'drscheme:module-overview:label-font-size + new-font-size) + (set! label-font (find-label-font label-font-size)) + (begin-edit-sequence) + (let loop ([snip (find-first-snip)]) + (when snip + (let ([admin (send snip get-admin)]) + (when admin + (send admin resized snip #t))) + (loop (send snip next)))) + (unless dont-move-snips + (render-snips)) + (end-edit-sequence) + (set! new-font-size #f) + (set! font-label-size-callback-running? #f)) + #f))) + + (define/public (begin-adding-connections) + (when max-lines + (error 'begin-adding-connections "already in begin-adding-connections/end-adding-connections sequence")) + (set! max-lines 0) + (begin-edit-sequence) + (let loop () + (let ([s (find-first-snip)]) + (when s + (send s release-from-owner) + (loop)))) + (set! level-ht (make-hasheq)) + (set! snip-table (make-hash))) + + (define/public (end-adding-connections) + (unless max-lines + (error 'end-adding-connections "not in begin-adding-connections/end-adding-connections sequence")) + + (unless (zero? max-lines) + (let loop ([snip (find-first-snip)]) + (when snip + (when (is-a? snip word-snip/lines%) + (send snip normalize-lines max-lines)) + (loop (send snip next))))) + + + (set! max-lines #f) + + (remove-specially-linked) + (render-snips) + (end-edit-sequence)) + + ;; add-connection : string string boolean number -> void + ;; name-original and name-require and the identifiers for those paths and + ;; original-filename? and require-filename? are booleans indicating if the names + ;; are filenames. + (define/public (add-connection name-original name-require path-key require-depth) + (unless max-lines + (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence")) + (let* ([original-filename? (file-exists? name-original)] + [require-filename? (file-exists? name-require)] + [original-snip (find/create-snip name-original original-filename?)] + [require-snip (find/create-snip name-require require-filename?)] + [original-level (send original-snip get-level)] + [require-level (send require-snip get-level)]) + (case require-depth + [(0) + (add-links original-snip require-snip + dark-pen light-pen + dark-brush light-brush)] + [else + (add-links original-snip require-snip + dark-syntax-pen light-syntax-pen + dark-syntax-brush light-syntax-brush)]) + (when path-key + (send original-snip add-special-key-child path-key require-snip)) + (if (send original-snip get-level) + (fix-snip-level require-snip (+ original-level 1)) + (fix-snip-level original-snip 0)))) + + ;; fix-snip-level : snip number -> void + ;; moves the snip (and any children) to at least `new-level' + ;; doesn't move them if they are already past that level + (define/private (fix-snip-level snip new-min-level) + (let loop ([snip snip] + [new-min-level new-min-level]) + (let ([current-level (send snip get-level)]) + (when (or (not current-level) + (new-min-level . > . current-level)) + (send snip set-level new-min-level) + (for-each + (λ (child) (loop child (+ new-min-level 1))) + (send snip get-children)))))) + + ;; find/create-snip : (union path string) boolean? -> word-snip/lines + ;; finds the snip with this key, or creates a new + ;; ones. For the same key, always returns the same snip. + ;; uses snip-table as a cache for this purpose. + (define/private (find/create-snip name is-filename?) + (hash-ref + snip-table + name + (λ () + (let* ([snip (instantiate word-snip/lines% () + (lines (if is-filename? (count-lines name) #f)) + (word (let-values ([(_1 name _2) (split-path name)]) + (path->string name))) + (pb this) + (filename (if is-filename? name #f)))]) + (insert snip) + (hash-set! snip-table name snip) + snip)))) + + ;; count-lines : string[filename] -> (union #f number) + ;; effect: updates max-lines + (define/private (count-lines filename) + (let ([lines + (call-with-input-file filename + (λ (port) + (let loop ([n 0]) + (let ([l (read-line port)]) + (if (eof-object? l) + n + (loop (+ n 1)))))) + #:mode 'text)]) + (set! max-lines (max lines max-lines)) + lines)) + + ;; get-snip-width : snip -> number + ;; exracts the width of a snip + (define/private (get-snip-width snip) + (let ([lb (box 0)] + [rb (box 0)]) + (get-snip-location snip lb #f #f) + (get-snip-location snip rb #f #t) + (- (unbox rb) + (unbox lb)))) + + ;; get-snip-height : snip -> number + ;; exracts the width of a snip + (define/private (get-snip-height snip) + (let ([tb (box 0)] + [bb (box 0)]) + (get-snip-location snip #f tb #f) + (get-snip-location snip #f bb #t) + (- (unbox bb) + (unbox tb)))) + + (field [hidden-paths (preferences:get 'drscheme:module-browser:hide-paths)]) + (define/public (remove-visible-paths symbol) + (unless (memq symbol hidden-paths) + (set! hidden-paths (cons symbol hidden-paths)) + (refresh-visible-paths))) + (define/public (show-visible-paths symbol) + (when (memq symbol hidden-paths) + (set! hidden-paths (remq symbol hidden-paths)) + (refresh-visible-paths))) + (define/public (get-hidden-paths) hidden-paths) + + (define/private (refresh-visible-paths) + (begin-edit-sequence) + (re-add-snips) + (render-snips) + (end-edit-sequence)) + + (define/private (re-add-snips) + (begin-edit-sequence) + (remove-specially-linked) + (end-edit-sequence)) + + (define/private (remove-specially-linked) + (remove-currrently-inserted) + (cond + [(null? hidden-paths) + (add-all)] + [else + (let ([ht (make-hasheq)]) + (for-each + (λ (snip) + (insert snip) + (let loop ([snip snip]) + (unless (hash-ref ht snip (λ () #f)) + (hash-set! ht snip #t) + (for-each + (λ (child) + (unless (ormap (λ (key) (send snip is-special-key-child? key child)) + hidden-paths) + (insert child) + (loop child))) + (send snip get-children))))) + (get-top-most-snips)))])) + + (define/private (remove-currrently-inserted) + (let loop () + (let ([snip (find-first-snip)]) + (when snip + (send snip release-from-owner) + (loop))))) + + (define/private (add-all) + (let ([ht (make-hasheq)]) + (for-each + (λ (snip) + (let loop ([snip snip]) + (unless (hash-ref ht snip (λ () #f)) + (hash-set! ht snip #t) + (insert snip) + (for-each loop (send snip get-children))))) + (get-top-most-snips)))) + + (define/private (get-top-most-snips) (hash-ref level-ht 0 (λ () null))) + + ;; render-snips : -> void + (define/public (render-snips) + (begin-edit-sequence) + (let ([max-minor 0]) + + ;; major-dim is the dimension that new levels extend along + ;; minor-dim is the dimension that snips inside a level extend along + + (hash-for-each + level-ht + (λ (n v) + (set! max-minor (max max-minor (apply + (map (if vertical? + (λ (x) (get-snip-width x)) + (λ (x) (get-snip-height x))) + v)))))) + + (let ([levels (sort (hash-map level-ht list) + (λ (x y) (<= (car x) (car y))))]) + (let loop ([levels levels] + [major-dim 0]) + (cond + [(null? levels) (void)] + [else + (let* ([level (car levels)] + [n (car level)] + [this-level-snips (cadr level)] + [this-minor (apply + (map (if vertical? + (λ (x) (get-snip-width x)) + (λ (x) (get-snip-height x))) + this-level-snips))] + [this-major (apply max (map (if vertical? + (λ (x) (get-snip-height x)) + (λ (x) (get-snip-width x))) + this-level-snips))]) + (let loop ([snips this-level-snips] + [minor-dim (/ (- max-minor this-minor) 2)]) + (unless (null? snips) + (let* ([snip (car snips)] + [new-major-coord + (+ major-dim + (floor + (- (/ this-major 2) + (/ (if vertical? + (get-snip-height snip) + (get-snip-width snip)) + 2))))]) + (if vertical? + (move-to snip minor-dim new-major-coord) + (move-to snip new-major-coord minor-dim)) + (loop (cdr snips) + (+ minor-dim + (if vertical? + (get-snip-hspace) + (get-snip-vspace)) + (if vertical? + (get-snip-width snip) + (get-snip-height snip))))))) + (loop (cdr levels) + (+ major-dim + (if vertical? + (get-snip-vspace) + (get-snip-hspace)) + this-major)))])))) + (end-edit-sequence)) + + (define/override (on-mouse-over-snips snips) + (mouse-currently-over snips)) + + (define/override (on-double-click snip event) + (cond + [(is-a? snip boxed-word-snip<%>) + (let ([fn (send snip get-filename)]) + (when fn + (handler:edit-file fn)))] + [else (super on-double-click snip event)])) + + (define/override (on-event evt) + (cond + [(send evt button-down? 'right) + (let ([ex (send evt get-x)] + [ey (send evt get-y)]) + (let-values ([(x y) (dc-location-to-editor-location ex ey)]) + (let ([snip (find-snip x y)] + [canvas (get-canvas)]) + (let ([right-button-menu (make-object popup-menu%)]) + (when (and snip + (is-a? snip boxed-word-snip<%>) + canvas + (send snip get-filename)) + (instantiate menu-item% () + (label + (trim-string + (format open-file-format + (path->string (send snip get-filename))) + 200)) + (parent right-button-menu) + (callback + (λ (x y) + (handler:edit-file + (send snip get-filename)))))) + (instantiate menu-item% () + (label (string-constant module-browser-open-all)) + (parent right-button-menu) + (callback + (λ (x y) + (let loop ([snip (find-first-snip)]) + (when snip + (when (is-a? snip boxed-word-snip<%>) + (let ([filename (send snip get-filename)]) + (handler:edit-file filename))) + (loop (send snip next))))))) + (send canvas popup-menu + right-button-menu + (+ (send evt get-x) 1) + (+ (send evt get-y) 1))))))] + [else (super on-event evt)])) + + (super-new))) + + (define (trim-string str len) + (cond + [(<= (string-length str) len) str] + [else (substring str (- (string-length str) len) (string-length str))])) + + (define (level-mixin %) + (class % + (field (level #f)) + (define/public (get-level) level) + (define/public (set-level _l) + (when level + (hash-set! level-ht level + (remq this (hash-ref level-ht level)))) + (set! level _l) + (hash-set! level-ht level + (cons this (hash-ref level-ht level (λ () null))))) + + (super-instantiate ()))) + + (define (boxed-word-snip-mixin %) + (class* % (boxed-word-snip<%>) + (init-field word + filename + lines + pb) + + (field [special-children (make-hasheq)]) + (define/public (is-special-key-child? key child) + (let ([ht (hash-ref special-children key #f)]) + (and ht + (hash-ref ht child #f)))) + (define/public (add-special-key-child key child) + (let ([ht (hash-ref special-children key #f)]) + (unless ht + (set! ht (make-hasheq)) + (hash-set! special-children key ht)) + (hash-set! ht child #t))) + + (define/public (get-filename) filename) + (define/public (get-word) word) + (define/public (get-lines) lines) + + (field (lines-brush #f)) + (define/public (normalize-lines n) + (if lines + (let* ([grey (inexact->exact (floor (- 255 (* 255 (sqrt (/ lines n))))))]) + (set! lines-brush (send the-brush-list find-or-create-brush + (make-object color% grey grey grey) + 'solid))) + (set! lines-brush (send the-brush-list find-or-create-brush + "salmon" + 'solid)))) + + (field (snip-width 0) + (snip-height 0)) + + (define/override (get-extent dc x y wb hb descent space lspace rspace) + (cond + [(equal? (name->label) "") + (set! snip-width 15) + (set! snip-height 15)] + [else + (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)]) + (set! snip-width (+ w 4)) + (set! snip-height (+ h 4)))]) + (set-box/f wb snip-width) + (set-box/f hb snip-height) + (set-box/f descent 0) + (set-box/f space 0) + (set-box/f lspace 0) + (set-box/f rspace 0)) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([old-font (send dc get-font)] + [old-text-foreground (send dc get-text-foreground)] + [old-brush (send dc get-brush)]) + (send dc set-font label-font) + (when lines-brush + (send dc set-brush lines-brush)) + (when (and (or (<= left x right) + (<= left (+ x snip-width) right)) + (or (<= top y bottom) + (<= top (+ y snip-height) bottom))) + (send dc draw-rectangle x y snip-width snip-height) + (send dc set-text-foreground text-color) + (send dc draw-text (name->label) (+ x 2) (+ y 2))) + (send dc set-brush old-brush) + (send dc set-text-foreground old-text-foreground) + (send dc set-font old-font))) + + ;; name->label : path -> string + ;; constructs a label for the little boxes in terms + ;; of the filename. + + (define last-name #f) + (define last-size #f) + + (define/private (name->label) + (let ([this-size (send pb get-name-length)]) + (cond + [(eq? this-size last-size) last-name] + [else + (set! last-size this-size) + (set! last-name + (case last-size + [(short) + (if (string=? word "") + "" + (string (string-ref word 0)))] + [(medium) + (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)]) + (let ([short-name (if m (cadr m) word)]) + (if (string=? short-name "") + "" + (let ([ms (regexp-match* #rx"-[^-]*" short-name)]) + (cond + [(null? ms) + (substring short-name 0 (min 2 (string-length short-name)))] + [else + (apply string-append + (cons (substring short-name 0 1) + (map (λ (x) (substring x 1 2)) + ms)))])))))] + [(long) word])) + last-name]))) + + (super-new))) + + (define word-snip/lines% (level-mixin (boxed-word-snip-mixin (graph-snip-mixin snip%)))) + + (define draw-lines-pasteboard% (module-overview-pasteboard-mixin + (graph-pasteboard-mixin + pasteboard:basic%))) + (make-object draw-lines-pasteboard%)) + + + ; + ; + ; + ; ;;; ;;;; ; ; ; + ; ; ; ; ; ; ; + ; ; ; ; ; ; + ; ;;;; ; ; ;;; ; ;; ;; ;;; ; ; ; ; + ; ; ;; ; ; ;; ;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ; ;;;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ;;;; ;;;;; ;;;;; ; + ; + ; + ; + + + (define (module-overview/file filename parent) + (define progress-frame (parameterize ([current-eventspace (make-eventspace)]) + (instantiate frame% () + (parent parent) + (label progress-label) + (width 600)))) + (define progress-message (instantiate message% () + (label "") + (stretchable-width #t) + (parent progress-frame))) + + (define thd + (thread + (λ () + (sleep 3) + (send progress-frame show #t)))) + + (define text/pos + (let ([t (make-object text:basic%)]) + (send t load-file filename) + (drscheme:language:make-text/pos + t + 0 + (send t last-position)))) + + (define update-label void) + + (define (show-status str) + (send progress-message set-label str)) + + (define pasteboard (make-module-overview-pasteboard + #f + (λ (x) (update-label x)))) + + (let ([success? (fill-pasteboard pasteboard text/pos show-status void)]) + (kill-thread thd) + (send progress-frame show #f) + (when success? + (let () + (define frame (instantiate overview-frame% () + (label (string-constant module-browser)) + (width (preferences:get 'drscheme:module-overview:window-width)) + (height (preferences:get 'drscheme:module-overview:window-height)) + (alignment '(left center)))) + (define vp (instantiate vertical-panel% () + (parent (send frame get-area-container)) + (alignment '(left center)))) + (define root-message (instantiate message% () + (label + (format (string-constant module-browser-root-filename) + filename)) + (parent vp) + (stretchable-width #t))) + (define label-message (instantiate message% () + (label "") + (parent vp) + (stretchable-width #t))) + (define font-size-gauge + (instantiate slider% () + (label font-size-gauge-label) + (min-value 1) + (max-value 72) + (init-value (preferences:get 'drscheme:module-overview:label-font-size)) + (parent vp) + (callback + (λ (x y) + (send pasteboard set-label-font-size (send font-size-gauge get-value)))))) + (define lib-paths-checkbox + (instantiate check-box% () + (label lib-paths-checkbox-constant) + (parent vp) + (callback + (λ (x y) + (if (send lib-paths-checkbox get-value) + (send pasteboard show-visible-paths 'lib) + (send pasteboard remove-visible-paths 'lib)))))) + + (define ec (make-object canvas:basic% vp pasteboard)) + + (send lib-paths-checkbox set-value (not (memq 'lib (preferences:get 'drscheme:module-browser:hide-paths)))) + (set! update-label + (λ (s) + (if (and s (not (null? s))) + (let* ([currently-over (car s)] + [fn (send currently-over get-filename)] + [lines (send currently-over get-lines)]) + (when (and fn lines) + (send label-message set-label + (format filename-constant fn lines)))) + (send label-message set-label "")))) + + ;; shouldn't be necessary here -- need to find callback on editor + (send pasteboard render-snips) + + (send frame show #t))))) + + (define (fill-pasteboard pasteboard text/pos show-status send-user-thread/eventspace) + + (define progress-channel (make-async-channel)) + (define connection-channel (make-async-channel)) + + (define-values/invoke-unit process-program-unit + (import process-program-import^) + (export process-program-export^)) + + ;; =user thread= + (define (iter sexp continue) + (cond + [(eof-object? sexp) + (custodian-shutdown-all user-custodian)] + [else + (add-connections sexp) + (continue)])) + (define init-complete (make-semaphore 0)) + + (define user-custodian #f) + (define user-thread #f) + (define error-str #f) + + (define init-dir + (let* ([bx (box #f)] + [filename (send (drscheme:language:text/pos-text text/pos) get-filename bx)]) + (if (and filename + (not (unbox bx))) + (let-values ([(base name dir) (split-path filename)]) + base) + (current-directory)))) + + (define (init) + (set! user-custodian (current-custodian)) + (set! user-thread (current-thread)) + (moddep-current-open-input-file + (λ (filename) + (let* ([p (open-input-file filename)] + [wxme? (regexp-match-peek #rx#"^WXME" p)]) + (if wxme? + (let ([t (new text%)]) + (close-input-port p) + (send t load-file filename) + (let ([prt (open-input-text-editor t)]) + (port-count-lines! prt) + prt)) + p)))) + (current-load-relative-directory init-dir) + (current-directory init-dir) + (error-display-handler (λ (str exn) (set! error-str str))) + + ;; instead of escaping when there's an error on the user thread, + ;; we just shut it all down. This kills the event handling loop + ;; for the eventspace and wakes up the thread below + ;; NOTE: we cannot set this directly in `init' since the call to `init' + ;; is wrapped in a parameterize of the error-escape-handler + (queue-callback + (λ () + (error-escape-handler + (λ () (custodian-shutdown-all user-custodian))) + (semaphore-post init-complete)))) + (define (kill-termination) (void)) + (define complete-program? #t) + + (define stupid-internal-define-syntax1 + ((drscheme:eval:traverse-program/multiple + (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol)) + init + kill-termination) + text/pos + iter + complete-program?)) + + (semaphore-wait init-complete) + (send-user-thread/eventspace user-thread user-custodian) + + ;; this thread puts a "cap" on the end of the connection-channel + ;; so that we know when we've gotten to the end. + ;; this ensures that we can completely flush out the + ;; connection-channel. + (thread + (λ () + (sync (thread-dead-evt user-thread)) + (async-channel-put connection-channel 'done))) + + (send pasteboard begin-adding-connections) + (let ([evt + (choice-evt + (handle-evt progress-channel (λ (x) (cons 'progress x))) + (handle-evt connection-channel (λ (x) (cons 'connect x))))]) + (let loop () + (let* ([evt-value (yield evt)] + [key (car evt-value)] + [val (cdr evt-value)]) + (case key + [(progress) + (show-status val) + (loop)] + [(connect) + (unless (eq? val 'done) + (let ([name-original (list-ref val 0)] + [name-require (list-ref val 1)] + [path-key (list-ref val 2)] + [require-depth (list-ref val 3)]) + (send pasteboard add-connection name-original name-require path-key require-depth)) + (loop))])))) + (send pasteboard end-adding-connections) + + (custodian-shutdown-all user-custodian) + + (cond + [error-str + (message-box + (string-constant module-browser) + (format (string-constant module-browser-error-expanding) + error-str)) + #f] + [else + #t])) + + (define overview-frame% + (class (drscheme:frame:basics-mixin + frame:standard-menus%) + (define/override (edit-menu:between-select-all-and-find menu) (void)) + (define/override (edit-menu:between-redo-and-cut menu) (void)) + (define/override (edit-menu:between-find-and-preferences menu) (void)) + + (define/override (edit-menu:create-cut?) #f) + (define/override (edit-menu:create-copy?) #f) + (define/override (edit-menu:create-paste?) #f) + (define/override (edit-menu:create-clear?) #f) + (define/override (edit-menu:create-select-all?) #f) + + (define/override (on-size w h) + (preferences:set 'drscheme:module-overview:window-width w) + (preferences:set 'drscheme:module-overview:window-height h) + (super on-size w h)) + (super-instantiate ())))) + + + +; +; +; +; +; +; +; ; ;; ; ; ;;; ;;; ;;; ;;; ;;; ; ;; ; ; ;;; ;; ; +; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; +; ; ; ; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;;;;;; ;; ;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;; +; ; ;; ; ;;; ;;; ;;;; ;;; ;;; ; ;; ; ;;; ;; ; +; ; ; ; +; ; ; ; ; +; ; ; ;;;; + + +(define-signature process-program-import^ + (progress-channel connection-channel)) + +(define-signature process-program-export^ + (add-connections)) + +(define-unit process-program-unit + (import process-program-import^) + (export process-program-export^) + + (define visited-hash-table (make-hash)) + + ;; add-connections : (union syntax string[filename]) -> (union #f string) + ;; recursively adds a connections from this file and + ;; all files it requires + ;; returns a string error message if there was an error compiling + ;; the program + (define (add-connections filename/stx) + (cond + [(string? filename/stx) + (add-filename-connections filename/stx)] + [(syntax? filename/stx) + (add-syntax-connections filename/stx)])) + + ;; add-syntax-connections : syntax -> void + (define (add-syntax-connections stx) + (let ([module-codes (map compile (expand-syntax-top-level-with-compile-time-evals/flatten stx))]) + (for-each + (λ (module-code) + (when (compiled-module-expression? module-code) + (let* ([name (extract-module-name stx)] + [base + (build-module-filename + (if (regexp-match #rx"^," name) + (substring name 1 (string-length name)) + (build-path (current-load-relative-directory) name)))]) + (add-module-code-connections base module-code)))) + module-codes))) + + (define (build-module-filename str) + (let ([try (λ (ext) + (let ([tst (bytes->path (bytes-append (path->bytes str) ext))]) + (and (file-exists? tst) + tst)))]) + (or (try #".ss") + (try #".scm") + (try #"") + str))) + + ;; add-filename-connections : string -> void + (define (add-filename-connections filename) + (add-module-code-connections filename (get-module-code filename))) + + (define (add-module-code-connections module-name module-code) + (unless (hash-ref visited-hash-table module-name (λ () #f)) + (async-channel-put progress-channel (format adding-file module-name)) + (hash-set! visited-hash-table module-name #t) + (let ([import-assoc (module-compiled-imports module-code)]) + (for-each + (λ (line) + (let* ([level (car line)] + [mpis (cdr line)] + [requires (extract-filenames mpis module-name)]) + (for-each (λ (require) + (add-connection module-name + (req-filename require) + (req-key require) + level) + (add-filename-connections (req-filename require))) + requires))) + import-assoc)))) + + ;; add-connection : string string boolean number -> void + ;; name-original and name-require and the identifiers for those paths and + ;; original-filename? and require-filename? are booleans indicating if the names + ;; are filenames. + (define (add-connection name-original name-require req-sym require-depth) + (async-channel-put connection-channel (list name-original + name-require + req-sym + require-depth))) + + (define (extract-module-name stx) + (syntax-case stx () + [(module m-name rest ...) + (and (eq? (syntax-e (syntax module)) 'module) + (identifier? (syntax m-name))) + (format "~a" (syntax->datum (syntax m-name)))] + [else unknown-module-name])) + + ;; extract-filenames : (listof (union symbol module-path-index)) string[module-name] -> + ;; (listof req) + (define (extract-filenames direct-requires base) + (let loop ([direct-requires direct-requires]) + (cond + [(null? direct-requires) null] + [else + + (let ([dr (car direct-requires)]) + (if (module-path-index? dr) + (let ([path (resolve-module-path-index dr base)]) + (if (path? path) + (cons (make-req (simplify-path path) (get-key dr)) + (loop (cdr direct-requires))) + (loop (cdr direct-requires)))) + (loop (cdr direct-requires))))]))) + + (define (get-key dr) + (and (module-path-index? dr) + (let-values ([(a b) (module-path-index-split dr)]) + (cond + [(symbol? a) 'lib] + [(pair? a) + (and (symbol? (car a)) + (car a))] + [else #f]))))) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss new file mode 100644 index 0000000000..a51bd03f05 --- /dev/null +++ b/collects/drscheme/private/module-language.ss @@ -0,0 +1,602 @@ +#lang scheme/base + +(provide module-language@) +(require scheme/unit + scheme/class + mred + compiler/embed + launcher + framework + string-constants + "drsig.ss" + scheme/contract) + +(define op (current-output-port)) +(define (oprintf . args) (apply fprintf op args)) + +(define-unit module-language@ + (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 + (instantiate 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) + (cond + [(eq? key 'drscheme:autocomplete-words) + (drscheme:language-configuration:get-all-scheme-manual-keywords)] + [else (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 + (apply + 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) + (begin + (display "Module Language: " (current-error-port)) + (display hopeless-message (current-error-port)) + (newline (current-error-port)) + (λ x eof)) + (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] + [module-name-prefix (get-module-name-prefix path)] + + [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)) + (cond + [(= 1 iteration-number) + #`(current-module-declare-name + (if #,path + (make-resolved-module-path '#,path) + #f))] + [(= 2 iteration-number) + (let ([super-result (super-thunk)]) + (if (eof-object? super-result) + (raise-syntax-error 'Module\ Language hopeless-message) + (let-values ([(name new-module) + (transform-module path super-result)]) + (set! module-name name) + new-module)))] + [(= 3 iteration-number) + (let ([super-result (super-thunk)]) + (if (eof-object? super-result) + #`(begin + (current-module-declare-name #f) + #,(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))))) + (raise-syntax-error + 'module-language + "there can only be one expression in the definitions window" + super-result)))] + [(= 4 iteration-number) + (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-message + (string-append + "There must be a module in the\n" + "definitions window. Try starting your program with\n" + "\n" + " #lang scheme\n" + "\n" + "and clicking ‘Run’.")) + + ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) + (define (module-language-config-panel parent) + (define new-parent + (instantiate 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 (instantiate group-box-panel% () + (parent new-parent) + (label (string-constant ml-cp-collection-paths)))) + + (define args-panel (instantiate 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 (instantiate list-box% () + (parent cp-panel) + (choices '("a" "b" "c")) + (label #f) + (callback (λ (x y) (update-buttons))))) + (define button-panel (instantiate 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) (raise-callback)))) + (define lower-button (make-object button% (string-constant ml-cp-lower) button-panel + (λ (x y) (lower-callback)))) + + (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 (lower-callback) + (let* ([sel (send lb get-selection)] + [vec (get-lb-vector)] + [below (vector-ref vec (+ sel 1))]) + (vector-set! vec (+ sel 1) (vector-ref vec sel)) + (vector-set! vec sel below) + (set-lb-vector vec) + (send lb set-selection (+ sel 1)) + (update-buttons))) + + (define (raise-callback) + (let* ([sel (send lb get-selection)] + [vec (get-lb-vector)] + [above (vector-ref vec (- sel 1))]) + (vector-set! vec (- sel 1) (vector-ref vec sel)) + (vector-set! vec sel above) + (set-lb-vector vec) + (send lb set-selection (- sel 1)) + (update-buttons))) + + (define (get-lb-vector) + (list->vector + (let loop ([n 0]) + (cond + [(= n (send lb get-number)) null] + [else (cons (cons (send lb get-string n) + (send lb get-data n)) + (loop (+ n 1)))])))) + + (define (set-lb-vector vec) + (send lb clear) + (let loop ([n 0]) + (cond + [(= n (vector-length vec)) (void)] + [else (send lb append (car (vector-ref vec n))) + (send lb set-data n (cdr (vector-ref vec n))) + (loop (+ n 1))]))) + + (define (get-collection-paths) + (let loop ([n 0]) + (cond + [(= n (send lb get-number)) null] + [else + (let ([data (send lb get-data n)]) + (cons (if data + 'default + (send lb get-string n)) + (loop (+ n 1))))]))) + + (define (install-collection-paths paths) + (send lb clear) + (for-each (λ (cp) + (if (symbol? cp) + (send lb append + (string-constant ml-cp-default-collection-path) + #t) + (send lb append cp #f))) + paths)) + + (define (get-command-line-args) + (let ([str (send args-text-box get-value)]) + (let ([read-res (parameterize ([read-accept-graph #f]) + (with-handlers ([exn:fail:read? (λ (x) #())]) + (read (open-input-string str))))]) + (cond + [(and (vector? read-res) + (andmap string? (vector->list read-res))) + read-res] + [else #()])))) + + (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 syntax -> (values symbol[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 . rest) + (syntax-case stx () + [(form name . _) + (let ([v-name (syntax name)]) + (when filename + (check-filename-matches filename + (syntax->datum (syntax name)) + stx)) + (thread-cell-set! hopeless-repl #f) + (values v-name + ;; rewrite the module to use the scheme/base version of `module' + (datum->syntax stx + (cons (datum->syntax #'here + 'module + #'form) + #'rest) + stx)))] + [_ + (raise-syntax-error 'module-language + "module form is missing a name" + stx)])] + [module (raise-syntax-error 'module-language + "bad syntax" + stx)] + [else + (raise-syntax-error 'module-language + "only module expressions are allowed" + stx)])) + + ;; get-module-name-prefix : path -> string + ;; returns the symbol that gets passed the current-module-name-prefix + ;; while evaluating/expanding the module. + (define (get-module-name-prefix path) + (and path + (let-values ([(base name dir) + (split-path (normal-case-path (simplify-path (expand-user-path path) #f)))]) + (string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base))))))) + + ;; build-name : path -> symbol + (define (build-name pre-path) + (let ([path (normal-case-path (simplify-path (expand-user-path pre-path) #f))]) + (let-values ([(base name dir) (split-path path)]) + (string->symbol (format ",~a" + (bytes->string/latin-1 + (path->bytes + (build-path + base + (remove-suffix (path->string name)))))))))) + + ;; 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 datum unexpanded-stx) + (unless (symbol? datum) + (raise-syntax-error 'module-language "unexpected object in name position of module" + unexpanded-stx)) + (let-values ([(base name dir?) (split-path filename)]) + (let* ([expected (string->symbol (remove-suffix (path->string name)))]) + (unless (equal? expected datum) + (raise-syntax-error + 'module-language + (format "module name doesn't match saved filename, got ~s and expected ~a" + datum + expected) + unexpanded-stx))))) + + (define re:check-filename-matches #rx"^(.*)\\.[^.]*$") + (define (remove-suffix str) + (let ([m (regexp-match re:check-filename-matches str)]) + (if m + (cadr m) + str))) + + + (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]) + (cond + [(pos . >= . last-pos) last-pos] + [else + (let ([char (get-character pos)]) + (cond + [(char-whitespace? char) + (loop (+ pos 1))] + [else 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)))) diff --git a/collects/drscheme/private/multi-file-search.ss b/collects/drscheme/private/multi-file-search.ss new file mode 100644 index 0000000000..15c8cc1ab7 --- /dev/null +++ b/collects/drscheme/private/multi-file-search.ss @@ -0,0 +1,716 @@ + +#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))))) diff --git a/collects/drscheme/private/number-snip.ss b/collects/drscheme/private/number-snip.ss new file mode 100644 index 0000000000..0cb5347273 --- /dev/null +++ b/collects/drscheme/private/number-snip.ss @@ -0,0 +1,9 @@ +(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)) diff --git a/collects/drscheme/private/recon.ss b/collects/drscheme/private/recon.ss new file mode 100644 index 0000000000..19993c224e --- /dev/null +++ b/collects/drscheme/private/recon.ss @@ -0,0 +1,19 @@ +#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]))])) \ No newline at end of file diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss new file mode 100644 index 0000000000..1ce0cd1677 --- /dev/null +++ b/collects/drscheme/private/rep.ss @@ -0,0 +1,1835 @@ +#lang scheme/base + +#| + +TODO +- should a GC should happen on each execution? (or perhaps better, each kill?) +- front-end methods have new signature + + +|# +; =Kernel= means in DrScheme's thread and parameterization +; +; =User= means the user's thread and parameterization +; +; =Handler= means in the handler thread of some eventspace; it must +; be combined with either =Kernel= or =User= + +;; WARNING: printf is rebound in this module to always use the +;; original stdin/stdout of drscheme, instead of the +;; user's io ports, to aid any debugging printouts. +;; (esp. useful when debugging the users's io) + +(require scheme/class + scheme/path + scheme/pretty + scheme/unit + scheme/list + "drsig.ss" + string-constants + setup/xref + scheme/gui/base + framework + browser/external) + +(provide rep@ with-stacktrace-name) + +(define-struct unsaved-editor (editor)) + +(define stacktrace-runtime-name + (string->uninterned-symbol "this-is-the-funny-name")) + +;; this function wraps its argument expression in some code in a non-tail manner +;; so that a new name gets put onto the mzscheme stack. DrScheme's exception +;; handlers trims the stack starting at this point to avoid showing drscheme's +;; internals on the stack in the REPL. +(define call-with-stacktrace-name + (eval `(let ([,stacktrace-runtime-name + (lambda (thunk) + (begin0 + (thunk) + (void)))]) + ,stacktrace-runtime-name) + (make-base-namespace))) + +(define-syntax-rule (with-stacktrace-name expr) + (call-with-stacktrace-name (lambda () expr))) + +(define no-breaks-break-parameterization + (parameterize-break + #f + (current-break-parameterization))) + +(define-unit rep@ + (import (prefix drscheme:init: drscheme:init^) + (prefix drscheme:language-configuration: drscheme:language-configuration/internal^) + (prefix drscheme:language: drscheme:language^) + (prefix drscheme:app: drscheme:app^) + (prefix drscheme:frame: drscheme:frame^) + (prefix drscheme:unit: drscheme:unit^) + (prefix drscheme:text: drscheme:text^) + (prefix drscheme:help-desk: drscheme:help-desk^) + (prefix drscheme:debug: drscheme:debug^) + [prefix drscheme:eval: drscheme:eval^]) + (export (rename drscheme:rep^ + [-text% text%] + [-text<%> text<%>])) + + (define -text<%> + (interface ((class->interface text%) + text:ports<%> + editor:file<%> + scheme:text<%> + color:text<%> + text:ports<%>) + reset-highlighting + highlight-errors + highlight-errors/exn + + get-user-custodian + get-user-eventspace + get-user-thread + get-user-namespace + + get-definitions-text + + kill-evaluation + + display-results + + run-in-evaluation-thread + after-many-evals + + shutdown + + get-error-ranges + reset-error-ranges + + reset-console + + copy-prev-previous-expr + copy-next-previous-expr + copy-previous-expr + + + initialize-console + + reset-pretty-print-width + + get-prompt + insert-prompt + get-context)) + + (define context<%> + (interface () + ensure-rep-shown ;; (interactions-text -> void) + ;; make the rep visible in the frame + + needs-execution ;; (-> boolean) + ;; ask if things have changed that would mean the repl is out + ;; of sync with the program being executed in it. + + enable-evaluation ;; (-> void) + ;; make the context enable all methods of evaluation + ;; (disable buttons, menus, etc) + + disable-evaluation ;; (-> void) + ;; make the context enable all methods of evaluation + ;; (disable buttons, menus, etc) + + set-breakables ;; (union thread #f) (union custodian #f) -> void + ;; the context might initiate breaks or kills to + ;; the thread passed to this function + + get-breakables ;; -> (values (union thread #f) (union custodian #f)) + ;; returns the last values passed to set-breakables. + + reset-offer-kill ;; (-> void) + ;; the next time the break button is pushed, it will only + ;; break. (if the break button is clicked twice without + ;; this method being called in between, it will offer to + ;; kill the user's program) + + update-running ;; (boolean -> void) + ;; a callback to indicate that the repl may have changed its running state + ;; use the repls' get-in-evaluation? method to find out what the current state is. + + clear-annotations ;; (-> void) + ;; clear any error highlighting context + + get-directory ;; (-> (union #f string[existing directory])) + ;; returns the directory that should be the default for + ;; the `current-directory' and `current-load-relative-directory' + ;; parameters in the repl. + )) + + (define sized-snip<%> + (interface ((class->interface snip%)) + ;; get-character-width : -> number + ;; returns the number of characters wide the snip is, + ;; for use in pretty printing the snip. + get-character-width)) + + ;; current-language-settings : (parameter language-setting) + ;; set to the current language and its setting on the user's thread. + (define current-language-settings (make-parameter #f)) + + ;; current-rep : (parameter (union #f (instanceof rep:text%))) + ;; the repl that controls the evaluation in this thread. + (define current-rep (make-parameter #f)) + + ;; a port that accepts values for printing in the repl + (define current-value-port (make-parameter #f)) + + ;; drscheme-error-display-handler : (string (union #f exn) -> void + ;; =User= + ;; the timing is a little tricky here. + ;; the file icon must appear before the error message in the text, so that happens first. + ;; the highlight must be set after the error message, because inserting into the text resets + ;; the highlighting. + (define (drscheme-error-display-handler msg exn) + (let* ([cut-stack (if (and (exn? exn) + (main-user-eventspace-thread?)) + (cut-out-top-of-stack exn) + '())] + [srclocs-stack (filter values (map cdr cut-stack))] + [stack + (filter + values + (map (λ (srcloc) + (let ([source (srcloc-source srcloc)] + [pos (srcloc-position srcloc)] + [span (srcloc-span srcloc)]) + (and source pos span + srcloc))) + srclocs-stack))] + [src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + (if (null? stack) + '() + (list (car srclocs-stack))))]) + + ;; for use in debugging the stack trace stuff + #; + (when (exn? exn) + (print-struct #t) + (for-each + (λ (frame) (printf " ~s\n" frame)) + (continuation-mark-set->context (exn-continuation-marks exn))) + (printf "\n")) + + (drscheme:debug:error-display-handler/stacktrace msg exn stack))) + + (define (main-user-eventspace-thread?) + (let ([rep (current-rep)]) + (and rep + (eq? (eventspace-handler-thread (send rep get-user-eventspace)) + (current-thread))))) + + (define (cut-out-top-of-stack exn) + (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))]) + (let loop ([stack initial-stack]) + (cond + [(null? stack) + (unless (exn:break? exn) + ;; give break exn's a free pass on this one. + ;; sometimes they get raised in a funny place. + ;; (see call-with-break-parameterization below) + (unless (null? initial-stack) + ;; sometimes, mzscheme just doesn't have any backtrace all. in that case, + ;; don't print anything either. + (fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))) + initial-stack] + [else + (let ([top (car stack)]) + (cond + [(cut-here? top) null] + [else (cons top (loop (cdr stack)))]))])))) + + ;; is-cut? : any symbol -> boolean + ;; determines if this stack entry is drscheme's barrier in the stacktrace + (define (cut-here? top) + (and (pair? top) + (let ([fn-name (car top)]) + (eq? fn-name stacktrace-runtime-name)))) + + (define drs-bindings-keymap (make-object keymap:aug-keymap%)) + + (let ([with-drs-frame + (λ (obj f) + (when (is-a? obj editor<%>) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame drscheme:unit:frame%) + (f frame)))))))]) + + (send drs-bindings-keymap add-function + "search-help-desk" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) + (cond + [(is-a? obj text%) + (let* ([start (send obj get-start-position)] + [end (send obj get-end-position)] + [str (if (= start end) + (drscheme:unit:find-symbol obj start) + (send obj get-text start end))]) + (if (equal? "" str) + (drscheme:help-desk:help-desk) + (let ([language (let ([canvas (send obj get-canvas)]) + (and canvas + (let ([tlw (send canvas get-top-level-window)]) + (and (is-a? tlw drscheme:unit:frame<%>) + (send (send tlw get-definitions-text) + get-next-settings)))))]) + (drscheme:help-desk:help-desk str))))] + [else + (drscheme:help-desk:help-desk)]))))) + + (send drs-bindings-keymap add-function + "execute" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) + (send frame execute-callback))))) + + (let ([shift-focus + (λ (adjust frame) + (let ([candidates (adjust (append + (send frame get-definitions-canvases) + (send frame get-interactions-canvases)))]) + (let loop ([cs candidates]) + (cond + [(null? cs) (send (car candidates) focus)] + [else + (let ([c (car cs)]) + (if (send c has-focus?) + (send (if (null? (cdr cs)) + (car candidates) + (cadr cs)) + focus) + (loop (cdr cs))))]))))]) + (send drs-bindings-keymap add-function + "toggle-focus-between-definitions-and-interactions" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (shift-focus values frame))))) + (send drs-bindings-keymap add-function + "toggle-focus-between-definitions-and-interactions backwards" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (shift-focus reverse frame)))))) + (send drs-bindings-keymap add-function + "next-tab" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (send frame next-tab))))) + (send drs-bindings-keymap add-function + "prev-tab" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (send frame prev-tab)))))) + + (send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions") + (send drs-bindings-keymap map-function "c:x;p" "toggle-focus-between-definitions-and-interactions backwards") + (send drs-bindings-keymap map-function "c:f6" "toggle-focus-between-definitions-and-interactions") + (send drs-bindings-keymap map-function "f5" "execute") + (send drs-bindings-keymap map-function "f1" "search-help-desk") + (send drs-bindings-keymap map-function "c:tab" "next-tab") + (send drs-bindings-keymap map-function "c:s:tab" "prev-tab") + (send drs-bindings-keymap map-function "d:s:right" "next-tab") + (send drs-bindings-keymap map-function "d:s:left" "prev-tab") + (send drs-bindings-keymap map-function "c:pagedown" "next-tab") + (send drs-bindings-keymap map-function "c:pageup" "prev-tab") + + (define (get-drs-bindings-keymap) drs-bindings-keymap) + + ;; drs-bindings-keymap-mixin : + ;; ((implements editor:keymap<%>) -> (implements editor:keymap<%>)) + ;; for any x that is an instance of the resulting class, + ;; (is-a? (send (send x get-canvas) get-top-level-frame) drscheme:unit:frame%) + (define drs-bindings-keymap-mixin + (mixin (editor:keymap<%>) (editor:keymap<%>) + (define/override (get-keymaps) + (cons drs-bindings-keymap (super get-keymaps))) + (super-instantiate ()))) + + ;; Max length of output queue (user's thread blocks if the + ;; queue is full): + (define output-limit-size 2000) + + (define (printf . args) (apply fprintf drscheme:init:original-output-port args)) + + (define setup-scheme-interaction-mode-keymap + (λ (keymap) + (send keymap add-function "put-previous-sexp" + (λ (text event) + (send text copy-prev-previous-expr))) + (send keymap add-function "put-next-sexp" + (λ (text event) + (send text copy-next-previous-expr))) + + (keymap:send-map-function-meta keymap "p" "put-previous-sexp") + (keymap:send-map-function-meta keymap "n" "put-next-sexp") + (send keymap map-function "c:up" "put-previous-sexp") + (send keymap map-function "c:down" "put-next-sexp"))) + + (define scheme-interaction-mode-keymap (make-object keymap:aug-keymap%)) + (setup-scheme-interaction-mode-keymap scheme-interaction-mode-keymap) + + (define drs-font-delta (make-object style-delta% 'change-family 'decorative)) + + (define output-delta (make-object style-delta%)) ; used to be 'change-weight 'bold + (define result-delta (make-object style-delta%)) ; used to be 'change-weight 'bold + (define error-delta (make-object style-delta% + 'change-style + 'italic)) + (send error-delta set-delta-foreground (make-object color% 255 0 0)) + (send result-delta set-delta-foreground (make-object color% 0 0 175)) + (send output-delta set-delta-foreground (make-object color% 150 0 150)) + + (define error-text-style-delta (make-object style-delta%)) + (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) + + (define grey-delta (make-object style-delta%)) + (send grey-delta set-delta-foreground "GREY") + + (define welcome-delta (make-object style-delta% 'change-family 'decorative)) + (define click-delta (gui-utils:get-clickback-delta)) + (define red-delta (make-object style-delta%)) + (define dark-green-delta (make-object style-delta%)) + (send* red-delta + (copy welcome-delta) + (set-delta-foreground "RED")) + (send* dark-green-delta + (copy welcome-delta) + (set-delta-foreground "dark green")) + (define warning-style-delta (make-object style-delta% 'change-bold)) + (send* warning-style-delta + (set-delta-foreground "BLACK") + (set-delta-background "YELLOW")) + (define (get-welcome-delta) welcome-delta) + (define (get-dark-green-delta) dark-green-delta) + + ;; is-default-settings? : language-settings -> boolean + ;; determines if the settings in `language-settings' + ;; correspond to the default settings of the language. + (define (is-default-settings? language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + default-settings? + (drscheme:language-configuration:language-settings-settings language-settings))) + + (define (extract-language-name language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-language-name)) + (define (extract-language-style-delta language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-style-delta)) + (define (extract-language-url language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-language-url)) + + (define-struct sexp (left right prompt)) + + (define console-max-save-previous-exprs 30) + (let* ([list-of? (λ (p?) + (λ (l) + (and (list? l) + (andmap p? l))))] + [snip/string? (λ (s) (or (is-a? s snip%) (string? s)))] + [list-of-snip/strings? (list-of? snip/string?)] + [list-of-lists-of-snip/strings? (list-of? list-of-snip/strings?)]) + (preferences:set-default + 'drscheme:console-previous-exprs + null + list-of-lists-of-snip/strings?)) + (let ([marshall + (λ (lls) + (map (λ (ls) + (list + (apply + string-append + (reverse + (map (λ (s) + (cond + [(is-a? s string-snip%) + (send s get-text 0 (send s get-count))] + [(string? s) s] + [else "'non-string-snip"])) + ls))))) + lls))] + [unmarshall (λ (x) x)]) + (preferences:set-un/marshall + 'drscheme:console-previous-exprs + marshall unmarshall)) + + (define color? ((get-display-depth) . > . 8)) + + ;; instances of this interface provide a context for a rep:text% + ;; its connection to its graphical environment (ie frame) for + ;; error display and status infromation is all mediated + ;; through an instance of this interface. + + (define file-icon + (let ([bitmap + (make-object bitmap% + (build-path (collection-path "icons") "file.gif"))]) + (if (send bitmap ok?) + (make-object image-snip% bitmap) + (make-object string-snip% "[open file]")))) + + + ;; insert/delta : (instanceof text%) (union snip string) (listof style-delta%) *-> (values number number) + ;; inserts the string/stnip into the text at the end and changes the + ;; style of the newly inserted text based on the style deltas. + (define (insert/delta text s . deltas) + (let ([before (send text last-position)]) + (send text insert s before before #f) + (let ([after (send text last-position)]) + (for-each (λ (delta) + (when (is-a? delta style-delta%) + (send text change-style delta before after))) + deltas) + (values before after)))) + + (define text-mixin + (mixin ((class->interface text%) + text:ports<%> + editor:file<%> + scheme:text<%> + color:text<%> + text:ports<%>) + (-text<%>) + (init-field context) + (inherit auto-wrap + begin-edit-sequence + change-style + clear-box-input-port + clear-undos + clear-input-port + clear-output-ports + delete + delete/io + end-edit-sequence + erase + find-snip + find-string + freeze-colorer + get-active-canvas + get-admin + get-can-close-parent + get-canvases + get-character + get-end-position + get-err-port + get-extent + get-focus-snip + get-in-port + get-in-box-port + get-insertion-point + get-out-port + get-regions + get-snip-position + get-start-position + get-styles-fixed + get-style-list + get-text + get-top-level-window + get-unread-start-point + get-value-port + in-edit-sequence? + insert + insert-before + insert-between + invalidate-bitmap-cache + is-frozen? + is-locked? + last-position + line-location + lock + paragraph-start-position + position-line + position-paragraph + port-name-matches? + release-snip + reset-input-box + reset-regions + run-after-edit-sequence + scroll-to-position + send-eof-to-in-port + set-allow-edits + set-caret-owner + set-clickback + set-insertion-point + set-position + set-styles-sticky + set-styles-fixed + set-unread-start-point + split-snip + thaw-colorer) + + (define definitions-text 'not-yet-set-definitions-text) + (define/public (set-definitions-text dt) (set! definitions-text dt)) + (define/public (get-definitions-text) definitions-text) + + (unless (is-a? context context<%>) + (error 'drscheme:rep:text% + "expected an object that implements drscheme:rep:context<%> as initialization argument, got: ~e" + context)) + + (define/public (get-context) context) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; User -> Kernel ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; =User= (probably doesn't matter) + (define/private queue-system-callback + (λ (ut thunk [always? #f]) + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback + (λ () + (when (or always? (eq? ut (get-user-thread))) + (thunk))) + #f)))) + + ;; =User= + (define/private queue-system-callback/sync + (λ (ut thunk) + (let ([s (make-semaphore 0)]) + (queue-system-callback + ut + (λ () + (when (eq? ut (get-user-thread)) + (thunk)) + (semaphore-post s)) + #t) + (semaphore-wait s)))) + + ;; display-results : (listof TST) -> void + ;; prints each element of anss that is not void as values in the REPL. + (define/public (display-results anss) ; =User=, =Handler=, =Breaks= + (display-results/void (filter (λ (x) (not (void? x))) anss))) + + ;; display-results : (listof TST) -> void + ;; prints each element of anss in the REPL. + (define/public (display-results/void anss) ; =User=, =Handler=, =Breaks= + (for-each + (λ (v) + (let* ([ls (current-language-settings)] + [lang (drscheme:language-configuration:language-settings-language ls)] + [settings (drscheme:language-configuration:language-settings-settings ls)]) + (send lang render-value/format + v + settings + (get-value-port) + (get-repl-char-width)))) + anss)) + + ;; get-repl-char-width : -> (and/c exact? integer?) + ;; returns the width of the repl in characters, or 80 if the + ;; answer cannot be found. + (define/private (get-repl-char-width) + (let ([admin (get-admin)] + [standard (send (get-style-list) find-named-style "Standard")]) + (if (and admin standard) + (let ([bw (box 0)]) + (send admin get-view #f #f bw #f) + (let* ([dc (send admin get-dc)] + [standard-font (send standard get-font)] + [old-font (send dc get-font)]) + (send dc set-font standard-font) + (let* ([char-width (send dc get-char-width)] + [answer (inexact->exact (floor (/ (unbox bw) char-width)))]) + (send dc set-font old-font) + answer))) + 80))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Error Highlighting ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) + (define error-ranges #f) + (define/public (get-error-ranges) error-ranges) + (define internal-reset-callback void) + (define internal-reset-error-arrows-callback void) + (define/public (reset-error-ranges) + (internal-reset-callback) + (internal-reset-error-arrows-callback)) + + ;; highlight-error : file number number -> void + (define/public (highlight-error file start end) + (highlight-errors (list (make-srcloc file #f #f start (- end start))) #f)) + + ;; highlight-errors/exn : exn -> void + ;; highlights all of the errors associated with the exn (incl. arrows) + (define/public (highlight-errors/exn exn) + (let ([locs (cond + [(exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn)] + [else '()])]) + (highlight-errors locs #f))) + + ;; =Kernel= =handler= + ;; highlight-errors : (listof srcloc) + ;; (union #f (listof srcloc)) + ;; -> (void) + (define/public (highlight-errors raw-locs raw-error-arrows) + (let* ([cleanup-locs + (λ (locs) + (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>) + (number? (srcloc-position loc)) + (number? (srcloc-span loc)))) + (map (λ (srcloc) + (cond + [(send definitions-text port-name-matches? (srcloc-source srcloc)) + (make-srcloc definitions-text + (srcloc-line srcloc) + (srcloc-column srcloc) + (srcloc-position srcloc) + (srcloc-span srcloc))] + [(port-name-matches? (srcloc-source srcloc)) + (make-srcloc this + (srcloc-line srcloc) + (srcloc-column srcloc) + (srcloc-position srcloc) + (srcloc-span srcloc))] + [(unsaved-editor? (srcloc-source srcloc)) + (make-srcloc (unsaved-editor-editor (srcloc-source srcloc)) + (srcloc-line srcloc) + (srcloc-column srcloc) + (srcloc-position srcloc) + (srcloc-span srcloc))] + [else srcloc])) + locs)))] + [locs (cleanup-locs raw-locs)] + [error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))]) + + (reset-highlighting) + + (set! error-ranges locs) + + (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs) + + (when color? + (let ([resets + (map (λ (loc) + (let* ([file (srcloc-source loc)] + [start (- (srcloc-position loc) 1)] + [span (srcloc-span loc)] + [finish (+ start span)]) + (send file highlight-range start finish (drscheme:debug:get-error-color) #f #f 'high))) + locs)]) + + (when (and definitions-text error-arrows) + (let ([filtered-arrows + (remove-duplicate-error-arrows + (filter + (λ (arr) (embedded-in? (srcloc-source arr) definitions-text)) + error-arrows))]) + (send definitions-text set-error-arrows filtered-arrows))) + + (set! internal-reset-callback + (λ () + (set! error-ranges #f) + (when definitions-text + (send definitions-text set-error-arrows #f)) + (set! internal-reset-callback void) + (for-each (λ (x) (x)) resets))))) + + (let* ([first-loc (and (pair? locs) (car locs))] + [first-file (and first-loc (srcloc-source first-loc))] + [first-start (and first-loc (- (srcloc-position first-loc) 1))] + [first-span (and first-loc (srcloc-span first-loc))]) + + (when (and first-loc first-start first-span) + (let ([first-finish (+ first-start first-span)]) + (when (eq? first-file definitions-text) ;; only move set the cursor in the defs window + (send first-file set-position first-start first-start)) + (send first-file scroll-to-position first-start #f first-finish))) + + (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) + + (when first-loc + (send first-file set-caret-owner (get-focus-snip) 'global))))) + + (define/public (reset-highlighting) + (reset-error-ranges)) + + ;; remove-duplicate-error-arrows : (listof X) -> (listof X) + ;; duplicate arrows point from and to the same place -- only + ;; need one arrow for each pair of locations they point to. + (define/private (remove-duplicate-error-arrows error-arrows) + (let ([ht (make-hash)]) + (let loop ([arrs error-arrows] + [n 0]) + (unless (null? arrs) + (hash-set! ht (car arrs) n) + (loop (cdr arrs) (+ n 1)))) + (let* ([unsorted (hash-map ht list)] + [sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))] + [arrs (map car sorted)]) + arrs))) + + (define/private (embedded-in? txt-inner txt-outer) + (let loop ([txt-inner txt-inner]) + (cond + [(eq? txt-inner txt-outer) #t] + [else (let ([admin (send txt-inner get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (loop (send (send (send admin get-snip) get-admin) get-editor))))]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; specialization + ;; + + (define/override (after-io-insertion) + (super after-io-insertion) + (let ([canvas (get-active-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (let ([tab (send definitions-text get-tab)]) + (when (eq? (send frame get-current-tab) tab) + (send context ensure-rep-shown this))))))) + + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (cond + [(in-edit-sequence?) + (set! had-an-insert (cons (cons start len) had-an-insert))] + [else (update-after-insert start len)])) + + ;; private field + (define had-an-insert '()) + + (define/augment (after-edit-sequence) + (inner (void) after-edit-sequence) + (let ([to-clean had-an-insert]) + (set! had-an-insert '()) + (for-each + (lambda (pr) + (update-after-insert (car pr) (cdr pr))) + to-clean))) + + (define/private (update-after-insert start len) + (unless inserting-prompt? + (reset-highlighting)) + (when (and prompt-position (< start prompt-position)) + + ;; trim extra space, according to preferences + #; + (let* ([start (get-repl-header-end)] + [end (get-insertion-point)] + [space (- end start)] + [pref (preferences:get 'drscheme:repl-buffer-size)]) + (when (car pref) + (let ([max-space (* 1000 (cdr pref))]) + (when (space . > . max-space) + (let ([to-delete-end (+ start (- space max-space))]) + (delete/io start to-delete-end)))))) + + (set! prompt-position (get-unread-start-point)) + (reset-regions (append (all-but-last (get-regions)) + (list (list prompt-position 'end)))))) + + (define/augment (after-delete x y) + (unless inserting-prompt? + (reset-highlighting)) + (inner (void) after-delete x y)) + + (define/override get-keymaps + (λ () + (cons scheme-interaction-mode-keymap (super get-keymaps)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Evaluation ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define/public (eval-busy?) + (not (and (get-user-thread) + (thread-running? (get-user-thread))))) + + (field (user-language-settings #f) + (user-custodian-parent #f) + (memory-killed-thread #f) + (user-custodian #f) + (custodian-limit (and (custodian-memory-accounting-available?) + (preferences:get 'drscheme:limit-memory))) + (user-eventspace-box (make-weak-box #f)) + (user-namespace-box (make-weak-box #f)) + (user-eventspace-main-thread #f) + (user-break-parameterization #f) + + ;; user-exit-code (union #f (integer-in 0 255)) + ;; #f indicates that exit wasn't called. Integer indicates exit code + (user-exit-code #f)) + + (define/public (get-user-language-settings) user-language-settings) + (define/public (get-user-custodian) user-custodian) + (define/public (get-user-eventspace) (weak-box-value user-eventspace-box)) + (define/public (get-user-thread) user-eventspace-main-thread) + (define/public (get-user-namespace) (weak-box-value user-namespace-box)) + (define/pubment (get-user-break-parameterization) user-break-parameterization) ;; final method + (define/pubment (get-custodian-limit) custodian-limit) + (define/pubment (set-custodian-limit c) (set! custodian-limit c)) + (field (in-evaluation? #f) + (ask-about-kill? #f)) + (define/public (get-in-evaluation?) in-evaluation?) + + (define/private (insert-warning message) + (begin-edit-sequence) + (let ([start (get-insertion-point)]) + (insert-before message) + (let ([end (get-insertion-point)]) + (change-style warning-style-delta start end))) + (insert-before "\n") + (end-edit-sequence)) + + (field (already-warned? #f)) + + (define/private (cleanup) + (set! in-evaluation? #f) + (update-running #f) + (unless (and (get-user-thread) (thread-running? (get-user-thread))) + (lock #t) + (unless shutting-down? + (no-user-evaluation-message + (let ([canvas (get-active-canvas)]) + (and canvas + (send canvas get-top-level-window))) + user-exit-code + (not (thread-running? memory-killed-thread)))))) + (field (need-interaction-cleanup? #f)) + + (define/private (no-user-evaluation-message frame exit-code memory-killed?) + (let* ([new-limit (and custodian-limit (+ (* 1024 1024 128) custodian-limit))] + [ans (message-box/custom + (string-constant evaluation-terminated) + (string-append + (string-constant evaluation-terminated-explanation) + (if exit-code + (string-append + "\n\n" + (if (zero? exit-code) + (string-constant exited-successfully) + (format (string-constant exited-with-error-code) exit-code))) + "") + (if memory-killed? + (string-append + "\n\n" + (string-constant program-ran-out-of-memory)) + "")) + (string-constant ok) + #f + (and memory-killed? + new-limit + (format "Increase memory limit to ~a megabytes" + (floor (/ new-limit 1024 1024)))) + frame + '(default=1 stop) + )]) + (when (equal? ans 3) + (set-custodian-limit new-limit) + (preferences:set 'drscheme:limit-memory new-limit)) + (void))) + + (define/private (cleanup-interaction) ; =Kernel=, =Handler= + (set! need-interaction-cleanup? #f) + (begin-edit-sequence) + (set-caret-owner #f 'display) + (cleanup) + (end-edit-sequence) + (send context set-breakables #f #f) + (send context enable-evaluation)) + + (define/augment (submit-to-port? key) + (and prompt-position + (only-whitespace-after-insertion-point) + (submit-predicate this prompt-position))) + + (define/private (only-whitespace-after-insertion-point) + (let ([start (get-start-position)] + [end (get-end-position)]) + (and (= start end) + (let loop ([pos start]) + (cond + [(= pos (last-position)) #t] + [else (and (char-whitespace? (get-character pos)) + (loop (+ pos 1)))]))))) + + (define/augment (on-submit) + (inner (void) on-submit) + (when (and (get-user-thread) + (thread-running? (get-user-thread))) + ;; the -2 drops the last newline from history (why -2 and not -1?!) + (save-interaction-in-history prompt-position (- (last-position) 2)) + + (let* ([old-regions (get-regions)] + [abl (all-but-last old-regions)] + [lst (last old-regions)]) + (reset-regions (append abl (list (list (list-ref lst 0) (last-position)))))) + + (let ([needs-execution (send context needs-execution)]) + (when (if (preferences:get 'drscheme:execute-warning-once) + (and (not already-warned?) + needs-execution) + needs-execution) + (set! already-warned? #t) + (insert-warning needs-execution))) + + ;; lets us know we are done with this one interaction + ;; (since there may be multiple expressions at the prompt) + (send-eof-to-in-port) + + (set! prompt-position #f) + (evaluate-from-port + (get-in-port) + #f + (λ () + ;; clear out the eof object if it wasn't consumed + (clear-input-port))))) + + (inherit get-backward-sexp) + (define/override (on-local-char key) + (let ([start (get-start-position)] + [end (get-end-position)] + [code (send key get-key-code)]) + (cond + [(not (or (eq? code 'numpad-enter) + (equal? code #\return) + (equal? code #\newline))) + (super on-local-char key)] + [(not prompt-position) + ;; evaluating? just drop the keypress + (void)] + [(and (< end prompt-position) + (= start end) + (get-backward-sexp end)) + => + (λ (sexp-start) + (copy-down sexp-start end))] + [(and (< end prompt-position) + (not (= start end))) + (copy-down start end)] + [else + (super on-local-char key)]))) + + (define/private (copy-down start end) + (begin-edit-sequence) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip start 'after-or-none)]) + (when snip + (let ([pos (+ (get-snip-position snip) + (send snip get-count))]) + (when (<= pos end) + (insert (send snip copy) (last-position) (last-position)) + (loop (send snip next)))))) + (set-position (last-position) (last-position)) + (end-edit-sequence)) + + ;; prompt-position : (union #f integer) + ;; the position just after the last prompt + (field (prompt-position #f)) + (define inserting-prompt? #f) + (define/public (get-prompt) "> ") + (define/public (insert-prompt) + (set! inserting-prompt? #t) + (begin-edit-sequence) + (reset-input-box) + (let* ([pmt (get-prompt)] + [prompt-space (string-length pmt)]) + + ;; insert the prompt, possibly inserting a newline first + (let* ([usp (get-unread-start-point)] + [usp-para (position-paragraph usp)] + [usp-para-start (paragraph-start-position usp-para)]) + (unless (equal? usp usp-para-start) + (insert-between "\n") + (set! prompt-space (+ prompt-space 1))) + (insert-between pmt)) + + (let ([sp (get-unread-start-point)]) + (set! prompt-position sp) + (reset-regions (append (get-regions) (list (list sp 'end)))))) + (end-edit-sequence) + (set! inserting-prompt? #f)) + + (field [submit-predicate (λ (text prompt-position) #t)]) + (define/public (set-submit-predicate p) + (set! submit-predicate p)) + + (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler= + (send context disable-evaluation) + (send context reset-offer-kill) + (send context set-breakables (get-user-thread) (get-user-custodian)) + (reset-pretty-print-width) + (set! in-evaluation? #t) + (update-running #t) + (set! need-interaction-cleanup? #t) + + (run-in-evaluation-thread + (λ () ; =User=, =Handler=, =No-Breaks= + (let* ([settings (current-language-settings)] + [lang (drscheme:language-configuration:language-settings-language settings)] + [settings (drscheme:language-configuration:language-settings-settings settings)] + [dummy-value (box #f)] + [get-sexp/syntax/eof + (if complete-program? + (send lang front-end/complete-program port settings) + (send lang front-end/interaction port settings))]) + + ; Evaluate the user's expression. We're careful to turn on + ; breaks as we go in and turn them off as we go out. + ; (Actually, we adjust breaks however the user wanted it.) + + (call-with-continuation-prompt + (λ () + (call-with-break-parameterization + user-break-parameterization + (λ () + (let loop () + (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))]) + (unless (eof-object? sexp/syntax/eof) + (call-with-values + (λ () + (call-with-continuation-prompt + (λ () (with-stacktrace-name (eval-syntax sexp/syntax/eof))) + (default-continuation-prompt-tag) + (and complete-program? + (λ args + (abort-current-continuation + (default-continuation-prompt-tag)))))) + (λ x (for-each (λ (x) ((current-print) x)) x))) + (loop))))))) + (default-continuation-prompt-tag) + (λ args (void))) + + (set! in-evaluation? #f) + (update-running #f) + (cleanup) + (flush-output (get-value-port)) + (queue-system-callback/sync + (get-user-thread) + (λ () ; =Kernel=, =Handler= + (after-many-evals) + (cleanup-interaction) + (insert-prompt))))))) + + (define/pubment (after-many-evals) (inner (void) after-many-evals)) + + (define/private shutdown-user-custodian ; =Kernel=, =Handler= + ; Use this procedure to shutdown when in the middle of other cleanup + ; operations, such as when the user clicks "Execute". + ; Don't use it to kill a thread where other, external cleanup + ; actions must occur (e.g., the exit handler for the user's + ; thread). In that case, shut down user-custodian directly. + (λ () + (when user-custodian + (custodian-shutdown-all user-custodian)) + (set! user-custodian #f) + (set! user-eventspace-main-thread #f))) + + (define/public (kill-evaluation) ; =Kernel=, =Handler= + (when user-custodian + (custodian-shutdown-all user-custodian)) + (set! user-custodian #f)) + + (field (eval-thread-thunks null) + (eval-thread-state-sema 'not-yet-state-sema) + (eval-thread-queue-sema 'not-yet-thread-sema) + + (cleanup-sucessful 'not-yet-cleanup-sucessful) + (cleanup-semaphore 'not-yet-cleanup-semaphore) + (thread-grace 'not-yet-thread-grace) + (thread-killed 'not-yet-thread-killed)) + (define/private (initialize-killed-thread) ; =Kernel= + (when (thread? thread-killed) + (kill-thread thread-killed)) + (set! thread-killed + (thread + (λ () ; =Kernel= + (let ([ut (get-user-thread)]) + (thread-wait ut) + (queue-system-callback + ut + (λ () ; =Kernel=, =Handler= + (if need-interaction-cleanup? + (cleanup-interaction) + (cleanup))))))))) + + (define/public (run-in-evaluation-thread thunk) ; =Kernel= + (semaphore-wait eval-thread-state-sema) + (set! eval-thread-thunks (append eval-thread-thunks (list thunk))) + (semaphore-post eval-thread-state-sema) + (semaphore-post eval-thread-queue-sema)) + + (define/private (init-evaluation-thread) ; =Kernel= + (set! user-language-settings (send definitions-text get-next-settings)) + + (set! user-custodian-parent (make-custodian)) + (set! user-custodian (parameterize ([current-custodian user-custodian-parent]) + (make-custodian))) + (set! memory-killed-thread + (parameterize ([current-custodian user-custodian-parent]) + (thread (λ () (semaphore-wait (make-semaphore 0)))))) + (when custodian-limit + (custodian-limit-memory user-custodian-parent + custodian-limit + user-custodian-parent)) + (let ([user-eventspace (parameterize ([current-custodian user-custodian]) + (make-eventspace))]) + (set! user-eventspace-box (make-weak-box user-eventspace)) + (set! user-break-parameterization (parameterize-break + #t + (current-break-parameterization))) + (set! eval-thread-thunks null) + (set! eval-thread-state-sema (make-semaphore 1)) + (set! eval-thread-queue-sema (make-semaphore 0)) + (set! user-exit-code #f) + + (let* ([init-thread-complete (make-semaphore 0)] + [goahead (make-semaphore)]) + + ; setup standard parameters + (let ([snip-classes + ; the snip-classes in the DrScheme eventspace's snip-class-list + (drscheme:eval:get-snip-classes)] + [drs-eventspace (current-eventspace)]) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + ; No user code has been evaluated yet, so we're in the clear... + (break-enabled #f) + (set! user-eventspace-main-thread (current-thread)) + + (let ([drscheme-exit-handler + (λ (x) + (parameterize-break + #f + (let ([s (make-semaphore)]) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (set! user-exit-code + (if (and (integer? x) + (<= 0 x 255)) + x + 0)) + (semaphore-post s)))) + (semaphore-wait s) + (custodian-shutdown-all user-custodian))))]) + (exit-handler drscheme-exit-handler)) + (initialize-parameters snip-classes)))) + + ;; disable breaks until an evaluation actually occurs + (send context set-breakables #f #f) + + ;; initialize the language + (send (drscheme:language-configuration:language-settings-language user-language-settings) + on-execute + (drscheme:language-configuration:language-settings-settings user-language-settings) + (let ([run-on-user-thread (lambda (t) (queue-user/wait t))]) + run-on-user-thread)) + + ;; setup the special repl values + (let ([raised-exn? #f] + [exn #f]) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (with-handlers ((void (λ (x) + (set! exn x) + (set! raised-exn? #t)))) + (drscheme:language:setup-setup-values)))) + (when raised-exn? + (fprintf + (current-error-port) + "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n") + (raise exn))) + + (parameterize ([current-eventspace user-eventspace]) + (queue-callback + (λ () + (set! in-evaluation? #f) + (update-running #f) + (send context set-breakables #f #f) + + ;; after this returns, future event dispatches + ;; will use the user's break parameterization + (initialize-dispatch-handler) + + ;; let init-thread procedure return, + ;; now that parameters are set + (semaphore-post init-thread-complete) + + ; We're about to start running user code. + + ; Pause to let killed-thread get initialized + (semaphore-wait goahead) + + (let loop () ; =User=, =Handler=, =No-Breaks= + ; Wait for something to do + (unless (semaphore-try-wait? eval-thread-queue-sema) + ; User event callbacks run here; we turn on + ; breaks in the dispatch handler. + (yield eval-thread-queue-sema)) + ; About to eval something + (semaphore-wait eval-thread-state-sema) + (let ([thunk (car eval-thread-thunks)]) + (set! eval-thread-thunks (cdr eval-thread-thunks)) + (semaphore-post eval-thread-state-sema) + ; This thunk evals the user's expressions with appropriate + ; protections. + (thunk)) + (loop))))) + (semaphore-wait init-thread-complete) + ; Start killed-thread + (initialize-killed-thread) + ; Let user expressions go... + (semaphore-post goahead)))) + + (define/private (queue-user/wait thnk) + (let ([wait (make-semaphore 0)]) + (parameterize ([current-eventspace (get-user-eventspace)]) + (queue-callback + (λ () + (thnk) + (semaphore-post wait)))) + (semaphore-wait wait))) + + (field (shutting-down? #f)) + + (define/override (allow-close-with-no-filename?) #t) + (define/augment (can-close?) + (and (cond + [in-evaluation? + (equal? (message-box/custom + (string-constant drscheme) + (string-constant program-is-still-running) + (string-constant close-anyway) + (string-constant cancel) + #f + (or (get-top-level-window) (get-can-close-parent)) + '(default=1 caution) + 2) + 1)] + [(let ([user-eventspace (get-user-eventspace)]) + (and user-eventspace + (parameterize ([current-eventspace user-eventspace]) + (not (null? (get-top-level-windows)))))) + (equal? (message-box/custom + (string-constant drscheme) + (string-constant program-has-open-windows) + (string-constant close-anyway) + (string-constant cancel) + #f + (or (get-top-level-window) (get-can-close-parent)) + '(default=1 caution) + 2) + 1)] + [else #t]) + (inner #t can-close?))) + + (define/augment (on-close) + (shutdown) + (preferences:set 'drscheme:console-previous-exprs + (trim-previous-exprs + (append + (preferences:get 'drscheme:console-previous-exprs) + local-previous-exprs))) + (inner (void) on-close)) + + (define/public (shutdown) ; =Kernel=, =Handler= + (set! shutting-down? #t) + (when (thread? thread-killed) + (kill-thread thread-killed) + (set! thread-killed #f)) + (shutdown-user-custodian)) + + (define/private update-running ; =User=, =Handler=, =No-Breaks= + (λ (bool) + (queue-system-callback + (get-user-thread) + (λ () + (send context update-running bool))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Execution ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; initialize-paramters : (listof snip-class%) -> void + (define/private (initialize-parameters snip-classes) ; =User= + + (current-language-settings user-language-settings) + (error-print-source-location #f) + (error-display-handler drscheme-error-display-handler) + (current-load-relative-directory #f) + (current-custodian user-custodian) + (current-load text-editor-load-handler) + + (drscheme:eval:set-basic-parameters snip-classes) + (current-rep this) + (let ([dir (or (send context get-directory) + drscheme:init:first-dir)]) + (current-directory dir) + (current-load-relative-directory dir)) + + (set! user-namespace-box (make-weak-box (current-namespace))) + + (current-output-port (get-out-port)) + (current-error-port (get-err-port)) + (current-value-port (get-value-port)) + (current-input-port (get-in-box-port)) + + (current-print (lambda (v) (display-results (list v))))) + + (define/private (initialize-dispatch-handler) ;;; =User= + (let* ([primitive-dispatch-handler (event-dispatch-handler)]) + (event-dispatch-handler + (letrec ([drscheme-event-dispatch-handler ; <= a name for #<...> printout + (λ (eventspace) ; =User=, =Handler= + ; Breaking is enabled if the user turned on breaks and + ; is in a `yield'. If we get a break, that's ok, because + ; the kernel never queues an event in the user's eventspace. + (cond + [(eq? eventspace (get-user-eventspace)) + ; =User=, =Handler= + + ; We must distinguish between "top-level" events and + ; those within `yield' in the user's program. + (cond + [(not in-evaluation?) + ;; at this point, we must not be in a nested dispatch, so we can + ;; just disable breaks and rely on call-with-break-parameterization + ;; to restore them to the user's setting. + (call-with-break-parameterization + no-breaks-break-parameterization + (λ () + ; =No-Breaks= + (send context reset-offer-kill) + (send context set-breakables (get-user-thread) (get-user-custodian)) + (call-with-continuation-prompt + (λ () ; =User=, =Handler=, =No-Breaks= + (call-with-break-parameterization + user-break-parameterization + (λ () (primitive-dispatch-handler eventspace))))) + + ;; in principle, the line below might cause + ;; "race conditions" in the GUI. That is, there might + ;; be many little events that the user won't quite + ;; be able to break. + (send context set-breakables #f #f)))] + [else + ; Nested dispatch; don't adjust interface + (primitive-dispatch-handler eventspace)])] + [else + ; =User=, =Non-Handler=, =No-Breaks= + (primitive-dispatch-handler eventspace)]))]) + drscheme-event-dispatch-handler)))) + + (define/public (new-empty-console) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (send (drscheme:language-configuration:language-settings-language user-language-settings) + first-opened)))) + + (define/public (reset-console) + (when (thread? thread-killed) + (kill-thread thread-killed)) + (send context clear-annotations) + (drscheme:debug:hide-backtrace-window) + (shutdown-user-custodian) + (clear-input-port) + (clear-box-input-port) + (clear-output-ports) + (set-allow-edits #t) + + ;; in case the last evaluation thread was killed, clean up some state. + (lock #f) + (set! in-evaluation? #f) + (update-running #f) + + ;; clear out repl first before doing any work. + (begin-edit-sequence) + (set! prompt-position #f) + (reset-input-box) + (delete (paragraph-start-position 1) (last-position)) + (end-edit-sequence) + + ;; must init-evaluation-thread before determining + ;; the language's name, since this updates user-language-settings + (init-evaluation-thread) + + (begin-edit-sequence) + (set-position (last-position) (last-position)) + + (set! setting-up-repl? #t) + (insert/delta this (string-append (string-constant language) ": ") welcome-delta) + (let-values (((before after) + (insert/delta + this + (extract-language-name user-language-settings) + dark-green-delta + (extract-language-style-delta user-language-settings))) + ((url) (extract-language-url user-language-settings))) + (when url + (set-clickback before after (λ args (send-url url)) + click-delta))) + (unless (is-default-settings? user-language-settings) + (insert/delta this (string-append " " (string-constant custom)) dark-green-delta)) + (when custodian-limit + (insert/delta this + "; memory limit: " + welcome-delta) + (insert/delta this + (format "~a megabytes" (floor (/ custodian-limit 1024 1024))) + dark-green-delta)) + (insert/delta this ".\n" welcome-delta) + + (let ([osf (get-styles-fixed)]) + (set-styles-fixed #f) + (send (drscheme:language-configuration:language-settings-language user-language-settings) + extra-repl-information + (drscheme:language-configuration:language-settings-settings user-language-settings) + (open-output-text-editor this 'end)) + (set-styles-fixed osf)) + + (set! setting-up-repl? #f) + + (set! already-warned? #f) + (reset-regions (list (list (last-position) (last-position)))) + (set-unread-start-point (last-position)) + (set-insertion-point (last-position)) + (set-allow-edits #f) + (set! repl-header-end #f) + (end-edit-sequence)) + + (define/public (initialize-console) + (begin-edit-sequence) + (freeze-colorer) + (set! setting-up-repl? #t) + (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta) + (let-values ([(before after) + (insert/delta this + (string-constant drscheme) + click-delta + drs-font-delta)]) + (insert/delta this (format (string-append ", " (string-constant version) " ~a [~a].\n") + (version:version) (system-type 'gc)) + welcome-delta) + (set-clickback before after + (λ args (drscheme:app:about-drscheme)) + click-delta)) + (set! setting-up-repl? #f) + (thaw-colorer) + (send context disable-evaluation) + (reset-console) + + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (send (drscheme:language-configuration:language-settings-language user-language-settings) + first-opened))) + + (insert-prompt) + (send context enable-evaluation) + (end-edit-sequence) + (clear-undos)) + + ;; avoid calling paragraph-start-position very often. + (define repl-header-end #f) + (define/private (get-repl-header-end) + (if repl-header-end + repl-header-end + (begin (set! repl-header-end (paragraph-start-position 2)) + repl-header-end))) + + (define setting-up-repl? #f) + (define/augment (can-change-style? start len) + (and (inner #t can-change-style? start len) + (or setting-up-repl? + (start . >= . (get-repl-header-end))))) + + (define/private (last-str l) + (if (null? (cdr l)) + (car l) + (last-str (cdr l)))) + + (field (previous-expr-pos -1)) + + (define/public (copy-previous-expr) + (when prompt-position + (let ([snip/strings (list-ref (get-previous-exprs) previous-expr-pos)]) + (begin-edit-sequence) + (delete prompt-position (last-position) #f) + (for-each (λ (snip/string) + (insert (if (is-a? snip/string snip%) + (send snip/string copy) + snip/string) + prompt-position)) + snip/strings) + (set-position (last-position)) + (end-edit-sequence)))) + + (define/public (copy-next-previous-expr) + (let ([previous-exprs (get-previous-exprs)]) + (unless (null? previous-exprs) + (set! previous-expr-pos + (if (< (add1 previous-expr-pos) (length previous-exprs)) + (add1 previous-expr-pos) + 0)) + (copy-previous-expr)))) + (define/public (copy-prev-previous-expr) + (let ([previous-exprs (get-previous-exprs)]) + (unless (null? previous-exprs) + (set! previous-expr-pos + (if (previous-expr-pos . <= . 0) + (sub1 (length previous-exprs)) + (sub1 previous-expr-pos))) + (copy-previous-expr)))) + + ;; private fields + (define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs)) + (define local-previous-exprs null) + (define/private (get-previous-exprs) + (append global-previous-exprs local-previous-exprs)) + (define/private (add-to-previous-exprs snips) + (let* ([new-previous-exprs + (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)]) + (let loop ([l trimmed-previous-exprs]) + (if (null? l) + (list snips) + (cons (car l) (loop (cdr l))))))]) + (set! local-previous-exprs new-previous-exprs))) + + (define/private (trim-previous-exprs lst) + (if ((length lst). >= . console-max-save-previous-exprs) + (cdr lst) + lst)) + + (define/private (save-interaction-in-history start end) + (split-snip start) + (split-snip end) + (let ([snips + (let loop ([snip (find-snip start 'after-or-none)] + [snips null]) + (cond + [(not snip) snips] + [((get-snip-position snip) . <= . end) + (loop (send snip next) + (cons (send snip copy) snips))] + [else snips]))]) + (set! previous-expr-pos -1) + (add-to-previous-exprs snips))) + + (define/public (reset-pretty-print-width) + (let* ([standard (send (get-style-list) find-named-style "Standard")]) + (when standard + (let* ([admin (get-admin)] + [width + (let ([bw (box 0)] + [b2 (box 0)]) + (send admin get-view b2 b2 bw b2) + (unbox bw))] + [dc (send admin get-dc)] + [new-font (send standard get-font)] + [old-font (send dc get-font)]) + (send dc set-font new-font) + (let* ([char-width (send dc get-char-width)] + [min-columns 50] + [new-columns (max min-columns + (floor (/ width char-width)))]) + (send dc set-font old-font) + (pretty-print-columns new-columns)))))) + (super-new) + (auto-wrap #t) + (set-styles-sticky #f) + + (inherit set-max-undo-history) + (set-max-undo-history 'forever))) + + (define (all-but-last lst) + (let loop ([o lst]) + (cond + [(null? o) null] + [(null? (cdr o)) null] + [else (cons (car o) (loop (cdr o)))]))) + + (define input-delta (make-object style-delta%)) + (send input-delta set-delta-foreground (make-object color% 0 150 0)) + + ;; insert-error-in-text : (is-a?/c text%) + ;; (union #f (is-a?/c drscheme:rep:text<%>)) + ;; string? + ;; exn? + ;; (union false? (and/c string? directory-exists?)) + ;; -> + ;; void? + (define (insert-error-in-text text interactions-text msg exn user-dir) + (insert-error-in-text/highlight-errors + text + (λ (l) (send interactions-text highlight-errors l)) + msg + exn + user-dir)) + + ;; insert-error-in-text/highlight-errors : (is-a?/c text%) + ;; ((listof (list text% number number)) -> void) + ;; string? + ;; exn? + ;; (union false? (and/c string? directory-exists?)) + ;; -> + ;; void? + (define (insert-error-in-text/highlight-errors text highlight-errors msg exn user-dir) + (let ([locked? (send text is-locked?)] + [insert-file-name/icon + ;; insert-file-name/icon : string number number number number -> void + (λ (source-name start span row col) + (let ([range-spec + (cond + [(and row col) + (format ":~a:~a" row col)] + [start + (format "::~a" start)] + [else ""])]) + (cond + [(file-exists? source-name) + (let* ([normalized-name (normalize-path source-name)] + [short-name (if user-dir + (find-relative-path user-dir normalized-name) + source-name)]) + (let-values ([(icon-start icon-end) (insert/delta text (send file-icon copy))] + [(space-start space-end) (insert/delta text " ")] + [(name-start name-end) (insert/delta text short-name)] + [(range-start range-end) (insert/delta text range-spec)] + [(colon-start colon-ent) (insert/delta text ": ")]) + (when (number? start) + (send text set-clickback icon-start range-end + (λ (_1 _2 _3) + (open-file-and-highlight normalized-name + (- start 1) + (if span + (+ start -1 span) + start)))))))] + [else + (insert/delta text source-name) + (insert/delta text range-spec) + (insert/delta text ": ")])))]) + (send text begin-edit-sequence) + (send text lock #f) + (cond + [(exn:fail:syntax? exn) + (for-each + (λ (expr) + (let ([src (and (syntax? expr) (syntax-source expr))] + [pos (and (syntax? expr) (syntax-position expr))] + [span (and (syntax? expr) (syntax-span expr))] + [col (and (syntax? expr) (syntax-column expr))] + [line (and (syntax? expr) (syntax-line expr))]) + (when (and (string? src) + (number? pos) + (number? span) + (number? line) + (number? col)) + (insert-file-name/icon src pos span line col)) + (insert/delta text (format "~a" (exn-message exn)) error-delta) + (when (syntax? expr) + (insert/delta text " in: ") + (insert/delta text (format "~s" (syntax->datum expr)) error-text-style-delta)) + (insert/delta text "\n") + (when (and (is-a? src text:basic%) + (number? pos) + (number? span)) + (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))) + (exn:fail:syntax-exprs exn))] + [(exn:fail:read? exn) + '(let ([src (exn:read-source exn)] + [pos (exn:read-position exn)] + [span (exn:read-span exn)] + [line (exn:read-line exn)] + [col (exn:read-column exn)]) + (when (and (string? src) + (number? pos) + (number? span) + (number? line) + (number? col)) + (insert-file-name/icon src pos span line col)) + (insert/delta text (format "~a" (exn-message exn)) error-delta) + (insert/delta text "\n") + (when (and (is-a? src text:basic%) + (number? pos) + (number? span)) + (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))] + [(exn? exn) + (insert/delta text (format "~a" (exn-message exn)) error-delta) + (insert/delta text "\n")] + [else + (insert/delta text "uncaught exception: " error-delta) + (insert/delta text (format "~s" exn) error-delta) + (insert/delta text "\n")]) + (send text lock locked?) + (send text end-edit-sequence))) + + + ;; open-file-and-highlight : string (union number #f) (union number #f) + ;; =Kernel, =Handler= + ;; opens the file named by filename. If position is #f, + ;; doesn't highlight anything. If position is a number and other-position + ;; is #f, highlights the range from position to the end of sexp. + ;; if other-position is a number, highlights from position to + ;; other position. + (define (open-file-and-highlight filename position other-position) + (let ([file (handler:edit-file filename)]) + (when (and (is-a? file drscheme:unit:frame%) + position) + (if other-position + (send (send file get-interactions-text) + highlight-error + (send file get-definitions-text) + position + other-position) + (send (send file get-interactions-text) + highlight-error/forward-sexp + (send file get-definitions-text) + position))))) + + (define drs-autocomplete-mixin + (λ (get-defs x) + (class (text:autocomplete-mixin x) + (define/override (get-all-words) + (let* ([definitions-text (get-defs this)] + [settings (send definitions-text get-next-settings)] + [language (drscheme:language-configuration:language-settings-language settings)]) + (send language capability-value 'drscheme:autocomplete-words))) + (super-new)))) + + (define -text% + (drs-bindings-keymap-mixin + (text-mixin + (text:ports-mixin + (scheme:text-mixin + (color:text-mixin + (text:info-mixin + (editor:info-mixin + (text:searching-mixin + (mode:host-text-mixin + (drs-autocomplete-mixin + (λ (txt) (send txt get-definitions-text)) + (text:foreground-color-mixin + text:clever-file-format%))))))))))))) \ No newline at end of file diff --git a/collects/drscheme/private/stick-figures.ss b/collects/drscheme/private/stick-figures.ss new file mode 100644 index 0000000000..380e18e15a --- /dev/null +++ b/collects/drscheme/private/stick-figures.ss @@ -0,0 +1,341 @@ +(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)) diff --git a/collects/drscheme/private/syncheck-debug.ss b/collects/drscheme/private/syncheck-debug.ss new file mode 100644 index 0000000000..364702e84a --- /dev/null +++ b/collects/drscheme/private/syncheck-debug.ss @@ -0,0 +1,164 @@ +(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))) diff --git a/collects/drscheme/private/text.ss b/collects/drscheme/private/text.ss new file mode 100644 index 0000000000..196e591614 --- /dev/null +++ b/collects/drscheme/private/text.ss @@ -0,0 +1,34 @@ + +#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))) diff --git a/collects/drscheme/private/time-keystrokes.ss b/collects/drscheme/private/time-keystrokes.ss new file mode 100644 index 0000000000..b0d75e70c7 --- /dev/null +++ b/collects/drscheme/private/time-keystrokes.ss @@ -0,0 +1,86 @@ +(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))))) + diff --git a/collects/drscheme/private/tool-contract-language.ss b/collects/drscheme/private/tool-contract-language.ss new file mode 100644 index 0000000000..7c8486c72b --- /dev/null +++ b/collects/drscheme/private/tool-contract-language.ss @@ -0,0 +1,135 @@ +(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 ...) ...)))))))]))) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss new file mode 100644 index 0000000000..f59afc7178 --- /dev/null +++ b/collects/drscheme/private/tools.ss @@ -0,0 +1,582 @@ + +#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) + (stringmodule-spec it)))]) + (if (installed-tool-is-loaded? it) + (string-append name " (loaded)") + name))) + (define (on-select-tool) + (let ([it (get-selected-tool)]) + (send* location-editor + (begin-edit-sequence) + (lock #f) + (erase) + (insert + (if it + (format "~s" (installed-tool->module-spec it)) + "")) + (lock #t) + (end-edit-sequence)) + (send configuration set-selection + (case (and it (get-tool-configuration it)) + ((load) 0) + ((skip) 1) + ((#f) 0))) ;; XXX (or 2, if default is an option) + (send configuration enable (and it #t)) + (void))) + (define (on-select-policy) + (let ([it (get-selected-tool)] + [policy + (case (send configuration get-selection) + ((0) 'load) + ((1) 'skip))]) + (when it + (let ([key (installed-tool->key it)]) + (case policy + ((load) + (toolspref (cons (list key 'load) + (let ([ts (toolspref)]) + (remove (assoc key ts) ts))))) + ((skip) + (toolspref (cons (list key 'skip) + (let ([ts (toolspref)]) + (remove (assoc key ts) ts))))) + ((#f) + (toolspref (let ([ts (toolspref)]) + (remove (assoc key ts) ts)))))))) + (void)) + (define (get-selected-tool) + (let ([index (send listing get-selection)]) + (and index (send listing get-data index)))) + (populate-listing!) + (send location-editor lock #t) + main))) diff --git a/collects/drscheme/private/ts.ss b/collects/drscheme/private/ts.ss new file mode 100644 index 0000000000..e1d6de5dc8 --- /dev/null +++ b/collects/drscheme/private/ts.ss @@ -0,0 +1,12 @@ +#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) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss new file mode 100644 index 0000000000..c6877ac9e3 --- /dev/null +++ b/collects/drscheme/private/unit.ss @@ -0,0 +1,3821 @@ + +#| + +closing: + warning messages don't have frame as parent..... + +tab panels new behavior: + - save all tabs (pr 6689?) + +module browser threading seems wrong. + +|# + +(module unit scheme/base + (require scheme/contract + scheme/unit + scheme/class + scheme/path + scheme/port + scheme/list + (only-in mzlib/etc compose) + string-constants + framework + (lib "name-message.ss" "mrlib") + (lib "bitmap-label.ss" "mrlib") + (lib "include-bitmap.ss" "mrlib") + "drsig.ss" + "auto-language.ss" + "insert-large-letters.ss" + mrlib/switchable-button + + (prefix-in drscheme:arrow: "../arrow.ss") + + mred + (prefix-in mred: mred) + + mzlib/date) + + (provide unit@) + + (define module-browser-progress-constant (string-constant module-browser-progress)) + (define status-compiling-definitions (string-constant module-browser-compiling-defns)) + (define show-lib-paths (string-constant module-browser-show-lib-paths/short)) + (define show-planet-paths (string-constant module-browser-show-planet-paths/short)) + (define refresh (string-constant module-browser-refresh)) + + (define-unit unit@ + (import [prefix help-desk: drscheme:help-desk^] + [prefix drscheme:app: drscheme:app^] + [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:text: drscheme:text^] + [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:get/extend: drscheme:get/extend^] + [prefix drscheme:module-overview: drscheme:module-overview^] + [prefix drscheme:tools: drscheme:tools^] + [prefix drscheme:eval: drscheme:eval^] + [prefix drscheme:init: drscheme:init^] + [prefix drscheme:module-language: drscheme:module-language^] + [prefix drscheme:modes: drscheme:modes^]) + (export (rename drscheme:unit^ + [-frame% frame%] + [-frame<%> frame<%>])) + + (define-local-member-name + get-visible-defs + set-visible-defs + set-focus-d/i + get-i + set-i) + (define tab<%> + (interface (drscheme:rep:context<%>) + get-frame + get-defs + get-ints + get-visible-defs + set-visible-defs + set-visible-ints + set-focus-d/i + get-i + set-i + break-callback + is-current-tab? + get-enabled + on-close + can-close?)) + + (define definitions-text<%> + (interface () + begin-metadata-changes + end-metadata-changes + get-tab + get-next-settings + after-set-next-settings + set-needs-execution-message)) + + (define-struct teachpack-callbacks + (get-names ;; settings -> (listof string) + add ;; settings path -> settings + remove ;; string[returned from teachpack-names] settings -> settings + remove-all ;; settings -> settings + )) + + ;; get rid of set-user-teachpack-cache method + + (keymap:add-to-right-button-menu + (let ([old (keymap:add-to-right-button-menu)]) + (λ (menu text event) + (old menu text event) + (when (and (is-a? text text%) + (or (is-a? text (get-definitions-text%)) + (is-a? text drscheme:rep:text%)) + (is-a? event mouse-event%)) + (let* ([end (send text get-end-position)] + [start (send text get-start-position)]) + (unless (= 0 (send text last-position)) + (let ([str (if (= end start) + (find-symbol + text + (call-with-values + (λ () + (send text dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (λ (x y) + (send text find-position x y)))) + (send text get-text start end))] + [language + (let ([canvas (send text get-canvas)]) + (and canvas + (let ([tlw (send canvas get-top-level-window)]) + (and (is-a? tlw -frame<%>) + (send (send tlw get-definitions-text) + get-next-settings)))))]) + (unless (string=? str "") + (make-object separator-menu-item% menu) + (make-object menu-item% + (gui-utils:format-literal-label (string-constant search-help-desk-for) + (shorten-str + str + (- 200 (string-length (string-constant search-help-desk-for))))) + menu + (λ x (help-desk:help-desk str))) + (void))))))))) + + ;; find-symbol : number -> string + ;; finds the symbol around the position `pos' (approx) + (define (find-symbol text pos) + (let* ([before + (let loop ([i (- pos 1)] + [chars null]) + (if (< i 0) + chars + (let ([char (send text get-character i)]) + (if (non-letter? char) + chars + (loop (- i 1) + (cons char chars))))))] + [after + (let loop ([i pos]) + (if (< i (send text last-position)) + (let ([char (send text get-character i)]) + (if (non-letter? char) + null + (cons char (loop (+ i 1))))) + null))]) + (apply string (append before after)))) + + ;; non-letter? : char -> boolean + ;; returns #t if the character belongs in a symbol (approx) and #f it is + ;; a divider between symbols (approx) + (define (non-letter? x) + (or (char-whitespace? x) + (memq x '(#\` #\' #\, #\; #\" + #\{ #\( #\[ #\] #\) #\})))) + (define (shorten-str str len) + (if ((string-length str) . <= . len) + str + (substring str 0 len))) + + + ; + ; + ; + ; ;;; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ; + ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ; + ; ; + ; ; ; + ; ;;;; + + (define (get-fraction-from-user parent) + (let* ([dlg (make-object dialog% (string-constant enter-fraction))] + [hp (make-object horizontal-panel% dlg)] + [_1 (make-object message% (string-constant whole-part) hp)] + [whole (make-object text-field% #f hp void)] + [vp (make-object vertical-panel% hp)] + [hp2 (make-object horizontal-panel% vp)] + [num (make-object text-field% #f hp2 void)] + [num-m (make-object message% (string-constant numerator) hp2)] + [hp3 (make-object horizontal-panel% vp)] + [den (make-object text-field% #f hp3 void)] + [den-m (make-object message% (string-constant denominator) hp3)] + [bp (make-object horizontal-panel% dlg)] + [ok? #f] + [validate-number + (λ () + (let ([num-s (string->number (send num get-value))] + [den-s (string->number (send den get-value))] + [whole-s (if (string=? (send whole get-value) "") + 0 + (string->number (send whole get-value)))]) + (if (and num-s den-s whole-s) + (let ([ans (+ whole-s (/ num-s den-s))]) + (if (and (exact? ans) + (real? ans) + (not (integer? ans))) + ans + #f)) + #f)))] + [ok-callback + (λ () + (cond + [(validate-number) + (set! ok? #t) + (send dlg show #f)] + [else + (message-box + (string-constant drscheme) + (string-constant invalid-number) + dlg)]))] + [cancel-callback + (λ () (send dlg show #f))]) + (let-values ([(ok cancel) + (gui-utils:ok/cancel-buttons + bp + (λ (x y) (ok-callback)) + (λ (x y) (cancel-callback)))]) + (let ([mw (max (send den-m get-width) (send num-m get-width))]) + (send den-m min-width mw) + (send num-m min-width mw)) + (send bp set-alignment 'right 'center) + (send dlg show #t) + (and ok? (validate-number))))) + + ;; create-executable : (instanceof drscheme:unit:frame<%>) -> void + (define (create-executable frame) + (let* ([definitions-text (send frame get-definitions-text)] + [program-filename (send definitions-text get-filename)]) + (cond + [(not program-filename) + (message-box (string-constant create-executable-title) + (string-constant must-save-before-executable) + frame)] + [else + (when (or (not (send definitions-text is-modified?)) + (gui-utils:get-choice + (string-constant definitions-not-saved) + (string-constant yes) + (string-constant no) + (string-constant drscheme) + #f + frame)) + (let ([settings (send definitions-text get-next-settings)]) + (send (drscheme:language-configuration:language-settings-language settings) + create-executable + (drscheme:language-configuration:language-settings-settings settings) + frame + program-filename)))]))) + + (define execute-bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask)) + (define break-bitmap (make-object bitmap% (build-path (collection-path "icons") "break.png") 'png/mask)) + (define save-bitmap (make-object bitmap% (build-path (collection-path "icons") "save.png") 'png/mask)) + + (define-values (get-program-editor-mixin add-to-program-editor-mixin) + (let* ([program-editor-mixin + (mixin (editor:basic<%> (class->interface text%)) () + (init-rest args) + (inherit get-top-level-window) + + (define/private (reset-highlighting) + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (let ([interactions-text (send f get-interactions-text)]) + (when (object? interactions-text) + (send interactions-text reset-highlighting)))))) + + (define/augment (after-insert x y) + (reset-highlighting) + (inner (void) after-insert x y)) + + (define/augment (after-delete x y) + (reset-highlighting) + (inner (void) after-delete x y)) + + (apply super-make-object args))] + [get-program-editor-mixin + (λ () + (drscheme:tools:only-in-phase 'drscheme:unit:get-program-editor-mixin 'phase2 'init-complete) + program-editor-mixin)] + [add-to-program-editor-mixin + (λ (mixin) + (drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1) + (set! program-editor-mixin (compose mixin program-editor-mixin)))]) + (values get-program-editor-mixin + add-to-program-editor-mixin))) + + + ;; this sends a message to it's frame when it gets the focus + (define make-searchable-canvas% + (λ (%) + (class % + (inherit get-top-level-window) + (define/override (on-focus on?) + (when on? + (send (get-top-level-window) make-searchable this)) + (super on-focus on?)) + (super-new)))) + + (define interactions-canvas% + (class (make-searchable-canvas% + (canvas:info-mixin + (canvas:wide-snip-mixin + (canvas:info-mixin + canvas:color%)))) + (init [style '()]) + (super-new (style (cons 'auto-hscroll style))))) + + + (define definitions-canvas% + (class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%))) + (init [style '()]) + (super-new (style (cons 'auto-hscroll style))))) + + ; + ; + ; + ; ; ;;; ; ; + ; ; ; ; + ; ; ; ; ; ; + ; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;; + ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; + ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;; + ; + ; + ; + + + (define get-definitions-text% + (let ([definitions-text% #f]) + (λ () + (drscheme:tools:only-in-phase 'phase2 'init-complete) + (unless definitions-text% + (set! definitions-text% (make-definitions-text%))) + definitions-text%))) + + (define (make-definitions-text%) + (let ([definitions-super% + ((get-program-editor-mixin) + (drscheme:module-language:module-language-put-file-mixin + (scheme:text-mixin + (color:text-mixin + (drscheme:rep:drs-bindings-keymap-mixin + (mode:host-text-mixin + (text:delegate-mixin + (text:foreground-color-mixin + (drscheme:rep:drs-autocomplete-mixin + (λ (x) x) + text:info%)))))))))]) + (class* definitions-super% (definitions-text<%>) + (inherit get-top-level-window is-locked? lock) + + (define interactions-text #f) + (define/public (set-interactions-text it) + (set! interactions-text it)) + + (define tab #f) + (define/public (get-tab) tab) + (define/public (set-tab t) (set! tab t)) + + (inherit get-surrogate set-surrogate) + (define/public (set-current-mode mode) + (let ([surrogate (drscheme:modes:mode-surrogate mode)]) + (set-surrogate surrogate) + (when interactions-text + (send interactions-text set-surrogate surrogate) + (send interactions-text set-submit-predicate + (drscheme:modes:mode-repl-submit mode))))) + + (define/public (is-current-mode? mode) + (let ([surrogate (drscheme:modes:mode-surrogate mode)]) + (eq? surrogate (get-surrogate)))) + + (define/public (change-mode-to-match) + (let* ([language-settings (get-next-settings)] + [language-name (and language-settings + (send (drscheme:language-configuration:language-settings-language + language-settings) + get-language-position))]) + (let loop ([modes (drscheme:modes:get-modes)]) + (cond + [(null? modes) (error 'change-mode-to-match + "didn't find a matching mode")] + [else (let ([mode (car modes)]) + (if ((drscheme:modes:mode-matches-language mode) language-name) + (unless (is-current-mode? mode) + (set-current-mode mode)) + (loop (cdr modes))))])))) + + (inherit begin-edit-sequence end-edit-sequence + delete insert last-position paragraph-start-position + get-character) + + (define save-file-metadata #f) + + (define/pubment (begin-metadata-changes) + (set! ignore-edits? #t) + (inner (void) begin-metadata-changes)) + (define/pubment (end-metadata-changes) + (set! ignore-edits? #f) + (inner (void) end-metadata-changes)) + + (define/augment (on-save-file filename fmt) + (inner (void) on-save-file filename fmt) + (let* ([lang (drscheme:language-configuration:language-settings-language next-settings)] + [settings (drscheme:language-configuration:language-settings-settings next-settings)] + [name-mod (send lang get-reader-module)]) + (when name-mod ;; the reader-module method's result is used a test of whether or not the get-metadata method is used for this language + (let ([metadata (send lang get-metadata (filename->modname filename) settings)]) + (begin-edit-sequence) + (begin-metadata-changes) + (let ([locked? (is-locked?)]) + (when locked? (lock #f)) + (set! save-file-metadata metadata) + (insert metadata 0 0) + (when locked? (lock #t))))))) + (define/private (filename->modname filename) + (let-values ([(base name dir) (split-path filename)]) + (string->symbol (regexp-replace #rx"\\.[^.]*$" + (path->string name) + "")))) + + (define/augment (after-save-file success?) + (when success? + (let ([filename (get-filename)]) + (when filename + ;; if a filesystem error happens, just give up + ;; on setting the file creator and type. + (with-handlers ([exn:fail:filesystem? void]) + (let-values ([(creator type) (file-creator-and-type filename)]) + (file-creator-and-type filename #"DrSc" type)))))) + (when save-file-metadata + (let ([modified? (is-modified?)] + [locked? (is-locked?)]) + (when locked? (lock #f)) + (delete 0 (string-length save-file-metadata)) + (when locked? (lock #t)) + (set! save-file-metadata #f) + ;; restore modification status to where it was before the metadata is removed + (set-modified modified?) + (end-metadata-changes) + (end-edit-sequence))) + (inner (void) after-save-file success?)) + + (define/augment (on-load-file filename format) + (inner (void) on-load-file filename format) + (begin-edit-sequence)) + (define/augment (after-load-file success?) + (when success? + (let-values ([(module-language module-language-settings) + (get-module-language/settings)]) + (let-values ([(matching-language settings) + (pick-new-language + this + (drscheme:language-configuration:get-languages) + module-language + module-language-settings)]) + (when matching-language + (set-next-settings + (drscheme:language-configuration:make-language-settings + matching-language + settings) + #f)))) + (set-modified #f)) + + (end-edit-sequence) + (inner (void) after-load-file success?)) + + (inherit is-modified? run-after-edit-sequence) + (define/override (set-modified mod?) + (super set-modified mod?) + (run-after-edit-sequence + (λ () + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (send f update-save-button)))))) + (define/override set-filename + (case-lambda + [(fn) (set-filename fn #f)] + [(fn tmp?) + (super set-filename fn tmp?) + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (send f update-save-message)))])) + + (field + [needs-execution-state #f] + [already-warned-state #f] + [execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)] + [next-settings execute-settings]) + + + (define/pubment (get-next-settings) next-settings) + (define/pubment set-next-settings + (lambda (_next-settings [update-prefs? #t]) + (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) + get-reader-module) + (send (drscheme:language-configuration:language-settings-language next-settings) + get-reader-module)) + (set-modified #t)) + (set! next-settings _next-settings) + (change-mode-to-match) + + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (send f language-changed))) + + (let ([lang (drscheme:language-configuration:language-settings-language next-settings)] + [sets (drscheme:language-configuration:language-settings-settings next-settings)]) + (preferences:set + 'drscheme:recent-language-names + (limit-length + (remove-duplicate-languages + (cons (cons (send lang get-language-name) + (send lang marshall-settings sets)) + (preferences:get 'drscheme:recent-language-names))) + 10))) + + (when update-prefs? + (preferences:set + drscheme:language-configuration:settings-preferences-symbol + next-settings)) + + (after-set-next-settings _next-settings))) + + (define/pubment (after-set-next-settings s) + (inner (void) after-set-next-settings s)) + + (define/public (needs-execution) + (or needs-execution-state + (and (not (this-and-next-language-the-same?)) + (string-constant needs-execute-language-changed)))) + + (define/public (this-and-next-language-the-same?) + (let ([execute-lang (drscheme:language-configuration:language-settings-language execute-settings)] + [next-lang (drscheme:language-configuration:language-settings-language next-settings)]) + (and (eq? execute-lang next-lang) + (equal? + (send execute-lang marshall-settings + (drscheme:language-configuration:language-settings-settings execute-settings)) + (send execute-lang marshall-settings + (drscheme:language-configuration:language-settings-settings next-settings)))))) + + (define/pubment (set-needs-execution-message msg) + (set! needs-execution-state msg)) + (define/pubment (teachpack-changed) + (set! needs-execution-state (string-constant needs-execute-teachpack-changed))) + (define/pubment (just-executed) + (set! execute-settings next-settings) + (set! needs-execution-state #f) + (set! already-warned-state #f)) + (define/pubment (already-warned?) + already-warned-state) + (define/pubment (already-warned) + (set! already-warned-state #t)) + + (define ignore-edits? #f) + (define/augment (after-insert x y) + (unless ignore-edits? + (set! needs-execution-state (string-constant needs-execute-defns-edited))) + (inner (void) after-insert x y)) + (define/augment (after-delete x y) + (unless ignore-edits? + (set! needs-execution-state (string-constant needs-execute-defns-edited))) + (inner (void) after-delete x y)) + + (inherit get-filename) + (field + [tmp-date-string #f]) + + (inherit get-filename/untitled-name) + (define/private (get-date-string) + (string-append + (date->string (seconds->date (current-seconds))) + " " + (get-filename/untitled-name))) + + (define/override (on-paint before dc left top right bottom dx dy draw-caret) + (when (and before + (or (is-a? dc post-script-dc%) + (is-a? dc printer-dc%))) + (set! tmp-date-string (get-date-string)) + (let-values ([(w h d s) (send dc get-text-extent tmp-date-string)]) + (send (current-ps-setup) set-editor-margin 0 (inexact->exact (ceiling h))))) + (super on-paint before dc left top right bottom dx dy draw-caret) + (when (and (not before) + (or (is-a? dc post-script-dc%) + (is-a? dc printer-dc%))) + (send dc draw-text (get-date-string) 0 0) + (void)) + + ;; draw the arrows + (when before + (when error-arrows + (let ([old-pen (send dc get-pen)]) + (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) + (let loop ([pts error-arrows]) + (cond + [(null? pts) (void)] + [(null? (cdr pts)) (void)] + [else (let ([pt1 (car pts)] + [pt2 (cadr pts)]) + (draw-arrow dc dx dy pt1 pt2) + (loop (cdr pts)))])) + (send dc set-pen old-pen))))) + + (define/private (draw-arrow dc dx dy pt1 pt2) + (let-values ([(x1 y1) (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))] + [(x2 y2) (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))]) + (drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy))) + + (inherit dc-location-to-editor-location) + (define/private (find-poss text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values (/ (+ xl xr) 2) + (/ (+ yl yr) 2))))) + + (inherit invalidate-bitmap-cache) + (define/public (set-error-arrows arrows) + (set! error-arrows arrows) + (invalidate-bitmap-cache)) + + (define error-arrows #f) + + (super-new) + + (inherit set-max-undo-history) + (set-max-undo-history 'forever)))) + + (define (get-module-language/settings) + (let* ([module-language + (and (preferences:get 'drscheme:switch-to-module-language-automatically?) + (ormap + (λ (lang) + (and (is-a? lang drscheme:module-language:module-language<%>) + lang)) + (drscheme:language-configuration:get-languages)))] + [module-language-settings + (let ([prefs-setting (preferences:get + drscheme:language-configuration:settings-preferences-symbol)]) + (cond + [(eq? (drscheme:language-configuration:language-settings-language prefs-setting) + module-language) + (drscheme:language-configuration:language-settings-settings prefs-setting)] + [else + (and module-language + (send module-language default-settings))]))]) + (values module-language module-language-settings))) + + + + ; ; ;; ; + ; ; ; + ; ; ; + ; ;;; ; ;;; ;;; ; ; ;;; ;;; + ; ; ;; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ;;;;; + ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; + ; ;;; ; ;;;; ; ; ; ; ;;;; ; ; ; + ; + ; + + + + ;; get-pos : text mouse-event% -> (union #f number) + (define (get-pos text event) + (let*-values ([(event-x event-y) + (values (send event get-x) + (send event get-y))] + [(x y) (send text dc-location-to-editor-location + event-x + event-y)]) + (let* ([on-it? (box #f)] + [pos (send text find-position x y #f on-it?)]) + (and (unbox on-it?) + pos)))) + + (let ([old (keymap:add-to-right-button-menu)]) + (keymap:add-to-right-button-menu + (λ (menu editor event) + (when (is-a? editor text%) + (let* ([canvas (send editor get-canvas)] + [frame (and canvas (send canvas get-top-level-window))]) + (when (is-a? frame -frame<%>) + (let* ([language-settings (send (send frame get-definitions-text) get-next-settings)] + [new-language (drscheme:language-configuration:language-settings-language language-settings)] + [capability-info (send new-language capability-value 'drscheme:define-popup)]) + (when capability-info + (let* ([current-pos (get-pos editor event)] + [current-word (and current-pos (get-current-word editor current-pos))] + [defn (and current-word + (ormap (λ (defn) (and (string=? current-word (defn-name defn)) + defn)) + (get-definitions (car capability-info) + #f + editor)))]) + (when defn + (new separator-menu-item% (parent menu)) + (new menu-item% + (parent menu) + (label (gui-utils:format-literal-label (string-constant jump-to-defn) (defn-name defn))) + (callback (λ (x y) + (send editor set-position (defn-start-pos defn)))))))))))) + (old menu editor event)))) + + ;; get-current-word : editor number -> string + ;; returns the string that is being clicked on + (define (get-current-word editor pos) + (let* ([search + (λ (dir offset) + (let loop ([pos pos]) + (cond + [(or (= pos 0) + (= pos (send editor last-position))) + pos] + [(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab)) + (offset pos)] + [else (loop (dir pos))])))] + [before (search sub1 add1)] + [after (search add1 (λ (x) x))]) + (send editor get-text before after))) + + (define func-defs-canvas% + (class name-message% + (init-field frame) + + (unless (is-a? frame -frame<%>) + (error 'func-defs-canvas "frame is not a drscheme:unit:frame<%>")) + + (define sort-by-name? #f) + (define sorting-name (string-constant sort-by-name)) + (define/private (change-sorting-order) + (set! sort-by-name? (not sort-by-name?)) + (set! sorting-name (if sort-by-name? + (string-constant sort-by-position) + (string-constant sort-by-name)))) + + (define capability-info (drscheme:language:get-capability-default 'drscheme:define-popup)) + + (inherit set-message set-hidden?) + (define/public (language-changed new-language) + (set! capability-info (send new-language capability-value 'drscheme:define-popup)) + (cond + [capability-info + (set-message #f (cdr capability-info)) + (set-hidden? #f)] + [else + (set-hidden? #t)])) + (define/override (fill-popup menu reset) + (when capability-info + (let* ([text (send frame get-definitions-text)] + [unsorted-defns (get-definitions (car capability-info) + (not sort-by-name?) + text)] + [defns (if sort-by-name? + (sort + unsorted-defns + (λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) + unsorted-defns)]) + (make-object menu:can-restore-menu-item% sorting-name + menu + (λ (x y) + (change-sorting-order))) + (make-object separator-menu-item% menu) + (if (null? defns) + (send (make-object menu:can-restore-menu-item% + (string-constant no-definitions-found) + menu + void) + enable #f) + (let loop ([defns defns]) + (unless (null? defns) + (let* ([defn (car defns)] + [checked? + (let ([t-start (send text get-start-position)] + [t-end (send text get-end-position)] + [d-start (defn-start-pos defn)] + [d-end (defn-end-pos defn)]) + (or (<= t-start d-start t-end) + (<= t-start d-end t-end) + (<= d-start t-start t-end d-end)))] + [item + (make-object (if checked? + menu:can-restore-checkable-menu-item% + menu:can-restore-menu-item%) + (gui-utils:quote-literal-label (defn-name defn)) + + menu + (λ (x y) + (reset) + (send text set-position (defn-start-pos defn) (defn-start-pos defn)) + (let ([canvas (send text get-canvas)]) + (when canvas + (send canvas focus)))))]) + (when checked? + (send item check #t)) + (loop (cdr defns))))))))) + + (super-new (label "(define ...)") + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]))) + + ;; defn = (make-defn number string number number) + (define-struct defn (indent name start-pos end-pos) #:mutable) + + ;; get-definitions : boolean text -> (listof defn) + (define (get-definitions tag-string indent? text) + (let* ([min-indent 0] + [defs (let loop ([pos 0]) + (let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)]) + (cond + [(not defn-pos) null] + [(in-semicolon-comment? text defn-pos) + (loop (+ defn-pos (string-length tag-string)))] + [else + (let ([indent (get-defn-indent text defn-pos)] + [name (get-defn-name text (+ defn-pos (string-length tag-string)))]) + (set! min-indent (min indent min-indent)) + (cons (make-defn indent name defn-pos defn-pos) + (loop (+ defn-pos (string-length tag-string)))))])))]) + + ;; update end-pos's based on the start pos of the next defn + (unless (null? defs) + (let loop ([first (car defs)] + [defs (cdr defs)]) + (cond + [(null? defs) + (set-defn-end-pos! first (send text last-position))] + [else (set-defn-end-pos! first (max (- (defn-start-pos (car defs)) 1) + (defn-start-pos first))) + (loop (car defs) (cdr defs))]))) + + (when indent? + (for-each (λ (defn) + (set-defn-name! defn + (string-append + (apply string + (vector->list + (make-vector + (- (defn-indent defn) min-indent) #\space))) + (defn-name defn)))) + defs)) + defs)) + + ;; in-semicolon-comment: text number -> boolean + ;; returns #t if `define-start-pos' is in a semicolon comment and #f otherwise + (define (in-semicolon-comment? text define-start-pos) + (let* ([para (send text position-paragraph define-start-pos)] + [start (send text paragraph-start-position para)]) + (let loop ([pos start]) + (cond + [(pos . >= . define-start-pos) #f] + [(char=? #\; (send text get-character pos)) #t] + [else (loop (+ pos 1))])))) + + ;; get-defn-indent : text number -> number + ;; returns the amount to indent a particular definition + (define (get-defn-indent text pos) + (let* ([para (send text position-paragraph pos)] + [para-start (send text paragraph-start-position para #t)]) + (let loop ([c-pos para-start] + [offset 0]) + (if (< c-pos pos) + (let ([char (send text get-character c-pos)]) + (cond + [(char=? char #\tab) + (loop (+ c-pos 1) (+ offset (- 8 (modulo offset 8))))] + [else + (loop (+ c-pos 1) (+ offset 1))])) + offset)))) + + ;; skip-to-whitespace/paren : text number -> number + ;; skips to the next parenthesis or whitespace after `pos', returns that position. + (define (skip-to-whitespace/paren text pos) + (let loop ([pos pos]) + (if (>= pos (send text last-position)) + (send text last-position) + (let ([char (send text get-character pos)]) + (cond + [(or (char=? #\) char) + (char=? #\( char) + (char=? #\] char) + (char=? #\[ char) + (char-whitespace? char)) + pos] + [else (loop (+ pos 1))]))))) + + ;; skip-whitespace/paren : text number -> number + ;; skips past any parenthesis or whitespace + (define (skip-whitespace/paren text pos) + (let loop ([pos pos]) + (if (>= pos (send text last-position)) + (send text last-position) + (let ([char (send text get-character pos)]) + (cond + [(or (char=? #\) char) + (char=? #\( char) + (char=? #\] char) + (char=? #\[ char) + (char-whitespace? char)) + (loop (+ pos 1))] + [else pos]))))) + + ;; get-defn-name : text number -> string + ;; returns the name of the definition starting at `define-pos' + (define (get-defn-name text define-pos) + (if (>= define-pos (send text last-position)) + (string-constant end-of-buffer-define) + (let* ([start-pos (skip-whitespace/paren text (skip-to-whitespace/paren text define-pos))] + [end-pos (skip-to-whitespace/paren text start-pos)]) + (send text get-text start-pos end-pos)))) + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + + + + + + ;; + ; + ; + ;;; ; ;; ;;; ; ;;; ;; ;;; + ; ;; ; ; ;; ;; ; ; ; + ; ; ; ; ; ; ; ; + ; ; ;;;; ; ; ; ;;;;; + ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; + ; ; ;;;;; ; ; ; ;;;; + + + + (define dragable/def-int-mixin + (mixin (panel:dragable<%>) () + (init-field unit-frame) + (inherit get-percentages) + (define/augment (after-percentage-change) + (let ([percentages (get-percentages)]) + (when (and (= 1 + (length (send unit-frame get-definitions-canvases)) + (length (send unit-frame get-interactions-canvases))) + (= 2 (length percentages))) + (preferences:set 'drscheme:unit-window-size-percentage (car percentages)))) + (inner (void) after-percentage-change)) + (super-new))) + + (define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%)) + (define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%)) + + (define super-frame% + (drscheme:frame:mixin + (drscheme:frame:basics-mixin + (frame:searchable-text-mixin + (frame:searchable-mixin + (frame:text-info-mixin + (frame:delegate-mixin + (frame:status-line-mixin + (frame:info-mixin + (frame:text-mixin + (frame:open-here-mixin + (frame:editor-mixin + (frame:standard-menus-mixin + (frame:register-group-mixin + (frame:basic-mixin + frame%))))))))))))))) + + (define tab% + (class* object% (drscheme:rep:context<%> tab<%>) + (init-field frame + defs + i + defs-shown? + ints-shown?) + (define enabled? #t) + (field [ints #f] + [visible-defs #f] + [visible-ints #f] + [focus-d/i 'defs]) + + ;; only called to initialize this tab. + ;; the interactions editor should be invariant. + (define/public (set-ints i) (set! ints i)) + + (define/public-final (get-frame) frame) + (define/public-final (get-defs) defs) + (define/public-final (get-ints) ints) + (define/public-final (get-visible-defs) (values visible-defs defs-shown?)) + (define/public-final (set-visible-defs vd ds?) + (set! visible-defs vd) + (set! defs-shown? ds?)) + (define/public-final (get-visible-ints) (values visible-ints ints-shown?)) + (define/public-final (set-visible-ints vi is?) + (set! visible-ints vi) + (set! ints-shown? is?)) + (define/public-final (set-focus-d/i di) + (set! focus-d/i di)) + (define/public-final (get-focus-d/i) focus-d/i) + (define/public-final (get-i) i) + (define/public-final (set-i _i) (set! i _i)) + (define/public (disable-evaluation) + (set! enabled? #f) + (send defs lock #t) + (send ints lock #t) + (send frame disable-evaluation-in-tab this)) + (define/public (enable-evaluation) + (set! enabled? #t) + (send defs lock #f) + (send ints lock #f) + (send frame enable-evaluation-in-tab this)) + (define/public (get-enabled) enabled?) + + (define/public (get-directory) + (let ([filename (send defs get-filename)]) + (if (and (path? filename) + (file-exists? filename)) + (let-values ([(base _1 _2) (split-path (normalize-path filename))]) + base) + #f))) + (define/public (needs-execution) + (send defs needs-execution)) + + (define/pubment (can-close?) + (and (send defs can-close?) + (send ints can-close?) + (inner #t can-close?))) + (define/pubment (on-close) + (send defs on-close) + (send ints on-close) + (inner (void) on-close)) + + ;; this should really do something local to the tab, but + ;; for now it doesn't. + (define/public (ensure-rep-shown rep) + (send frame ensure-rep-shown rep)) + + (field [thread-to-break-box (make-weak-box #f)] + [custodian-to-kill-box (make-weak-box #f)] + [offer-kill? #f]) + + ;; break-callback : -> void + (define/public (break-callback) + (let ([thread-to-break (weak-box-value thread-to-break-box)] + [custodian-to-kill (weak-box-value custodian-to-kill-box)]) + (cond + [(or (not thread-to-break) + (not custodian-to-kill)) + (bell)] + [offer-kill? + (if (user-wants-kill?) + (when thread-to-break + (break-thread thread-to-break)) + (when custodian-to-kill + (custodian-shutdown-all custodian-to-kill)))] + [else + (when thread-to-break + (break-thread thread-to-break)) + ;; only offer a kill the next time if + ;; something got broken. + (set! offer-kill? #t)]))) + + ;; user-wants-kill? : -> boolean + ;; handles events, so be sure to check state + ;; after calling to avoid race conditions. + (define/private (user-wants-kill?) + (gui-utils:get-choice + (string-constant kill-evaluation?) + (string-constant just-break) + (string-constant kill) + (string-constant kill?) + 'diallow-close + frame)) + + ;; reset-offer-kill + (define/public (reset-offer-kill) + (set! offer-kill? #f)) + + ;; get-breakables : -> (union #f thread) (union #f cust) -> void + (define/public (get-breakables) + (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box))) + + ;; set-breakables : (union #f thread) (union #f cust) -> void + (define/public (set-breakables thd cust) + (set! thread-to-break-box (make-weak-box thd)) + (set! custodian-to-kill-box (make-weak-box cust))) + + (define/pubment (clear-annotations) + (inner (void) clear-annotations) + (send ints reset-highlighting)) + + (define running? #f) + (define/public-final (is-running?) running?) + (define/public (update-running b?) + (set! running? b?) + (send frame update-running b?)) + + (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) + + (super-new))) + + ;; should only be called by the tab% object + (define-local-member-name + disable-evaluation-in-tab + enable-evaluation-in-tab + update-toolbar-visibility) + + (define -frame<%> + (interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) + get-insert-menu + get-special-menu + get-interactions-text + get-definitions-text + get-interactions-canvas + get-definitions-canvas + get-button-panel + execute-callback + get-current-tab + open-in-new-tab + on-tab-change + enable-evaluation + disable-evaluation + get-definitions/interactions-panel-parent + register-capability-menu-item + + ensure-rep-shown + ensure-rep-hidden + ensure-defs-shown + + get-language-menu + register-toolbar-button + get-tabs)) + + (define frame-mixin + (mixin (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) + (-frame<%>) + (init filename) + (inherit set-label-prefix get-show-menu + get-menu% + get-area-container + update-info + get-file-menu + file-menu:get-close-item + file-menu:get-save-item + file-menu:get-save-as-item + file-menu:get-revert-item + file-menu:get-print-item) + + ;; logging : (union #f string[directory-name]) + (field [logging #f] + [definitions-log-counter 0] ;; number + [interactions-log-counter 0] ;; number + [logging-parent-panel #f] ;; panel (unitialized short time only) + [logging-panel #f] ;; panel (unitialized short time only) + [logging-menu-item #f]) ;; menu-item (unitialized short time only) + ;; log-definitions : -> void + (define/private (log-definitions) + (when logging + (set! definitions-log-counter (+ definitions-log-counter 1)) + (send definitions-text save-file + (build-path logging (format "~a-definitions" (pad-two definitions-log-counter))) + 'copy))) + + ;; log-ineractions : -> void + (define/private (log-interactions) + (when logging + (set! interactions-log-counter (+ interactions-log-counter 1)) + (send interactions-text save-file + (build-path logging (format "~a-interactions" (pad-two interactions-log-counter))) + 'copy))) + + ;; pad-two : number -> string + ;; pads a number to two digits? + (define/private (pad-two n) + (cond + [(<= 0 n 9) (format "0~a" n)] + [else (format "~a" n)])) + + ;; start-logging : -> void + ;; turns on the logging and shows the logging gui + (define/private (start-logging) + (let ([log-directory (mred:get-directory + (string-constant please-choose-a-log-directory) + this)]) + (when (and log-directory + (ensure-empty log-directory)) + (send logging-menu-item set-label (string-constant stop-logging)) + (set! logging log-directory) + (set! definitions-log-counter 0) + (set! interactions-log-counter 0) + (build-logging-panel) + (log-definitions)))) + + ;; stop-logging : -> void + ;; turns off the logging procedure + (define/private (stop-logging) + (log-interactions) + (send logging-menu-item set-label (string-constant log-definitions-and-interactions)) + (set! logging #f) + (send logging-panel change-children (λ (l) null))) + + ;; build-logging-panel : -> void + ;; builds the contents of the logging panel + (define/private (build-logging-panel) + (define hp (make-object horizontal-panel% logging-panel '(border))) + (make-object message% (string-constant logging-to) hp) + (send (make-object message% (path->string logging) hp) stretchable-width #t) + (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-logging)))) + + ;; ensure-empty : string[directory] -> boolean + ;; if the log-directory is empty, just return #t + ;; if not, ask the user about emptying it. + ;; if they say yes, try to empty it. + ;; if that fails, report the error and return #f. + ;; if it succeeds, return #t. + ;; if they say no, return #f. + (define/private (ensure-empty log-directory) + (let ([dir-list (directory-list log-directory)]) + (or (null? dir-list) + (let ([query (message-box + (string-constant drscheme) + (gui-utils:format-literal-label (string-constant erase-log-directory-contents) log-directory) + this + '(yes-no))]) + (cond + [(eq? query 'no) + #f] + [(eq? query 'yes) + (with-handlers ([exn:fail:filesystem? + (λ (exn) + (message-box + (string-constant drscheme) + (gui-utils:format-literal-label (string-constant error-erasing-log-directory) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) + this) + #f)]) + (for-each (λ (file) (delete-file (build-path log-directory file))) + dir-list) + #t)]))))) + + (define/override (make-root-area-container cls parent) + (let* ([outer-panel (super make-root-area-container module-browser-dragable-panel% parent)] + [saved-p (preferences:get 'drscheme:module-browser-size-percentage)] + [_module-browser-panel (new vertical-panel% + (parent outer-panel) + (alignment '(left center)) + (stretchable-width #f))] + [louter-panel (make-object vertical-panel% outer-panel)] + [root (make-object cls louter-panel)]) + (set! module-browser-panel _module-browser-panel) + (set! module-browser-parent-panel outer-panel) + (send outer-panel change-children (λ (l) (remq module-browser-panel l))) + (preferences:set 'drscheme:module-browser-size-percentage saved-p) + (set! logging-parent-panel (new horizontal-panel% + (parent louter-panel) + (stretchable-height #f))) + (set! logging-panel (make-object horizontal-panel% logging-parent-panel)) + (unless (toolbar-shown?) + (send logging-parent-panel change-children (λ (l) '()))) + root)) + + (inherit show-info hide-info is-info-hidden?) + (field [toolbar-state (preferences:get 'drscheme:toolbar-state)] + [toolbar-top-menu-item #f] + [toolbar-left-menu-item #f] + [toolbar-right-menu-item #f] + [toolbar-hidden-menu-item #f] + [toolbar-menu #f]) + + ;; returns #t if the toolbar is visible, #f otherwise + (define/private (toolbar-shown?) (car toolbar-state)) + + (define/private (change-toolbar-state new-state) + (set! toolbar-state new-state) + (preferences:set 'drscheme:toolbar-state new-state) + (update-toolbar-visibility)) + + (define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) + (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) + (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) + (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) + (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) + + (define/public (update-toolbar-visibility) + (let* ([hidden? (toolbar-is-hidden?)] + [left? (toolbar-is-left?)] + [right? (toolbar-is-right?)] + [top? (toolbar-is-top?)]) + + (send toolbar-left-menu-item check left?) + (send toolbar-right-menu-item check right?) + (send toolbar-top-menu-item check top?) + (send toolbar-hidden-menu-item check hidden?) + + (cond + [hidden? + (hide-info) + (send top-outer-panel change-children (λ (l) '())) + (send logging-parent-panel change-children (λ (l) '()))] + [top? (orient/show #t)] + [left? (orient/show #t)] + [right? (orient/show #f)])) + (update-defs/ints-resize-corner)) + + (define/private (toolbar-is-hidden?) + (car (preferences:get 'drscheme:toolbar-state))) + (define/private (toolbar-is-top?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'top))) + (define/private (toolbar-is-right?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'right))) + (define/private (toolbar-is-left?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'left))) + + (define/private (orient/show bar-at-beginning?) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (begin-container-sequence) + (show-info) + + (let ([bpo (send button-panel get-orientation)]) + (unless (equal? bpo (not vertical?)) + (send button-panel set-orientation (not vertical?)) + + ;; have to be careful to avoid reversing the list when the orientation is already proper + (send button-panel change-children reverse))) + + (orient) + + (send top-outer-panel stretchable-height vertical?) + (send top-outer-panel stretchable-width (not vertical?)) + (send top-panel set-orientation (not vertical?)) + (send toolbar/rest-panel set-orientation vertical?) + (send toolbar/rest-panel change-children + (λ (l) + (if bar-at-beginning? + (cons top-outer-panel (remq top-outer-panel l)) + (append (remq top-outer-panel l) (list top-outer-panel))))) + (send top-outer-panel change-children (λ (l) (list top-panel))) + (send logging-parent-panel change-children (λ (l) (list logging-panel))) + (if vertical? + (send top-panel change-children (λ (x) (remq name-panel x))) + (send top-panel change-children (λ (x) (cons name-panel (remq name-panel x))))) + (end-container-sequence))) + + (define toolbar-buttons '()) + (define/public (register-toolbar-button b) + (set! toolbar-buttons (cons b toolbar-buttons)) + (orient)) + + (define/private (orient) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (for-each + (λ (obj) (send obj set-label-visible (not vertical?))) + toolbar-buttons)) + + (let loop ([obj button-panel]) + (cond + [(is-a? obj area-container<%>) + (for-each loop (send obj get-children))] + [(is-a? obj switchable-button%) + (unless (memq obj toolbar-buttons) + (error 'register-toolbar-button "found a switchable-button% that is not registered, label ~s" + (send obj get-label)))] + [else (void)]))) + + (field [remove-show-status-line-callback + (preferences:add-callback + 'framework:show-status-line + (λ (p v) + (update-defs/ints-resize-corner/pref v)))]) + + (define/private (update-defs/ints-resize-corner) + (update-defs/ints-resize-corner/pref + (preferences:get 'framework:show-status-line))) + + (define/private (update-defs/ints-resize-corner/pref si-pref) + (let ([bottom-material? (and (not (car toolbar-state)) + si-pref)]) + (let loop ([cs definitions-canvases]) + (cond + [(null? cs) (void)] + [(null? (cdr cs)) + (send (car cs) set-resize-corner (and (not bottom-material?) + (not interactions-shown?)))] + [else + (send (car cs) set-resize-corner #f) + (loop (cdr cs))])) + (let loop ([cs interactions-canvases]) + (cond + [(null? cs) (void)] + [(null? (cdr cs)) + (send (car cs) set-resize-corner (and (not bottom-material?) + interactions-shown?))] + [else + (send (car cs) set-resize-corner #f) + (loop (cdr cs))])))) + + [define definitions-item #f] + [define interactions-item #f] + [define name-message #f] + [define save-button #f] + [define save-init-shown? #f] + + [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))] + + [define canvas-show-mode #f] + [define allow-split? #f] + [define forced-quit? #f] + [define search-canvas #f] + + (define/public (make-searchable canvas) + (update-info) + (set! search-canvas canvas)) + (define/override (get-text-to-search) + (if search-canvas + (send search-canvas get-editor) + (get-editor))) + + (define was-locked? #f) + + (define/public-final (disable-evaluation-in-tab tab) + (when (eq? tab current-tab) + (disable-evaluation))) + + (define/pubment (disable-evaluation) + (when execute-menu-item + (send execute-menu-item enable #f)) + (send execute-button enable #f) + (inner (void) disable-evaluation)) + + (define/public-final (enable-evaluation-in-tab tab) + (when (eq? tab current-tab) + (enable-evaluation))) + + (define/pubment (enable-evaluation) + (when execute-menu-item + (send execute-menu-item enable #t)) + (send execute-button enable #t) + (inner (void) enable-evaluation)) + + (inherit set-label) + (inherit modified) + (define/public (update-save-button) + (let ([mod? (send definitions-text is-modified?)]) + (modified mod?) + (if save-button + (unless (eq? mod? (send save-button is-shown?)) + (send save-button show mod?)) + (set! save-init-shown? mod?)) + (update-tab-label current-tab))) + + (define/public (language-changed) + (let* ([settings (send definitions-text get-next-settings)] + [language (drscheme:language-configuration:language-settings-language settings)]) + (send func-defs-canvas language-changed language) + (send language-message set-yellow/lang + (not (send definitions-text this-and-next-language-the-same?)) + (string-append (send language get-language-name) + (if (send language default-settings? + (drscheme:language-configuration:language-settings-settings settings)) + "" + (string-append " " (string-constant custom))))) + (let ([label (send scheme-menu get-label)] + [new-label (send language capability-value 'drscheme:language-menu-title)]) + (unless (equal? label new-label) + (send scheme-menu set-label new-label))))) + + (define/public (get-language-menu) scheme-menu) + + ;; update-save-message : -> void + ;; sets the save message. If input is #f, uses the frame's + ;; title. + (define/public (update-save-message) + (when name-message + (let ([filename (send definitions-text get-filename)]) + (send name-message set-message + (if filename #t #f) + (send definitions-text get-filename/untitled-name)))) + (update-tabs-labels)) + + (define/private (update-tabs-labels) + (for-each (λ (tab) (update-tab-label tab)) tabs) + (send tabs-panel set-selection (send current-tab get-i)) + (send (send tabs-panel get-parent) + change-children + (λ (l) + (cond + [(= (send tabs-panel get-number) 1) + (remq tabs-panel l)] + [else + (if (memq tabs-panel l) + l + (cons tabs-panel l))])))) + + (define/private (update-tab-label tab) + (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) + (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) + (send tabs-panel set-item-label (send tab get-i) label)))) + + (define/private (get-defs-tab-label defs tab) + (let ([fn (send defs get-filename)]) + (add-modified-flag + defs + (if fn + (get-tab-label-from-filename fn) + (send defs get-filename/untitled-name))))) + + (define/private (get-tab-label-from-filename fn) + (let* ([take-n + (λ (n lst) + (let loop ([n n] + [lst lst]) + (cond + [(zero? n) null] + [(null? lst) null] + [else (cons (car lst) (loop (- n 1) (cdr lst)))])))] + [find-exp-diff + (λ (p1 p2) + (let loop ([p1 p1] + [p2 p2] + [i 1]) + (cond + [(or (null? p1) (null? p2)) i] + [else (let ([f1 (car p1)] + [f2 (car p2)]) + (if (equal? f1 f2) + (loop (cdr p1) (cdr p2) (+ i 1)) + i))])))] + [exp (reverse (explode-path (normalize-path/exists fn)))] + [other-exps + (filter + (λ (x) (and x + (not (equal? exp x)))) + (map (λ (other-tab) + (let ([fn (send (send other-tab get-defs) get-filename)]) + (and fn + (reverse (explode-path (normalize-path/exists fn)))))) + tabs))] + [size + (let loop ([other-exps other-exps] + [size 1]) + (cond + [(null? other-exps) size] + [else (let ([new-size (find-exp-diff (car other-exps) exp)]) + (loop (cdr other-exps) + (max new-size size)))]))]) + (path->string (apply build-path (reverse (take-n size exp)))))) + + (define/private (normalize-path/exists fn) + (if (file-exists? fn) + (normalize-path fn) + fn)) + + (define/private (add-modified-flag text string) + (if (send text is-modified?) + (let ([prefix (get-save-diamond-prefix)]) + (if prefix + (string-append prefix string) + string)) + string)) + + (define/private (get-save-diamond-prefix) + (let ([candidate-prefixes (list + (case (system-type) + [(windows) "• "] + [else "◆ "]) + "* ")]) + (ormap + (lambda (candidate) + (and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t)) + (string->list candidate)) + candidate)) + candidate-prefixes))) + + [define/override get-canvas% (λ () (drscheme:get/extend:get-definitions-canvas))] + + (define/public (update-running running?) + (send running-canvas set-running running?)) + (define/public (ensure-defs-shown) + (unless definitions-shown? + (toggle-show/hide-definitions) + (update-shown))) + (define/public (ensure-rep-shown rep) + (unless (eq? rep interactions-text) + (let loop ([tabs tabs]) + (unless (null? tabs) + (let ([tab (car tabs)]) + (if (eq? (send tab get-ints) rep) + (change-to-tab tab) + (loop (cdr tabs))))))) + (unless interactions-shown? + (toggle-show/hide-interactions) + (update-shown))) + (define/public (ensure-rep-hidden) + (when interactions-shown? + (toggle-show/hide-interactions) + (update-shown))) + + (define/override (get-editor%) (drscheme:get/extend:get-definitions-text)) + (define/public (still-untouched?) + (and (= (send definitions-text last-position) 0) + (not (send definitions-text is-modified?)) + (not (send definitions-text get-filename)) + (let* ([prompt (send interactions-text get-prompt)] + [first-prompt-para + (let loop ([n 0]) + (cond + [(n . <= . (send interactions-text last-paragraph)) + (if (string=? + (send interactions-text get-text + (send interactions-text paragraph-start-position n) + (+ (send interactions-text paragraph-start-position n) + (string-length prompt))) + prompt) + n + (loop (+ n 1)))] + [else #f]))]) + (and first-prompt-para + (= first-prompt-para (send interactions-text last-paragraph)) + (equal? + (send interactions-text get-text + (send interactions-text paragraph-start-position first-prompt-para) + (send interactions-text paragraph-end-position first-prompt-para)) + (send interactions-text get-prompt)))))) + (define/public (change-to-file name) + (cond + [(and name (file-exists? name)) + (ensure-rep-hidden) + (send definitions-text begin-edit-sequence) + (send definitions-text load-file/gui-error name) + (send definitions-text end-edit-sequence) + (send language-message set-yellow #f)] + [name + (send definitions-text set-filename name)] + [else (send definitions-text clear)]) + (send definitions-canvas focus)) + + + + + + ; + ; + ; + ; ; + ; ; + ; ; + ; ; ;; ;; ;;; ;; ; ;;; ;;; + ; ;; ;; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ;;;;;; ;; + ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; + ; ; ; ; ;;; ;; ; ;;;; ;;; + ; + ; + ; + + + (define/private (add-modes-submenu edit-menu) + (new menu% + (parent edit-menu) + (label (string-constant mode-submenu-label)) + (demand-callback + (λ (menu) + (for-each (λ (item) (send item delete)) + (send menu get-items)) + (for-each (λ (mode) + (let* ([item + (new checkable-menu-item% + (label (drscheme:modes:mode-name mode)) + (parent menu) + (callback + (λ (_1 _2) (send definitions-text set-current-mode mode))))]) + (when (send definitions-text is-current-mode? mode) + (send item check #t)))) + (drscheme:modes:get-modes)))))) + + + + + ; + ; + ; + ; ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; + ; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; + ; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;; + ; ; ; ; + ; ; ; ; + ; ; ; + + + (inherit get-edit-target-window) + + (define/private (split) + (let ([canvas-to-be-split (get-edit-target-window)]) + (cond + [(memq canvas-to-be-split definitions-canvases) + (split-definitions canvas-to-be-split)] + [(memq canvas-to-be-split interactions-canvases) + (split-interactions canvas-to-be-split)] + [else (bell)]))) + + (define/private (split-definitions canvas-to-be-split) + (handle-split canvas-to-be-split + (λ (x) (set! definitions-canvases x)) + definitions-canvases + (drscheme:get/extend:get-definitions-canvas) + definitions-text)) + + (define/private (split-interactions canvas-to-be-split) + (handle-split canvas-to-be-split + (λ (x) (set! interactions-canvases x)) + interactions-canvases + (drscheme:get/extend:get-interactions-canvas) + interactions-text)) + + (define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text) + (let-values ([(ox oy ow oh cursor-y) + (get-visible-region canvas-to-be-split)]) + (let ([orig-percentages (send resizable-panel get-percentages)] + [orig-canvases (send resizable-panel get-children)] + [new-canvas (new canvas% + (parent resizable-panel) + (editor text) + (style '()))]) + + (set-canvases! + (let loop ([canvases canvases]) + (cond + [(null? canvases) (error 'split "couldn't split; didn't find canvas")] + [else + (let ([canvas (car canvases)]) + (if (eq? canvas canvas-to-be-split) + (list* new-canvas + canvas + (cdr canvases)) + (cons canvas (loop (cdr canvases)))))]))) + + (update-shown) + + ;; with-handlers prevents bad calls to set-percentages + ;; might still leave GUI in bad state, however. + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages + (let loop ([canvases orig-canvases] + [percentages orig-percentages]) + (cond + [(null? canvases) + (error 'split "couldn't split; didn't find canvas")] + [(null? percentages) + (error 'split "wrong number of percentages: ~s ~s" + orig-percentages + (send resizable-panel get-children))] + [else (let ([canvas (car canvases)]) + (if (eq? canvas-to-be-split canvas) + (list* (/ (car percentages) 2) + (/ (car percentages) 2) + (cdr percentages)) + (cons + (car percentages) + (loop (cdr canvases) + (cdr percentages)))))])))) + + (set-visible-region new-canvas ox oy ow oh cursor-y) + (set-visible-region canvas-to-be-split ox oy ow oh cursor-y) + + (send new-canvas focus)))) + + ;; split-demand : menu-item -> void + ;; enables the menu-item if splitting is allowed, disables otherwise + (define/private (split-demand item) + (let ([canvas-to-be-split (get-edit-target-window)]) + (send item enable + (or (memq canvas-to-be-split definitions-canvases) + (memq canvas-to-be-split interactions-canvases))))) + + ;; collapse-demand : menu-item -> void + ;; enables the menu-item if collapsing is allowed, disables otherwise + (define/private (collapse-demand item) + (let ([canvas-to-be-split (get-edit-target-window)]) + (cond + [(memq canvas-to-be-split definitions-canvases) + (send item enable (2 . <= . (length definitions-canvases)))] + [(memq canvas-to-be-split interactions-canvases) + (send item enable (2 . <= . (length interactions-canvases)))] + [else + (send item enable #f)]))) + + ;; get-visible-region : editor-canvas -> number number number number (union #f number) + ;; calculates the visible region of the editor in this editor-canvas, returning + ;; four numbers for the x, y, width and height of the visible region + ;; also, the last two booleans indiciate if the beginning and the end + ;; of the selection was visible before the split, respectively. + (define/private (get-visible-region canvas) + (send canvas call-as-primary-owner + (λ () + (let* ([text (send canvas get-editor)] + [admin (send text get-admin)] + [start (send text get-start-position)] + [end (send text get-end-position)]) + (let-values ([(x y w h) (get-visible-area admin)]) + (let ([ysb (box 0)]) + (send text position-location (send text get-start-position) #f ysb) + (values x y w h + (and (= start end) + (<= y (unbox ysb) (+ y h)) + (unbox ysb))))))))) + + ;; set-visible-region : editor-canvas number number number number (union #f number) -> void + ;; sets the visible region of the text displayed by the editor canvas + ;; to be the middle of the region (vertically) specified by x, y, w, and h. + ;; if start-visible? and/or end-visible? are true, some special handling + ;; is done to try to keep the start and end visible, with precendence + ;; given to start if both are #t. + (define/private (set-visible-region canvas x y w h cursor-y) + (send canvas call-as-primary-owner + (λ () + (let* ([text (send canvas get-editor)] + [admin (send text get-admin)] + [nwb (box 0)] + [nhb (box 0)]) + (send admin get-view #f #f nwb nhb) + (let* ([nw (unbox nwb)] + [nh (unbox nhb)] + + [nx x] + [raw-y (- (+ y (/ h 2)) (/ nh 2))] + [ny (if (and cursor-y + (not (<= raw-y cursor-y (+ raw-y nh)))) + (- cursor-y (/ nh 2)) + raw-y)]) + (send canvas scroll-to nx ny nw nh #t) + (void)))))) + + ;; get-visible-area : admin -> number number number number + ;; returns the visible area for this admin + (define/private (get-visible-area admin) + (let ([bx (box 0)] + [by (box 0)] + [bw (box 0)] + [bh (box 0)]) + (send admin get-view bx by bw bh) + (values (unbox bx) + (unbox by) + (unbox bw) + (unbox bh)))) + + (define/private (collapse) + (let* ([target (get-edit-target-window)]) + (cond + [(memq target definitions-canvases) + (collapse-definitions target)] + [(memq target interactions-canvases) + (collapse-interactions target)] + [else (bell)]))) + + (define/private (collapse-definitions target) + (handle-collapse + target + (λ () definitions-canvases) + (λ (c) (set! definitions-canvases c)))) + + (define/private (collapse-interactions target) + (handle-collapse + target + (λ () interactions-canvases) + (λ (c) (set! interactions-canvases c)))) + + (define/private (handle-collapse target get-canvases set-canvases!) + (if (= 1 (length (get-canvases))) + (bell) + (let* ([old-percentages (send resizable-panel get-percentages)] + [soon-to-be-bigger-canvas #f] + [percentages + (if (eq? (car (get-canvases)) target) + (begin + (set! soon-to-be-bigger-canvas (cadr (get-canvases))) + (cons (+ (car old-percentages) + (cadr old-percentages)) + (cddr old-percentages))) + (let loop ([canvases (cdr (get-canvases))] + [prev-canvas (car (get-canvases))] + [percentages (cdr old-percentages)] + [prev-percentage (car old-percentages)]) + (cond + [(null? canvases) + (error 'collapse "internal error.1")] + [(null? percentages) + (error 'collapse "internal error.2")] + [else + (if (eq? (car canvases) target) + (begin + (set! soon-to-be-bigger-canvas prev-canvas) + (cons (+ (car percentages) + prev-percentage) + (cdr percentages))) + (cons prev-percentage + (loop (cdr canvases) + (car canvases) + (cdr percentages) + (car percentages))))])))]) + (unless soon-to-be-bigger-canvas + (error 'collapse "internal error.3")) + (set-canvases! (remq target (get-canvases))) + (update-shown) + + (let ([target-admin + (send target call-as-primary-owner + (λ () + (send (send target get-editor) get-admin)))] + [to-be-bigger-admin + (send soon-to-be-bigger-canvas call-as-primary-owner + (λ () + (send (send soon-to-be-bigger-canvas get-editor) get-admin)))]) + (let-values ([(bx by bw bh) (get-visible-area target-admin)]) + + ;; this line makes the soon-to-be-bigger-canvas bigger + ;; if it fails, we're out of luck, but at least we don't crash. + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages percentages)) + + (let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)]) + (send soon-to-be-bigger-canvas scroll-to + bx + (- by (/ (- ah bh) 2)) + aw + ah + #t)))) + + (send target set-editor #f) + (send soon-to-be-bigger-canvas focus)))) + ; + ; + ; + ; ; + ; ; + ; ; + ; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ; + ; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; + ; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ; + ; + ; + ; + + + (define interactions-shown? #t) + (define definitions-shown? #t) + + (define/private (toggle-show/hide-definitions) + (set! definitions-shown? (not definitions-shown?)) + (unless definitions-shown? + (set! interactions-shown? #t))) + (define/private (toggle-show/hide-interactions) + (set! interactions-shown? (not interactions-shown?)) + (unless interactions-shown? + (set! definitions-shown? #t))) + + (define/override (update-shown) + (super update-shown) + + (let ([new-children + (foldl + (λ (shown? children sofar) + (if shown? + (append children sofar) + sofar)) + null + (list interactions-shown? + definitions-shown?) + (list interactions-canvases + definitions-canvases))] + [p (preferences:get 'drscheme:unit-window-size-percentage)]) + + (update-defs/ints-resize-corner) + + (send definitions-item set-label + (if definitions-shown? + (string-constant hide-definitions-menu-item-label) + (string-constant show-definitions-menu-item-label))) + (send interactions-item set-label + (if interactions-shown? + (string-constant hide-interactions-menu-item-label) + (string-constant show-interactions-menu-item-label))) + + (send resizable-panel begin-container-sequence) + + ;; this might change the unit-window-size-percentage, so save/restore it + (send resizable-panel change-children (λ (l) new-children)) + + (preferences:set 'drscheme:unit-window-size-percentage p) + + ;; restore preferred interactions/definitions sizes + (when (and (= 1 (length definitions-canvases)) + (= 1 (length interactions-canvases)) + (= 2 (length new-children))) + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages + (list p (- 1 p)))))) + + (send resizable-panel end-container-sequence) + + (when (ormap (λ (child) + (and (is-a? child editor-canvas%) + (not (send child has-focus?)))) + (send resizable-panel get-children)) + (let loop ([children (send resizable-panel get-children)]) + (cond + [(null? children) (void)] + [else (let ([child (car children)]) + (if (is-a? child editor-canvas%) + (send child focus) + (loop (cdr children))))]))) + + + (for-each + (λ (get-item) + (let ([item (get-item)]) + (when item + (send item enable definitions-shown?)))) + (list (λ () (file-menu:get-revert-item)) + (λ () (file-menu:get-save-item)) + (λ () (file-menu:get-save-as-item)) + ;(λ () (file-menu:save-as-text-item)) ; Save As Text... + (λ () (file-menu:get-print-item)))) + (send file-menu:print-transcript-item enable interactions-shown?)) + + (define/augment (can-close?) + (and (andmap (lambda (tab) + (or (eq? tab current-tab) + (and (send (send tab get-defs) can-close?) + (send (send tab get-ints) can-close?)))) + tabs) + (send interactions-text can-close?) + (inner #t can-close?))) + (define/augment (on-close) + (inner (void) on-close) + (for-each (lambda (tab) + (unless (eq? tab current-tab) + (send (send tab get-defs) on-close) + (send (send tab get-ints) on-close))) + tabs) + (when (eq? this newest-frame) + (set! newest-frame #f)) + (when logging + (stop-logging)) + (remove-show-status-line-callback) + (send interactions-text on-close)) + + ;; execute-callback : -> void + ;; uses the state of the button to determine if an execution is + ;; already running. This function is called from many places, not + ;; just the execute button. + (define/public (execute-callback) + (when (send execute-button is-enabled?) + + ;; if the language is not-a-language, and the buffer looks like a module, + ;; automatically make the switch to the module language + (let ([next-settings (send definitions-text get-next-settings)]) + (when (is-a? (drscheme:language-configuration:language-settings-language next-settings) + drscheme:language-configuration:not-a-language-language<%>) + (when (looks-like-module? definitions-text) + (let-values ([(module-language module-language-settings) (get-module-language/settings)]) + (when (and module-language module-language-settings) + (send definitions-text set-next-settings + (drscheme:language-configuration:make-language-settings + module-language + module-language-settings))))))) + + (check-if-save-file-up-to-date) + (when (preferences:get 'drscheme:show-interactions-on-execute) + (ensure-rep-shown interactions-text)) + (when logging + (log-definitions) + (log-interactions)) + (send definitions-text just-executed) + (send language-message set-yellow #f) + (send interactions-canvas focus) + (send interactions-text reset-console) + (send interactions-text clear-undos) + + (let ([start 0]) + (send definitions-text split-snip start) + (let* ([name (send definitions-text get-port-name)] + [text-port (open-input-text-editor definitions-text start 'end values name)]) + (port-count-lines! text-port) + (let* ([line (send definitions-text position-paragraph start)] + [column (- start (send definitions-text paragraph-start-position line))] + [relocated-port (relocate-input-port text-port + (+ line 1) + column + (+ start 1))]) + (port-count-lines! relocated-port) + (send interactions-text evaluate-from-port + relocated-port + #t + (λ () + (send interactions-text clear-undos)))))))) + + (inherit revert save) + (define/private (check-if-save-file-up-to-date) + (when (send definitions-text save-file-out-of-date?) + (let ([user-choice + (message-box/custom + (string-constant drscheme) + (string-constant definitions-modified) + (string-constant ignore) + (string-constant revert) + #f + this + '(caution default=2 number-order) + 1)]) + (case user-choice + [(1) (void)] + [(2) (revert)])))) + + (inherit get-menu-bar get-focus-object get-edit-target-object) + + (inherit is-maximized?) + (define/override (on-size w h) + (preferences:set 'drscheme:unit-window-width w) + (preferences:set 'drscheme:unit-window-height h) + (preferences:set 'drscheme:unit-window-max? (is-maximized?)) + (super on-size w h)) + + (define on-move-timer-args #f) + (define on-move-timer #f) + (define/override (on-move x y) + (cond + [on-move-timer + (set! on-move-timer-args (cons x y))] + [else + (set! on-move-timer-args (cons x y)) + (set! on-move-timer + (new timer% + [notify-callback + (λ () + (set! on-move-timer #f) + (set! on-move-timer-args #f) + (preferences:set 'drscheme:frame:initial-position on-move-timer-args))] + [interval 1000] + [just-once? #t]))])) + + (define/override (get-editor) definitions-text) + (define/override (get-canvas) + (initialize-definitions-canvas) + definitions-canvas) + (define/private (initialize-definitions-canvas) + (unless definitions-canvas + (set! definitions-canvas + (new (drscheme:get/extend:get-definitions-canvas) + (parent resizable-panel) + (editor definitions-text))))) + + (define/override (get-delegated-text) definitions-text) + (define/override (get-open-here-editor) definitions-text) + + ;; wire the definitions text to the interactions text and initialize it. + (define/private (init-definitions-text tab) + (let ([defs (send tab get-defs)] + [ints (send tab get-ints)]) + (send defs set-interactions-text ints) + (send defs set-tab tab) + (send ints set-definitions-text defs) + (send defs change-mode-to-match))) + + + ; + ; + ; @@ + ; @ @ + ; @@@@@ $@$: @-@$ :@@+@ + ; @ -@ @+ *$ @$ -@ + ; @ -$@$@ @ @ :@@$- + ; @ $* @ @ @ *@ + ; @: :$ @- *@ @ +$ @ :@ + ; :@@$- -$$-@@@@+@$ $+@@: + ; + ; + ; + ; + + (define/public (get-current-tab) current-tab) + + ;; create-new-tab : -> void + ;; creates a new tab and updates the GUI for that new tab + (define/private create-new-tab + (lambda ([filename #f]) + (let* ([defs (new (drscheme:get/extend:get-definitions-text))] + [tab-count (length tabs)] + [new-tab (new (drscheme:get/extend:get-tab) + (defs defs) + (i tab-count) + (frame this) + (defs-shown? #t) + (ints-shown? (not filename)))] + [ints (make-object (drscheme:get/extend:get-interactions-text) new-tab)]) + (send new-tab set-ints ints) + (set! tabs (append tabs (list new-tab))) + (send tabs-panel append + (gui-utils:trim-string + (if filename + (get-tab-label-from-filename filename) + (get-defs-tab-label defs #f)) + 200)) + (init-definitions-text new-tab) + (when filename (send defs load-file filename)) + (change-to-nth-tab (- (send tabs-panel get-number) 1)) + (send ints initialize-console) + (send tabs-panel set-selection (- (send tabs-panel get-number) 1)) + (set! newest-frame this) + (update-menu-bindings)))) + + ;; change-to-tab : tab -> void + ;; updates current-tab, definitions-text, and interactactions-text + ;; to be the nth tab. Also updates the GUI to show the new tab + (inherit begin-container-sequence end-container-sequence) + (define/private (change-to-tab tab) + (let ([old-delegate (send definitions-text get-delegate)] + [old-tab current-tab]) + (save-visible-tab-regions) + (set! current-tab tab) + (set! definitions-text (send current-tab get-defs)) + (set! interactions-text (send current-tab get-ints)) + + + (begin-container-sequence) + (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text)) + definitions-canvases) + (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text)) + interactions-canvases) + + (update-save-message) + (update-save-button) + (language-changed) + + (send definitions-text update-frame-filename) + (send definitions-text set-delegate old-delegate) + (update-running (send current-tab is-running?)) + (on-tab-change old-tab current-tab) + + (end-container-sequence) + ;; restore-visible-tab-regions has to be outside the container sequence + ;; or else things get moved again during the container sequence end + (restore-visible-tab-regions))) + + (define/pubment (on-tab-change from-tab to-tab) + (let ([old-enabled (send from-tab get-enabled)] + [new-enabled (send to-tab get-enabled)]) + (unless (eq? old-enabled new-enabled) + (if new-enabled + (enable-evaluation) + (disable-evaluation)))) + + (let ([from-defs (send from-tab get-defs)] + [to-defs (send to-tab get-defs)]) + (let ([delegate (send from-defs get-delegate)]) + (send from-defs set-delegate #f) + (send to-defs set-delegate delegate))) + + (inner (void) on-tab-change from-tab to-tab)) + + (define/public (next-tab) (change-to-delta-tab +1)) + (define/public (prev-tab) (change-to-delta-tab -1)) + + (define/private (change-to-delta-tab dt) + (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) + + (define/private (close-current-tab) + (cond + [(null? tabs) (void)] + [(null? (cdr tabs)) (void)] + [else + (let loop ([l-tabs tabs]) + (cond + [(null? l-tabs) (error 'close-current-tab "uh oh.3")] + [else + (let ([tab (car l-tabs)]) + (if (eq? tab current-tab) + (when (close-tab tab) + (for-each (lambda (t) (send t set-i (- (send t get-i) 1))) + (cdr l-tabs)) + (set! tabs (remq tab tabs)) + (send tabs-panel delete (send tab get-i)) + (update-menu-bindings) + (change-to-tab (cond + [(< (send tab get-i) (length tabs)) + (list-ref tabs (send tab get-i))] + [else (last tabs)]))) + (loop (cdr l-tabs))))]))])) + + (define/private (close-tab tab) + (cond + [(send tab can-close?) + (send tab on-close) + #t] + [else #f])) + + (define/public (open-in-new-tab filename) + (create-new-tab filename)) + + (define/private (change-to-nth-tab n) + (unless (< n (length tabs)) + (error 'change-to-nth-tab "number too big ~s" n)) + (change-to-tab (list-ref tabs n))) + + (define/private (save-visible-tab-regions) + (send current-tab set-visible-ints + (get-tab-visible-regions interactions-text) + interactions-shown?) + (send current-tab set-visible-defs + (get-tab-visible-regions definitions-text) + definitions-shown?) + (send current-tab set-focus-d/i + (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) + 'ints + 'defs))) + + (define/private (get-tab-visible-regions txt) + (map (λ (canvas) + (let-values ([(x y w h _) (get-visible-region canvas)]) + (list x y w h))) + (send txt get-canvases))) + + (define/private (restore-visible-tab-regions) + (define (set-visible-regions txt regions ints?) + (when regions + (let* ([canvases (send txt get-canvases)] + [canvases-count (length canvases)] + [regions-count (length regions)]) + (cond + [(> canvases-count regions-count) + (let loop ([i (- canvases-count regions-count)] + [canvases canvases]) + (unless (zero? i) + (if ints? + (collapse-interactions (car canvases)) + (collapse-definitions (car canvases))) + (loop (- i 1) + (cdr canvases))))] + [(= canvases-count regions-count) + (void)] + [(< canvases-count regions-count) + (let loop ([i (- regions-count canvases-count)] + [canvases canvases]) + (unless (zero? i) + (if ints? + (split-interactions (car canvases)) + (split-definitions (car canvases))) + (loop (- i 1) + (cdr canvases))))])) + (for-each (λ (c r) + (set-visible-tab-region txt c r)) + (send txt get-canvases) + regions))) + (define (set-visible-tab-region txt canvas region) + (let ([admin (send txt get-admin)]) + (send admin scroll-to + (first region) + (second region) + (third region) + (fourth region)))) + (let-values ([(vi is?) (send current-tab get-visible-ints)] + [(vd ds?) (send current-tab get-visible-defs)]) + (set! interactions-shown? is?) + (set! definitions-shown? ds?) + (update-shown) + (set-visible-regions definitions-text vd #f) + (set-visible-regions interactions-text vi #t)) + (case (send current-tab get-focus-d/i) + [(defs) (send (car definitions-canvases) focus)] + [(ints) (send (car interactions-canvases) focus)])) + + (define/private (pathname-equal? p1 p2) + (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (string=? (path->string (normal-case-path (normalize-path p1))) + (path->string (normal-case-path (normalize-path p2)))))) + (define/override (make-visible filename) + (let loop ([tabs tabs]) + (unless (null? tabs) + (let* ([tab (car tabs)] + [tab-filename (send (send tab get-defs) get-filename)]) + (if (and tab-filename + (pathname-equal? filename tab-filename)) + (change-to-tab tab) + (loop (cdr tabs))))))) + + (define/override (editing-this-file? filename) + (ormap (λ (tab) + (let ([fn (send (send tab get-defs) get-filename)]) + (and fn + (pathname-equal? fn filename)))) + tabs)) + + (define/override (get-menu-item%) + (class (super get-menu-item%) + (inherit get-label get-plain-label) + (define/override (restore-keybinding) + (cond + [(equal? (get-plain-label) (string-constant close)) + (update-close-menu-item-shortcut this)] + [(equal? (get-plain-label) (string-constant close-tab)) + (update-close-tab-menu-item-shortcut this)] + [else (super restore-keybinding)])) + (super-new))) + + (define/private (update-menu-bindings) + (when (preferences:get 'framework:menu-bindings) + (when close-tab-menu-item + (update-close-tab-menu-item-shortcut close-tab-menu-item)) + (update-close-menu-item-shortcut (file-menu:get-close-item)))) + + (define/private (update-close-tab-menu-item-shortcut item) + (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) + (send item set-label (if just-one? + (string-constant close-tab) + (string-constant close-tab-amp))) + (send item set-shortcut (if just-one? #f #\w)))) + + (define/private (update-close-menu-item-shortcut item) + (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) + (send item set-label (if just-one? + (string-constant close-menu-item) + (string-constant close))) + (send item set-shortcut (if just-one? #\w #f)))) + + + ;; + ;; end tabs + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define/public (get-definitions-text) definitions-text) + (define/public (get-interactions-text) interactions-text) + + (define/public (get-definitions/interactions-panel-parent) + toolbar/rest-panel) + + (inherit delegated-text-shown? hide-delegated-text show-delegated-text) + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! definitions-item + (make-object menu:can-restore-menu-item% + (string-constant hide-definitions-menu-item-label) + (get-show-menu) + (λ (_1 _2) + (toggle-show/hide-definitions) + (update-shown)) + #\d + (string-constant definitions-menu-item-help-string))) + (set! interactions-item + (make-object menu:can-restore-menu-item% + (string-constant show-interactions-menu-item-label) + (get-show-menu) + (λ (_1 _2) + (toggle-show/hide-interactions) + (update-shown)) + #\e + (string-constant interactions-menu-item-help-string))) + + (new menu:can-restore-menu-item% + (shortcut #\u) + (label + (if (delegated-text-shown?) + (string-constant hide-overview) + (string-constant show-overview))) + (parent (get-show-menu)) + (callback + (λ (menu evt) + (if (delegated-text-shown?) + (begin + (send menu set-label (string-constant show-overview)) + (preferences:set 'framework:show-delegate? #f) + (hide-delegated-text)) + (begin + (send menu set-label (string-constant hide-overview)) + (preferences:set 'framework:show-delegate? #t) + (show-delegated-text)))))) + + (set! module-browser-menu-item + (new menu:can-restore-menu-item% + (label (if module-browser-shown? + (string-constant hide-module-browser) + (string-constant show-module-browser))) + (parent (get-show-menu)) + (callback + (λ (menu evt) + (if module-browser-shown? + (hide-module-browser) + (show-module-browser)))))) + + (set! toolbar-menu (new menu% + [parent show-menu] + [label (string-constant toolbar)])) + (set! toolbar-left-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-left)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-left))] + [checked #f])) + (set! toolbar-top-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-top)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-top))] + [checked #f])) + (set! toolbar-right-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-right)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-right))] + [checked #f])) + (set! toolbar-hidden-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-hidden)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-hidden))] + [checked #f]))) + + + ; + ; + ; + ; ; ; ; + ; ; ; ; + ; ; ; ; + ; ; ;; ;; ;;; ;; ; ; ; ; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;;; ; ; + ; ;; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;; ;;;;;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; + ; ; ; ; ;;; ;; ; ;; ; ; ;;;; ; ;; ; ;;; ; ; ;;; ;;;; ; + ; + ; + ; + + + (field [module-browser-shown? #f] + [module-browser-parent-panel #f] + [module-browser-panel #f] + [module-browser-ec #f] + [module-browser-button #f] + [module-browser-lib-path-check-box #f] + [module-browser-planet-path-check-box #f] + [module-browser-name-length-choice #f] + [module-browser-pb #f] + [module-browser-menu-item 'module-browser-menu-item-unset]) + + (inherit open-status-line close-status-line update-status-line) + + (define/private (show-module-browser) + (when module-browser-panel + (when (can-browse-language?) + (set! module-browser-shown? #t) + (send module-browser-menu-item set-label (string-constant hide-module-browser)) + (update-module-browser-pane)))) + + (define/private (hide-module-browser) + (when module-browser-panel + (set! module-browser-shown? #f) + (send module-browser-menu-item set-label (string-constant show-module-browser)) + (close-status-line 'plt:module-browser:mouse-over) + (send module-browser-parent-panel change-children + (λ (l) + (remq module-browser-panel l))))) + + (define/private (can-browse-language?) + (let* ([lang/config (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))] + [lang (drscheme:language-configuration:language-settings-language lang/config)] + [strs (send lang get-language-position)] + [can-browse? + (or (regexp-match #rx"Module" (last strs)) + (ormap (λ (x) (regexp-match #rx"PLT" x)) + strs))]) + (unless can-browse? + (message-box (string-constant drscheme) + (string-constant module-browser-only-in-plt-and-module-langs))) + can-browse?)) + + (define/private (update-module-browser-pane) + (open-status-line 'plt:module-browser:mouse-over) + (send module-browser-panel begin-container-sequence) + (unless module-browser-ec + (set! module-browser-pb + (drscheme:module-overview:make-module-overview-pasteboard + #t + (λ (x) (mouse-currently-over x)))) + (set! module-browser-ec (make-object editor-canvas% + module-browser-panel + module-browser-pb)) + + (let* ([show-callback + (λ (cb key) + (if (send cb get-value) + (send module-browser-pb show-visible-paths key) + (send module-browser-pb remove-visible-paths key)) + (preferences:set 'drscheme:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))] + [mk-checkbox + (λ (key label) + (new check-box% + (parent module-browser-panel) + (label label) + (value (not (memq key (preferences:get 'drscheme:module-browser:hide-paths)))) + (callback + (λ (cb _) + (show-callback cb key)))))]) + (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths)) + (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths))) + + (set! module-browser-name-length-choice + (new choice% + (parent module-browser-panel) + (label (string-constant module-browser-name-length)) + (choices (list (string-constant module-browser-name-short) + (string-constant module-browser-name-medium) + (string-constant module-browser-name-long))) + (selection (preferences:get 'drscheme:module-browser:name-length)) + (callback + (λ (x y) + (let ([selection (send module-browser-name-length-choice get-selection)]) + (preferences:set 'drscheme:module-browser:name-length selection) + (update-module-browser-name-length selection)))))) + (update-module-browser-name-length + (preferences:get 'drscheme:module-browser:name-length)) + + (set! module-browser-button + (new button% + (parent module-browser-panel) + (label refresh) + (callback (λ (x y) (update-module-browser-pane))) + (stretchable-width #t)))) + + (let ([p (preferences:get 'drscheme:module-browser-size-percentage)]) + (send module-browser-parent-panel change-children + (λ (l) + (cons module-browser-panel + (remq module-browser-panel l)))) + (with-handlers ([exn:fail? void]) + (send module-browser-parent-panel set-percentages (list p (- 1 p)))) + (send module-browser-parent-panel end-container-sequence) + (calculate-module-browser))) + + (define/private (update-module-browser-name-length i) + (send module-browser-pb set-name-length + (case i + [(0) 'short] + [(1) 'medium] + [(2) 'long]))) + + (define/private (mouse-currently-over snips) + (if (null? snips) + (update-status-line 'plt:module-browser:mouse-over #f) + (let* ([snip (car snips)] + [lines (send snip get-lines)] + [name (or (send snip get-filename) + (send snip get-word))] + [str (if lines + (format (string-constant module-browser-filename-format) name lines) + name)]) + (update-status-line 'plt:module-browser:mouse-over str)))) + + (define/private (calculate-module-browser) + (let ([mod-tab current-tab]) + (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)]) + (open-status-line 'plt:module-browser) + (update-status-line 'plt:module-browser status-compiling-definitions) + (send module-browser-button enable #f) + (send module-browser-lib-path-check-box enable #f) + (send module-browser-planet-path-check-box enable #f) + (send module-browser-name-length-choice enable #f) + (disable-evaluation-in-tab current-tab) + (drscheme:module-overview:fill-pasteboard + module-browser-pb + (drscheme:language:make-text/pos + definitions-text + 0 + (send definitions-text last-position)) + (λ (str) (update-status-line + 'plt:module-browser + (format module-browser-progress-constant str))) + (λ (user-thread user-custodian) + (send mod-tab set-breakables user-thread user-custodian))) + (send mod-tab set-breakables old-break-thread old-custodian) + (send mod-tab enable-evaluation) + (send module-browser-button enable #t) + (send module-browser-lib-path-check-box enable #t) + (send module-browser-planet-path-check-box enable #t) + (send module-browser-name-length-choice enable #t) + (close-status-line 'plt:module-browser)))) + + ;; set-directory : text -> void + ;; sets the current-directory and current-load-relative-directory + ;; based on the file saved in the definitions-text + (define/private (set-directory definitions-text) + (let* ([tmp-b (box #f)] + [fn (send definitions-text get-filename tmp-b)]) + (unless (unbox tmp-b) + (when fn + (let-values ([(base name dir?) (split-path fn)]) + (current-directory base) + (current-load-relative-directory base)))))) + + + ; + ; + ; + ; + ; + ; + ; ; ;; ;; ;;; ; ;; ; ; ;;; + ; ;; ;; ; ; ; ;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ;;;;;; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ;; ; + ; ; ; ; ;;;; ; ; ;; ; ;;; + ; + ; + ; + + (define execute-menu-item #f) + (define file-menu:print-transcript-item #f) + (define file-menu:create-new-tab-item #f) + + (define/override (file-menu:between-new-and-open file-menu) + (set! file-menu:create-new-tab-item + (new menu:can-restore-menu-item% + (label (string-constant new-tab)) + (shortcut #\=) + (parent file-menu) + (callback + (λ (x y) + (create-new-tab)))))) + [define/override file-menu:between-open-and-revert + (lambda (file-menu) + (super file-menu:between-open-and-revert file-menu) + (make-object separator-menu-item% file-menu))] + (define close-tab-menu-item #f) + (define/override (file-menu:between-close-and-quit file-menu) + (set! close-tab-menu-item + (new (get-menu-item%) + (label (string-constant close-tab)) + (demand-callback + (λ (item) + (send item enable (1 . < . (send tabs-panel get-number))))) + (parent file-menu) + (callback + (λ (x y) + (close-current-tab))))) + (super file-menu:between-close-and-quit file-menu)) + + (define/override (file-menu:save-string) (string-constant save-definitions)) + (define/override (file-menu:save-as-string) (string-constant save-definitions-as)) + (define/override (file-menu:between-save-as-and-print file-menu) + (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) + (make-object menu:can-restore-menu-item% + (string-constant save-definitions-as-text) + sub-menu + (λ (_1 _2) + (let ([filename (send definitions-text put-file #f #f)]) + (when filename + (send definitions-text save-file/gui-error filename 'text))))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions) + sub-menu + (λ (_1 _2) + (send interactions-text save-file/gui-error))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions-as) + sub-menu + (λ (_1 _2) + (let ([filename (send interactions-text put-file #f #f)]) + (when filename + (send interactions-text save-file/gui-error filename 'standard))))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions-as-text) + sub-menu + (λ (_1 _2) + (let ([filename (send interactions-text put-file #f #f)]) + (when filename + (send interactions-text save-file/gui-error filename 'text))))) + (make-object separator-menu-item% file-menu) + (set! logging-menu-item + (make-object menu:can-restore-menu-item% + (string-constant log-definitions-and-interactions) + file-menu + (λ (x y) + (if logging + (stop-logging) + (start-logging))))) + (make-object separator-menu-item% file-menu) + (super file-menu:between-save-as-and-print file-menu))) + + [define/override file-menu:print-string (λ () (string-constant print-definitions))] + (define/override (file-menu:between-print-and-close file-menu) + (set! file-menu:print-transcript-item + (make-object menu:can-restore-menu-item% + (string-constant print-interactions) + file-menu + (λ (_1 _2) + (send interactions-text print + #t + #t + (preferences:get 'framework:print-output-mode))))) + (super file-menu:between-print-and-close file-menu)) + + (define/override (edit-menu:between-find-and-preferences edit-menu) + (new menu-item% + [label (string-constant complete-word)] + [shortcut #\/] + [parent edit-menu] + [demand-callback + (λ (mi) + (send mi enable + (let ([ed (get-edit-target-object)]) + (and ed + (is-a? ed text:autocomplete<%>)))))] + [callback (λ (x y) + (send (get-edit-target-object) auto-complete))]) + (super edit-menu:between-find-and-preferences edit-menu) + (add-modes-submenu edit-menu)) + + ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) + (define capability-menu-items (make-hasheq)) + (define/public (register-capability-menu-item key menu) + (let ([items (send menu get-items)]) + (when (null? items) + (error 'register-capability-menu-item "menu ~e has no items" menu)) + (let* ([menu-item (last items)] + [this-one (list menu-item (- (length items) 1) key)] + [old-ones (hash-ref capability-menu-items menu (λ () '()))]) + (hash-set! capability-menu-items menu (cons this-one old-ones))))) + + (define/private (update-items/capability menu) + (let ([new-items (get-items/capability menu)]) + (for-each (λ (i) (send i delete)) (send menu get-items)) + (for-each (λ (i) (send i restore)) new-items))) + (define/private (get-items/capability menu) + (let loop ([capability-items + (reverse + (hash-ref capability-menu-items menu (λ () '())))] + [all-items (send menu get-items)] + [i 0]) + (cond + [(null? capability-items) all-items] + [else + (let* ([cap-item-list (car capability-items)] + [cap-item (list-ref cap-item-list 0)] + [cap-num (list-ref cap-item-list 1)] + [cap-key (list-ref cap-item-list 2)]) + (cond + [(= cap-num i) + (let ([is-on? (get-current-capability-value cap-key)]) + (cond + [is-on? + (cond + [(null? all-items) + (cons cap-item (loop (cdr capability-items) null (+ i 1)))] + [(eq? (car all-items) cap-item) + (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))] + [else + (cons cap-item (loop (cdr capability-items) all-items (+ i 1)))])] + [else + (cond + [(null? all-items) + (loop (cdr capability-items) null (+ i 1))] + [(eq? (car all-items) cap-item) + (loop (cdr capability-items) (cdr all-items) (+ i 1))] + [else + (loop (cdr capability-items) all-items (+ i 1))])]))] + [else (cons (car all-items) + (loop capability-items + (cdr all-items) + (+ i 1)))]))]))) + + (define/private (get-current-capability-value key) + (let* ([language-settings (send (get-definitions-text) get-next-settings)] + [new-language (drscheme:language-configuration:language-settings-language language-settings)]) + (send new-language capability-value key))) + + (define language-menu 'uninited-language-menu) + (define scheme-menu 'scheme-menu-not-yet-init) + (define insert-menu 'insert-menu-not-yet-init) + (define/public (get-insert-menu) insert-menu) + (define/public (get-special-menu) + (define context (continuation-mark-set->context (current-continuation-marks))) + (fprintf (current-error-port) + "called get-special-menu: ~a\n" + (if (and (pair? context) + (pair? (cdr context))) + (format "~s ~s" (car (cadr context)) (cdr (cadr context))) + "<>")) + insert-menu) + + (define/public (choose-language-callback) + (let ([new-settings (drscheme:language-configuration:language-dialog + #f + (send definitions-text get-next-settings) + this)]) + (when new-settings + (send definitions-text set-next-settings new-settings)))) + + ;; must be called from on-demand (on each menu click), or the state won't be handled properly + (define/private (update-teachpack-menu) + (for-each (λ (item) (send item delete)) teachpack-items) + (let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)]) + (cond + [tp-callbacks + (let* ([language (drscheme:language-configuration:language-settings-language + (send (get-definitions-text) get-next-settings))] + [settings (drscheme:language-configuration:language-settings-settings + (send (get-definitions-text) get-next-settings))] + [tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)] + [update-settings + (λ (settings) + (send (get-definitions-text) set-next-settings + (drscheme:language-configuration:make-language-settings language settings)) + (send (get-definitions-text) teachpack-changed))]) + (set! teachpack-items + (list* + (make-object separator-menu-item% language-menu) + (new menu:can-restore-menu-item% + [label (string-constant add-teachpack-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))]) + (let ([mi (new menu:can-restore-menu-item% + [label (string-constant clear-all-teachpacks-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])]) + + (send mi enable (not (null? tp-names))) + mi) + (map (λ (name) + (new menu:can-restore-menu-item% + [label (gui-utils:format-literal-label (string-constant clear-teachpack) name)] + [parent language-menu] + [callback + (λ (item evt) + (update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) + tp-names))))] + [else + (set! teachpack-items + (list + (new menu:can-restore-menu-item% + [label (string-constant add-teachpack-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (message-box (string-constant drscheme) + (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) + (apply + string-append + (reverse + (filter + values + (map (λ (l) + (and + (send l capability-value 'drscheme:teachpack-menu-items) + (format "\n ~a" (send l get-language-name)))) + (drscheme:language-configuration:get-languages)))))) + this))])))]))) + + (define/private (initialize-menus) + (let* ([mb (get-menu-bar)] + [language-menu-on-demand (λ (menu-item) (update-teachpack-menu))] + [_ (set! language-menu (make-object (get-menu%) + (string-constant language-menu-name) + mb + #f + language-menu-on-demand))] + [_ (set! scheme-menu (new (get-menu%) + [label (drscheme:language:get-capability-default + 'drscheme:language-menu-title)] + [parent mb]))] + [send-method + (λ (method) + (λ (_1 _2) + (let ([text (get-focus-object)]) + (when (is-a? text scheme:text<%>) + (method text)))))] + [show/hide-capability-menus + (λ () + (for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))]) + + (make-object menu:can-restore-menu-item% + (string-constant choose-language-menu-item-label) + language-menu + (λ (_1 _2) (choose-language-callback)) + #\l) + + (set! execute-menu-item + (make-object menu:can-restore-menu-item% + (string-constant execute-menu-item-label) + scheme-menu + (λ (_1 _2) (execute-callback)) + #\t + (string-constant execute-menu-item-help-string))) + (make-object menu:can-restore-menu-item% + (string-constant break-menu-item-label) + scheme-menu + (λ (_1 _2) (send current-tab break-callback)) + #\b + (string-constant break-menu-item-help-string)) + (make-object menu:can-restore-menu-item% + (string-constant kill-menu-item-label) + scheme-menu + (λ (_1 _2) (send interactions-text kill-evaluation)) + #\k + (string-constant kill-menu-item-help-string)) + (when (custodian-memory-accounting-available?) + (new menu-item% + [label (string-constant limit-memory-menu-item-label)] + [parent scheme-menu] + [callback + (λ (item b) + (let ([num (get-mbytes this + (let ([limit (send interactions-text get-custodian-limit)]) + (and limit + (floor (/ limit 1024 1024)))))]) + (when num + (cond + [(eq? num #t) + (preferences:set 'drscheme:limit-memory #f) + (send interactions-text set-custodian-limit #f)] + [else + (preferences:set 'drscheme:limit-memory + (* 1024 1024 num)) + (send interactions-text set-custodian-limit + (* 1024 1024 num))]))))])) + (new menu:can-restore-menu-item% + (label (string-constant clear-error-highlight-menu-item-label)) + (parent scheme-menu) + (callback + (λ (_1 _2) + (let ([ints (send (get-current-tab) get-ints)]) + (send ints reset-error-ranges)))) + (help-string (string-constant clear-error-highlight-item-help-string)) + (demand-callback + (λ (item) + (let ([ints (send (get-current-tab) get-ints)]) + (send item enable (send ints get-error-ranges)))))) + (make-object separator-menu-item% scheme-menu) + (make-object menu:can-restore-menu-item% + (string-constant create-executable-menu-item-label) + scheme-menu + (λ (x y) (create-executable this))) + (make-object menu:can-restore-menu-item% + (string-constant module-browser...) + scheme-menu + (λ (x y) (drscheme:module-overview:module-overview this))) + (make-object separator-menu-item% scheme-menu) + (make-object menu:can-restore-menu-item% + (string-constant reindent-menu-item-label) + scheme-menu + (send-method (λ (x) (send x tabify-selection)))) + (make-object menu:can-restore-menu-item% + (string-constant reindent-all-menu-item-label) + scheme-menu + (send-method (λ (x) (send x tabify-all))) + #\i) + (make-object menu:can-restore-menu-item% + (string-constant box-comment-out-menu-item-label) + scheme-menu + (send-method (λ (x) (send x box-comment-out-selection)))) + (make-object menu:can-restore-menu-item% + (string-constant semicolon-comment-out-menu-item-label) + scheme-menu + (send-method (λ (x) (send x comment-out-selection)))) + (make-object menu:can-restore-menu-item% + (string-constant uncomment-menu-item-label) + scheme-menu + (λ (x y) + (let ([text (get-focus-object)]) + (when (is-a? text text%) + (let ([admin (send text get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (let ([es (send admin get-snip)]) + (cond + [(is-a? es comment-box:snip%) + (let ([es-admin (send es get-admin)]) + (when es-admin + (let ([ed (send es-admin get-editor)]) + (when (is-a? ed scheme:text<%>) + (send ed uncomment-box/selection)))))] + [else (send text uncomment-selection)]))] + [else (send text uncomment-selection)])))))) + + (set! insert-menu + (new (get-menu%) + [label (string-constant insert-menu)] + [parent mb] + [demand-callback + (λ (insert-menu) + ;; just here for convience -- it actually works on all menus, not just the special menu + (show/hide-capability-menus))])) + + (let ([has-editor-on-demand + (λ (menu-item) + (let ([edit (get-edit-target-object)]) + (send menu-item enable (and edit (is-a? edit editor<%>)))))] + [callback + (λ (menu evt) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (let ([number (get-fraction-from-user this)]) + (when number + (send edit insert + (number-snip:make-fraction-snip number #f))))) + #t))] + [insert-lambda + (λ () + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (send edit insert "\u03BB"))) + #t)] + [insert-large-semicolon-letters + (λ () + (let ([edit (get-edit-target-object)]) + (when edit + (let ([language-settings (send definitions-text get-next-settings)]) + (let-values ([(comment-prefix comment-character) + (if language-settings + (send (drscheme:language-configuration:language-settings-language + language-settings) + get-comment-character) + (values ";" #\;))]) + (insert-large-letters comment-prefix comment-character edit this))))))] + [c% (get-menu-item%)]) + + (frame:add-snip-menu-items + insert-menu + c% + (λ (item) + (let ([label (send item get-label)]) + (cond + [(equal? label (string-constant insert-comment-box-menu-item-label)) + (register-capability-menu-item 'drscheme:special:insert-comment-box insert-menu)] + [(equal? label (string-constant insert-image-item)) + (register-capability-menu-item 'drscheme:special:insert-image insert-menu)])))) + + (make-object c% (string-constant insert-fraction-menu-item-label) + insert-menu callback + #f #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-fraction insert-menu) + + (make-object c% (string-constant insert-large-letters...) + insert-menu + (λ (x y) (insert-large-semicolon-letters)) + #f #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-large-letters insert-menu) + + (make-object c% (string-constant insert-lambda) + insert-menu + (λ (x y) (insert-lambda)) + #\\ + #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu)) + + (make-object separator-menu-item% (get-show-menu)) + + (new menu:can-restore-menu-item% + (shortcut (if (eq? (system-type) 'macosx) #\r #\m)) + (label (string-constant split-menu-item-label)) + (parent (get-show-menu)) + (shortcut-prefix (if (eq? (system-type) 'macosx) + (cons 'shift (get-default-shortcut-prefix)) + (get-default-shortcut-prefix))) + (callback (λ (x y) (split))) + (demand-callback (λ (item) (split-demand item)))) + (new menu:can-restore-menu-item% + (shortcut #\r) + (label (string-constant collapse-menu-item-label)) + (parent (get-show-menu)) + (callback (λ (x y) (collapse))) + (demand-callback (λ (item) (collapse-demand item)))) + + (frame:reorder-menus this))) + + ; + ; + ; + ; + ; ++-@@- -+@+- +++: :++ + ; +@@-+@ -@-:-@--@- -@ + ; :@: @: @+ ++ @::@::@ + ; :@ @: @@@@@@@ +--@--* + ; :@ @: @- -@+*+@: + ; -@: :@- +@:::+@ :@@:@@ + ; @@@ +@@: +@@@+: ++ ++ + ; + ; + ; + + (define definitions-text (new (drscheme:get/extend:get-definitions-text))) + + ;; tabs : (listof tab) + (define tabs (list (new (drscheme:get/extend:get-tab) + (defs definitions-text) + (frame this) + (i 0) + (defs-shown? #t) + (ints-shown? #t)))) + (define/public-final (get-tabs) tabs) + + ;; current-tab : tab + ;; corresponds to the tabs-panel's active button. + (define current-tab (car tabs)) + + (define interactions-text (new (drscheme:get/extend:get-interactions-text) + (context (car tabs)))) + (send (car tabs) set-ints interactions-text) + + (init-definitions-text (car tabs)) + + (super-new + (filename filename) + (style '(toolbar-button)) + (width (preferences:get 'drscheme:unit-window-width)) + (height (preferences:get 'drscheme:unit-window-height))) + + (initialize-menus) + + + ; + ; + ; + ; ; ; + ; ; ; + ; ; ; ; + ; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;; + ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; + ; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;; + ; ; ; + ; ; ; + ; ; ; + + + (define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)])) + + ;; most contain only top-panel (or nothing) + (define top-outer-panel (new horizontal-panel% + [parent toolbar/rest-panel] + [alignment '(right top)] + [stretchable-height #f])) + + [define top-panel (make-object horizontal-panel% top-outer-panel)] + [define name-panel (new horizontal-panel% + (parent top-panel) + (alignment '(left center)) + (stretchable-width #f) + (stretchable-height #f))] + (define panel-with-tabs (new vertical-panel% + (parent (get-definitions/interactions-panel-parent)))) + (define tabs-panel (new tab-panel% + (font small-control-font) + (parent panel-with-tabs) + (stretchable-height #f) + (style '(deleted no-border)) + (choices '("first name")) + (callback (λ (x y) + (let ([sel (send tabs-panel get-selection)]) + (when sel + (change-to-nth-tab sel))))))) + [define resizable-panel (new (if (preferences:get 'drscheme:defs/ints-horizontal) + horizontal-dragable/def-int% + vertical-dragable/def-int%) + (unit-frame this) + (parent panel-with-tabs))] + + [define definitions-canvas #f] + (initialize-definitions-canvas) + [define definitions-canvases (list definitions-canvas)] + [define interactions-canvas (new (drscheme:get/extend:get-interactions-canvas) + (parent resizable-panel) + (editor interactions-text))] + [define interactions-canvases (list interactions-canvas)] + + + (define/public (get-definitions-canvases) + ;; before definition, just return null + (if (pair? definitions-canvases) + definitions-canvases + null)) + (define/public (get-interactions-canvases) + ;; before definition, just return null + (if (pair? interactions-canvases) + interactions-canvases + null)) + + (public get-definitions-canvas get-interactions-canvas) + [define get-definitions-canvas (λ () definitions-canvas)] + [define get-interactions-canvas (λ () interactions-canvas)] + + (set! save-button + (new switchable-button% + [parent top-panel] + [callback (λ (x) (when definitions-text + (save) + (send definitions-canvas focus)))] + [bitmap save-bitmap] + [label (string-constant save-button-label)])) + (register-toolbar-button save-button) + + (set! name-message (new drs-name-message% [parent name-panel])) + (send name-message stretchable-width #t) + (send name-message set-allow-shrinking 200) + [define teachpack-items null] + [define break-button (void)] + [define execute-button (void)] + [define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])] + (define/public (get-execute-button) execute-button) + (define/public (get-break-button) break-button) + (define/public (get-button-panel) button-panel) + + (inherit get-info-panel) + (define running-canvas + (new running-canvas% [parent (get-info-panel)])) + + + [define func-defs-canvas (new func-defs-canvas% + (parent name-panel) + (frame this))] + + (set! execute-button + (new switchable-button% + [parent button-panel] + [callback (λ (x) (execute-callback))] + [bitmap execute-bitmap] + [label (string-constant execute-button-label)])) + (register-toolbar-button execute-button) + + (set! break-button + (new switchable-button% + [parent button-panel] + [callback (λ (x) (send current-tab break-callback))] + [bitmap break-bitmap] + [label (string-constant break-button-label)])) + (register-toolbar-button break-button) + + (send button-panel stretchable-height #f) + (send button-panel stretchable-width #f) + + (send top-panel change-children + (λ (l) + (list name-panel save-button + (make-object vertical-panel% top-panel) ;; spacer + button-panel))) + + (send top-panel stretchable-height #f) + (inherit get-label) + (let ([m (send definitions-canvas get-editor)]) + (set-save-init-shown? + (and m (send m is-modified?)))) + + (define language-message + (let* ([info-panel (get-info-panel)] + [p (new vertical-panel% + [parent info-panel] + [alignment '(left center)])] + [language-message (new language-label-message% [parent p] [frame this])]) + (send info-panel change-children + (λ (l) + (list* p + (remq* (list p) + l)))) + language-message)) + + (update-save-message) + (update-save-button) + (language-changed) + + (cond + [filename + (set! definitions-shown? #t) + (set! interactions-shown? #f)] + [else + (set! definitions-shown? #t) + (set! interactions-shown? #t)]) + + (update-shown) + + (when (= 2 (length (send resizable-panel get-children))) + (send resizable-panel set-percentages + (let ([p (preferences:get 'drscheme:unit-window-size-percentage)]) + (list p (- 1 p))))) + + (set-label-prefix (string-constant drscheme)) + (set! newest-frame this) + (send definitions-canvas focus))) + + (define running-bitmap (include-bitmap (lib "b-run.png" "icons"))) + (define waiting-bitmap (include-bitmap (lib "b-wait.png" "icons"))) + (define waiting2-bitmap (include-bitmap (lib "b-wait2.png" "icons"))) + (define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap)) + (define running-canvas% + (class canvas% + (inherit get-dc refresh get-client-size) + (define/public (set-running r?) + (unless (eq? r? is-running?) + (set! is-running? r?) + (refresh))) + (define is-running? #f) + (define toggle? #t) + (define timer #f) + (define inside? #f) + + (define/override (on-event evt) + (let-values ([(w h) (get-client-size)]) + (let ([new-inside? + (and (<= 0 (send evt get-x) w) + (<= 0 (send evt get-y) h))] + [old-inside? inside?]) + (set! inside? new-inside?) + (cond + [(and new-inside? (not old-inside?)) + (unless is-running? + (set! timer + (new timer% + [notify-callback + (λ () + (set! toggle? (not toggle?)) + (refresh))] + [interval 200])))] + [(and (not new-inside?) old-inside? timer) + (send timer stop) + (set! timer #f)])))) + + (define/override (on-paint) + (let ([dc (get-dc)] + [bm + (if is-running? + running-bitmap + (if toggle? + waiting-bitmap + waiting2-bitmap))]) + (let-values ([(cw ch) (get-client-size)]) + (send dc draw-bitmap bm + (- (/ cw 2) (/ (send bm get-width) 2)) + (- (/ ch 2) (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (send bm get-loaded-mask))))) + + (super-new [stretchable-width #f] + [stretchable-height #f] + [style '(transparent)]) + (inherit min-width min-height) + (min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps))) + (min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps))))) + + ;; get-mbytes : top-level-window -> (union #f ;; cancel + ;; integer[>=100] ;; a limit + ;; #t) ;; no limit + (define (get-mbytes parent current-limit) + (define d (new dialog% + [label (string-constant drscheme)] + [parent parent])) + (define msg1 (new message% + [parent d] + [label (string-constant limit-memory-msg-1)])) + (define msg1.5 (new message% + [parent d] + [label (string-constant limit-memory-msg-2)])) + + (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) + (define rb (new radio-box% + [label #f] + [choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))] + [callback (λ (a b) (grayizie))] + [parent outer-hp])) + + (define (grayizie) + (case (send rb get-selection) + [(0) + (send tb enable #f) + (send msg2 enable #f) + (background gray-foreground-sd)] + [(1) + (send tb enable #t) + (send msg2 enable #t) + (background black-foreground-sd) + (let ([e (send tb get-editor)]) + (send e set-position 0 (send e last-position))) + (send tb focus)]) + (update-ok-button-state)) + + (define hp (new horizontal-panel% + [parent outer-hp] + [stretchable-height #f] + [stretchable-width #f])) + + (define tb + (new text-field% + [label #f] + [parent hp] + [init-value (if current-limit + (format "~a" current-limit) + "128")] + [stretchable-width #f] + [min-width 100] + [callback + (λ (tf e) + (let ([ed (send tf get-editor)]) + (cond + [(is-valid-number? ed) + (background clear-sd)] + [else + (background yellow-sd)])) + (update-ok-button-state))])) + + (define (update-ok-button-state) + (case (send rb get-selection) + [(0) (send ok-button enable #t)] + [(1) (send ok-button enable (is-valid-number? (send tb get-editor)))])) + + (define msg2 (new message% [parent hp] [label (string-constant limit-memory-megabytes)])) + (define bp (new horizontal-panel% [parent d])) + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons + bp + (λ (a b) + (case (send rb get-selection) + [(0) (set! result #t)] + [(1) (set! result (string->number (send (send tb get-editor) get-text)))]) + (send d show #f)) + (λ (a b) (send d show #f)))) + + (define result #f) + + (define clear-sd (make-object style-delta%)) + (define yellow-sd (make-object style-delta%)) + + (define black-foreground-sd (make-object style-delta%)) + (define gray-foreground-sd (make-object style-delta%)) + + (define (is-valid-number? txt) + (let* ([n (string->number (send txt get-text))]) + (and n + (integer? n) + (100 . <= . n)))) + + (define (background sd) + (let ([txt (send tb get-editor)]) + (send txt change-style sd 0 (send txt last-position)))) + + (send clear-sd set-delta-background "white") + (send yellow-sd set-delta-background "yellow") + (send black-foreground-sd set-delta-foreground "black") + (send gray-foreground-sd set-delta-foreground "gray") + (send d set-alignment 'left 'center) + (send bp set-alignment 'right 'center) + (when current-limit + (send rb set-selection 1)) + (update-ok-button-state) + (grayizie) + (send tb focus) + (let ([e (send tb get-editor)]) + (send e set-position 0 (send e last-position))) + (send d show #t) + result) + + + + (define (limit-length l n) + (let loop ([l l] + [n n]) + (cond + [(or (null? l) (zero? n)) null] + [else (cons (car l) (loop (cdr l) (- n 1)))]))) + (define (remove-duplicate-languages l) + (reverse + (let loop ([l (reverse l)]) + (cond + [(null? l) l] + [else + (if (member (car (car l)) (map car (cdr l))) + (loop (cdr l)) + (cons (car l) (loop (cdr l))))])))) + + (define language-label-message% + (class name-message% + (init-field frame) + (inherit refresh) + + (inherit set-message) + (define yellow? #f) + (define/override (get-background-color) (and yellow? "yellow")) + (define/public (set-yellow y?) + (set! yellow? y?) + (refresh)) + (define/public (set-yellow/lang y? lang) + (set-message #f lang) + (set-yellow y?)) + + (define/override (fill-popup menu reset) + (let ([added-one? #f]) + (send (new menu-item% + [label (string-constant recent-languages)] + [callback void] + [parent menu]) + enable #f) + (for-each + (λ (name/settings) + (let* ([name (car name/settings)] + [marshalled-settings (cdr name/settings)] + [lang (ormap + (λ (l) (and (equal? (send l get-language-name) name) l)) + (drscheme:language-configuration:get-languages))]) + (when lang + ;; this test can fail when a language has been added wrongly via the tools interface + ;; just ignore that menu item, in that case. + (let ([settings (or (send lang unmarshall-settings marshalled-settings) + (send lang default-settings))]) + (when lang + (set! added-one? #t) + (new menu-item% + [parent menu] + [label (send lang get-language-name)] + [callback + (λ (x y) + (send (send frame get-definitions-text) + set-next-settings + (drscheme:language-configuration:make-language-settings + lang + settings)))])))))) + (preferences:get 'drscheme:recent-language-names)) + (unless added-one? + (send (new menu-item% + [label (string-append + " << " + (string-constant no-recently-chosen-languages) + " >>")] + [parent menu] + [callback void]) + enable #f)) + (new separator-menu-item% [parent menu])) + (new menu-item% + [label (string-constant choose-language-menu-item-label)] + [parent menu] + [callback + (λ (x y) + (send frame choose-language-callback))])) + + (super-new [label ""] + [font small-control-font] + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]) + + (inherit set-allow-shrinking) + (set-allow-shrinking 100))) + + (define -frame% (frame-mixin super-frame%)) + + (define module-browser-dragable-panel% + (class panel:horizontal-dragable% + (inherit get-percentages) + (define/augment (after-percentage-change) + (let ([percentages (get-percentages)]) + (when (and (pair? percentages) + (pair? (cdr percentages)) + (null? (cddr percentages))) + (preferences:set 'drscheme:module-browser-size-percentage + (car percentages)))) + (inner (void) after-percentage-change)) + (super-new))) + + (define drs-name-message% + (class name-message% + (define/override (on-choose-directory dir) + (let ([file (finder:get-file dir + (string-constant select-file) + #f + "" + (send this get-top-level-window))]) + (when file + (handler:edit-file file)))) + (super-new + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; lambda-snipclass is for backwards compatibility + ;; + (define lambda-snipclass + (make-object (class snip-class% + (define/override (read p) (make-object string-snip% "λ")) + (super-new)))) + (send lambda-snipclass set-version 1) + (send lambda-snipclass set-classname "drscheme:lambda-snip%") + (send (get-the-snip-class-list) add lambda-snipclass) + + (define newest-frame 'nothing-yet) + + (define open-drscheme-window + (case-lambda + [() (open-drscheme-window #f)] + [(name) + (cond + [(and newest-frame + name + (not (eq? newest-frame 'nothing-yet)) + (send newest-frame still-untouched?)) + (send newest-frame change-to-file name) + (send newest-frame show #t) + (begin0 newest-frame + (set! newest-frame #f))] + [(and name ;; only open a tab if we have a filename + (preferences:get 'drscheme:open-in-tabs)) + (let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame) + (send (group:get-the-frame-group) get-frames))]) + (cond + [(null? frs) #f] + [else (let ([fr (car frs)]) + (or (and (is-a? fr -frame<%>) + fr) + (loop (cdr frs))))]))]) + (if fr + (begin (send fr open-in-new-tab name) + (send fr show #t) + fr) + (create-new-drscheme-frame name)))] + [else + (create-new-drscheme-frame name)])])) + + (define first-frame? #t) + (define (create-new-drscheme-frame filename) + (let* ([drs-frame% (drscheme:get/extend:get-unit-frame)] + [frame (new drs-frame% (filename filename))]) + (send (send frame get-interactions-text) initialize-console) + (when first-frame? + (let ([pos (preferences:get 'drscheme:frame:initial-position)]) + (when pos + (send frame move (car pos) (cdr pos)))) + (unless (eq? (system-type) 'macosx) + ;; mac os x has a bug where maximizing can make the window too big. + (send frame maximize (preferences:get 'drscheme:unit-window-max?)))) + (send frame update-toolbar-visibility) + (send frame show #t) + (set! first-frame? #f) + frame)))) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss new file mode 100644 index 0000000000..8e51b17be7 --- /dev/null +++ b/collects/drscheme/syncheck.ss @@ -0,0 +1,2738 @@ +#lang scheme/base +#| + +Check Syntax separates two classes of identifiers, +those bound in this file and those bound by require, +and uses identifier-binding and identifier-transformer-binding +to distinguish them. + +Variables come from 'origin, 'disappeared-use, and 'disappeared-binding +syntax properties, as well as from variable references and binding (letrec-values, +let-values, define-values) in the fully expanded text. + +Variables inside #%top (not inside a module) are treated specially. +If the namespace has a binding for them, they are colored bound color. +If the namespace does not, they are colored the unbound color. + +|# + + +(require string-constants + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/switchable-button + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base)) +(provide tool@) + +(define o (current-output-port)) + +(define status-init (string-constant cs-status-init)) +(define status-coloring-program (string-constant cs-status-coloring-program)) +(define status-eval-compile-time (string-constant cs-status-eval-compile-time)) +(define status-expanding-expression (string-constant cs-status-expanding-expression)) +(define status-loading-docs-index (string-constant cs-status-loading-docs-index)) + +(define jump-to-next-bound-occurrence (string-constant cs-jump-to-next-bound-occurrence)) +(define jump-to-binding (string-constant cs-jump-to-binding)) +(define jump-to-definition (string-constant cs-jump-to-definition)) + +(define-local-member-name + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition + + syncheck:clear-highlighting + syncheck:button-callback + syncheck:add-to-cleanup-texts + ;syncheck:error-report-visible? ;; test suite uses this one. + ;syncheck:get-bindings-table ;; test suite uses this one. + syncheck:clear-error-message + + hide-error-report + get-error-report-text + get-error-report-visible? + + update-button-visibility/settings) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + ;; use this to communicate the frame being + ;; syntax checked w/out having to add new + ;; parameters to all of the functions + (define currently-processing-drscheme-frame (make-parameter #f)) + + (define (phase1) + (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin)) + (define (phase2) (void)) + + (define (printf . args) (apply fprintf o args)) + + + (define xref 'not-yet-loaded-xref) + (define (get-xref) + (cond + [(equal? xref 'failed-to-load) #f] + [else + (when (symbol? xref) + (error 'get-xref "xref has not yet been loaded")) + xref])) + (define (force-xref th) + (cond + [(equal? xref 'failed-to-load) + (void)] + [(symbol? xref) + (th) + (with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load)))) + (set! xref (load-collections-xref)))] + [else + (void)])) + + + + ;;; ;;; ;;; ;;;;; + ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; + ; ;; ; ; ; + ; ; ; ; ; + ; ; ;; ;; ; + ;;; ;;; ;;;;; + + + ;; used for quicker debugging of the preference panel + '(define test-preference-panel + (λ (name f) + (let ([frame (make-object frame% name)]) + (f frame) + (send frame show #t)))) + + (define-struct graphic (pos* locs->thunks draw-fn click-fn)) + + (define-struct arrow (start-x start-y end-x end-y) #:mutable) + (define-struct (var-arrow arrow) + (start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual?)) + (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) + + ;; color : string + ;; start, fin: number + ;; used to represent regions to highlight when passing the mouse over the syncheck window + (define-struct colored-region (color start fin)) + + ;; id : symbol -- the nominal-source-id from identifier-binding + ;; filename : path + (define-struct def-link (id filename) #:inspector (make-inspector)) + + (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)) + (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid)) + + (define templ-color (send the-color-database find-color "purple")) + (define templ-pen (send the-pen-list find-or-create-pen templ-color 1 'solid)) + (define tacked-templ-brush (send the-brush-list find-or-create-brush templ-color 'solid)) + + (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid)) + (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid)) + (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) + + (define syncheck-text<%> + (interface () + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:get-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition)) + + ;; clearing-text-mixin : (mixin text%) + ;; overrides methods that make sure the arrows go away appropriately. + ;; adds a begin/end-edit-sequence to the insertion and deletion + ;; to ensure that the on-change method isn't called until after + ;; the arrows are cleared. + (define clearing-text-mixin + (mixin ((class->interface text%)) () + + (inherit begin-edit-sequence end-edit-sequence) + (define/augment (on-delete start len) + (begin-edit-sequence) + (inner (void) on-delete start len)) + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (clean-up) + (end-edit-sequence)) + + (define/augment (on-insert start len) + (begin-edit-sequence) + (inner (void) on-insert start len)) + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (clean-up) + (end-edit-sequence)) + + (define/private (clean-up) + (let ([st (find-syncheck-text this)]) + (when (and st + (is-a? st drscheme:unit:definitions-text<%>)) + (let ([tab (send st get-tab)]) + (send tab syncheck:clear-error-message) + (send tab syncheck:clear-highlighting))))) + + (super-new))) + + (define make-syncheck-text% + (λ (super%) + (let* ([cursor-arrow (make-object cursor% 'arrow)]) + (class* super% (syncheck-text<%>) + (inherit set-cursor get-admin invalidate-bitmap-cache set-position + position-location + get-canvas last-position dc-location-to-editor-location + find-position begin-edit-sequence end-edit-sequence + highlight-range unhighlight-range) + + + + ;; arrow-vectors : + ;; (union + ;; #f + ;; (hash-table + ;; (text% + ;; . -o> . + ;; (vector (listof (union (cons (union #f sym) (menu -> void)) + ;; def-link + ;; tail-link + ;; arrow + ;; string)))))) + (define arrow-vectors #f) + + + ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] + ;; this is a private field + (define bindings-table (make-hash)) + + ;; add-to-bindings-table : text number number text number number -> boolean + ;; results indicates if the binding was added to the table. It is added, unless + ;; 1) it is already there, or + ;; 2) it is a link to itself + (define/private (add-to-bindings-table start-text start-left start-right + end-text end-left end-right) + (cond + [(and (object=? start-text end-text) + (= start-left end-left) + (= start-right end-right)) + #f] + [else + (let* ([key (list start-text start-left start-right)] + [priors (hash-ref bindings-table key (λ () '()))] + [new (list end-text end-left end-right)]) + (cond + [(member new priors) + #f] + [else + (hash-set! bindings-table key (cons new priors)) + #t]))])) + + ;; for use in the automatic test suite + (define/public (syncheck:get-bindings-table) bindings-table) + + (define/public (syncheck:sort-bindings-table) + + ;; compare-bindings : (list text number number) (list text number number) -> boolean + (define (compare-bindings l1 l2) + (let ([start-text (list-ref l1 0)] + [start-left (list-ref l1 1)] + [end-text (list-ref l2 0)] + [end-left (list-ref l2 1)]) + (let-values ([(sx sy) (find-dc-location start-text start-left)] + [(ex ey) (find-dc-location end-text end-left)]) + (cond + [(= sy ey) (< sx ex)] + [else (< sy ey)])))) + + ;; find-dc-location : text number -> (values number number) + (define (find-dc-location text pos) + (let ([bx (box 0)] + [by (box 0)]) + (send text position-location pos bx by) + (send text editor-location-to-dc-location (unbox bx) (unbox by)))) + + (hash-for-each + bindings-table + (λ (k v) + (hash-set! bindings-table k (sort v compare-bindings))))) + + (define tacked-hash-table (make-hasheq)) + (define cursor-location #f) + (define cursor-text #f) + (define cursor-eles #f) + (define/private (find-poss text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values (/ (+ xl xr) 2) + (/ (+ yl yr) 2))))) + + ;; find-char-box : text number number -> (values number number number number) + ;; returns the bounding box (left, top, right, bottom) for the text range. + ;; only works right if the text is on a single line. + (define/private (find-char-box text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values + xl + yl + xr + yr)))) + + (define/private (update-arrow-poss arrow) + (cond + [(var-arrow? arrow) (update-var-arrow-poss arrow)] + [(tail-arrow? arrow) (update-tail-arrow-poss arrow)])) + + (define/private (update-var-arrow-poss arrow) + (let-values ([(start-x start-y) (find-poss + (var-arrow-start-text arrow) + (var-arrow-start-pos-left arrow) + (var-arrow-start-pos-right arrow))] + [(end-x end-y) (find-poss + (var-arrow-end-text arrow) + (var-arrow-end-pos-left arrow) + (var-arrow-end-pos-right arrow))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + (define/private (update-tail-arrow-poss arrow) + (let-values ([(start-x start-y) (find-poss + (tail-arrow-from-text arrow) + (tail-arrow-from-pos arrow) + (+ (tail-arrow-from-pos arrow) 1))] + [(end-x end-y) (find-poss + (tail-arrow-to-text arrow) + (tail-arrow-to-pos arrow) + (+ (tail-arrow-to-pos arrow) 1))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + ;; syncheck:init-arrows : -> void + (define/public (syncheck:init-arrows) + (set! tacked-hash-table (make-hasheq)) + (set! arrow-vectors (make-hasheq)) + (set! bindings-table (make-hash)) + (let ([f (get-top-level-window)]) + (when f + (send f open-status-line 'drscheme:check-syntax:mouse-over)))) + + ;; syncheck:clear-arrows : -> void + (define/public (syncheck:clear-arrows) + (when (or arrow-vectors cursor-location cursor-text) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (set! tacked-hash-table #f) + (set! arrow-vectors #f) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (when any-tacked? + (invalidate-bitmap-cache)) + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f close-status-line 'drscheme:check-syntax:mouse-over)))))) + (define/public (syncheck:add-menu text start-pos end-pos key make-menu) + (when (and (<= 0 start-pos end-pos (last-position))) + (add-to-range/key text start-pos end-pos make-menu key #t))) + + (define/public (syncheck:add-background-color text color start fin key) + (add-to-range/key text start fin (make-colored-region color start fin) key #f)) + + ;; syncheck:add-arrow : symbol text number number text number number boolean -> void + ;; pre: start-editor, end-editor are embedded in `this' (or are `this') + (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right actual?) + (let* ([arrow (make-var-arrow #f #f #f #f + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual?)]) + (when (add-to-bindings-table + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right) + (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) + (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))) + + ;; syncheck:add-tail-arrow : text number text number -> void + (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) + (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)]) + (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f) + (add-to-range/key from-text to-pos (+ to-pos 1) tail-arrow #f #f))) + + ;; syncheck:add-jump-to-definition : text start end id filename -> void + (define/public (syncheck:add-jump-to-definition text start end id filename) + (add-to-range/key text start end (make-def-link id filename) #f #f)) + + ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void + (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) + (add-to-range/key text pos-left pos-right str #f #f)) + + ;; add-to-range/key : text number number any any boolean -> void + ;; adds `key' to the range `start' - `end' in the editor + ;; If use-key? is #t, it adds `to-add' with the key, and does not + ;; replace a value with that key already there. + ;; If use-key? is #f, it adds `to-add' without a key. + ;; pre: arrow-vectors is not #f + (define/private (add-to-range/key text start end to-add key use-key?) + (let ([arrow-vector (hash-ref + arrow-vectors + text + (λ () + (let ([new-vec + (make-vector + (add1 (send text last-position)) + null)]) + (hash-set! + arrow-vectors + text + new-vec) + new-vec)))]) + (let loop ([p start]) + (when (and (<= p end) + (< p (vector-length arrow-vector))) + ;; the last test in the above and is because some syntax objects + ;; appear to be from the original source, but can have bogus information. + + (let ([r (vector-ref arrow-vector p)]) + (cond + [use-key? + (unless (ormap (λ (x) + (and (pair? x) + (car x) + (eq? (car x) key))) + r) + (vector-set! arrow-vector p (cons (cons key to-add) r)))] + [else + (vector-set! arrow-vector p (cons to-add r))])) + (loop (add1 p)))))) + + (inherit get-top-level-window) + + (define/augment (on-change) + (inner (void) on-change) + (when arrow-vectors + (flush-arrow-coordinates-cache) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (when any-tacked? + (invalidate-bitmap-cache))))) + + ;; flush-arrow-coordinates-cache : -> void + ;; pre-condition: arrow-vector is not #f. + (define/private (flush-arrow-coordinates-cache) + (hash-for-each + arrow-vectors + (λ (text arrow-vector) + (let loop ([n (vector-length arrow-vector)]) + (unless (zero? n) + (let ([eles (vector-ref arrow-vector (- n 1))]) + (for-each (λ (ele) + (cond + [(arrow? ele) + (set-arrow-start-x! ele #f) + (set-arrow-start-y! ele #f) + (set-arrow-end-x! ele #f) + (set-arrow-end-y! ele #f)])) + eles)) + (loop (- n 1))))))) + + (define/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) + (when (and arrow-vectors (not before)) + (let ([draw-arrow2 + (λ (arrow) + (unless (arrow-start-x arrow) + (update-arrow-poss arrow)) + (let ([start-x (arrow-start-x arrow)] + [start-y (arrow-start-y arrow)] + [end-x (arrow-end-x arrow)] + [end-y (arrow-end-y arrow)]) + (unless (and (= start-x end-x) + (= start-y end-y)) + (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy) + (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow))) + (let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) + (send dc draw-text "?" + (+ end-x dx fw) + (+ end-y dy (- fh))))))))] + [old-brush (send dc get-brush)] + [old-pen (send dc get-pen)] + [old-font (send dc get-font)] + [old-text-foreground (send dc get-text-foreground)] + [old-text-mode (send dc get-text-mode)]) + (send dc set-font + (send the-font-list find-or-create-font + (send old-font get-point-size) + 'default + 'normal + 'bold)) + (send dc set-text-foreground templ-color) + (hash-for-each tacked-hash-table + (λ (arrow v) + (when v + (cond + [(var-arrow? arrow) + (if (var-arrow-actual? arrow) + (begin (send dc set-pen var-pen) + (send dc set-brush tacked-var-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush tacked-templ-brush)))] + [(tail-arrow? arrow) + (send dc set-pen tail-pen) + (send dc set-brush tacked-tail-brush)]) + (draw-arrow2 arrow)))) + (when (and cursor-location + cursor-text) + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector cursor-location)]) + (for-each (λ (ele) + (cond + [(var-arrow? ele) + (if (var-arrow-actual? ele) + (begin (send dc set-pen var-pen) + (send dc set-brush untacked-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush untacked-brush))) + (draw-arrow2 ele)] + [(tail-arrow? ele) + (send dc set-pen tail-pen) + (send dc set-brush untacked-brush) + (for-each-tail-arrows draw-arrow2 ele)])) + eles))))) + (send dc set-brush old-brush) + (send dc set-pen old-pen) + (send dc set-font old-font) + (send dc set-text-foreground old-text-foreground) + (send dc set-text-mode old-text-mode)))) + + ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void + (define/private (for-each-tail-arrows f tail-arrow) + ;; call-f-ht ensures that `f' is only called once per arrow + (define call-f-ht (make-hasheq)) + + (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text + tail-arrow-other-pos tail-arrow-other-text) + + ;; traversal-ht ensures that we don't loop in the arrow traversal. + (let ([traversal-ht (make-hasheq)]) + (let loop ([tail-arrow tail-arrow]) + (unless (hash-ref traversal-ht tail-arrow (λ () #f)) + (hash-set! traversal-ht tail-arrow #t) + (unless (hash-ref call-f-ht tail-arrow (λ () #f)) + (hash-set! call-f-ht tail-arrow #t) + (f tail-arrow)) + (let* ([next-pos (tail-arrow-pos tail-arrow)] + [next-text (tail-arrow-text tail-arrow)] + [arrow-vector (hash-ref arrow-vectors next-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector next-pos)]) + (for-each (λ (ele) + (cond + [(tail-arrow? ele) + (let ([other-pos (tail-arrow-other-pos ele)] + [other-text (tail-arrow-other-text ele)]) + (when (and (= other-pos next-pos) + (eq? other-text next-text)) + (loop ele)))])) + eles)))))))) + + (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text + tail-arrow-from-pos tail-arrow-from-text) + (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text + tail-arrow-to-pos tail-arrow-to-text)) + + ;; get-pos/text : event -> (values (union #f text%) (union number #f)) + ;; returns two #fs to indicate the event doesn't correspond to + ;; a position in an editor, or returns the innermost text + ;; and position in that text where the event is. + (define/private (get-pos/text event) + (let ([event-x (send event get-x)] + [event-y (send event get-y)] + [on-it? (box #f)]) + (let loop ([editor this]) + (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)]) + (cond + [(is-a? editor text%) + (let ([pos (send editor find-position x y #f on-it?)]) + (cond + [(not (unbox on-it?)) (values #f #f)] + [else + (let ([snip (send editor find-snip pos 'after-or-none)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values pos editor)))]))] + [(is-a? editor pasteboard%) + (let ([snip (send editor find-snip x y)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values #f #f)))] + [else (values #f #f)]))))) + + (define/override (on-event event) + (if arrow-vectors + (cond + [(send event leaving?) + (update-docs-background #f) + (when (and cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (invalidate-bitmap-cache)) + (super on-event event)] + [(or (send event moving?) + (send event entering?)) + (let-values ([(pos text) (get-pos/text event)]) + (cond + [(and pos text) + (unless (and (equal? pos cursor-location) + (eq? cursor-text text)) + (set! cursor-location pos) + (set! cursor-text text) + + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))] + [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) + + (unless (equal? cursor-eles eles) + (set! cursor-eles eles) + (update-docs-background eles) + (when eles + (update-status-line eles) + (for-each (λ (ele) + (cond + [(arrow? ele) + (update-arrow-poss ele)])) + eles) + (invalidate-bitmap-cache)))))] + [else + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (when (or cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (invalidate-bitmap-cache))])) + (super on-event event)] + [(send event button-down? 'right) + (let-values ([(pos text) (get-pos/text event)]) + (if (and pos text) + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (vector-ref arrow-vector pos)]) + (cond + [(null? vec-ents) + (super on-event event)] + [else + (let* ([menu (make-object popup-menu% #f)] + [arrows (filter arrow? vec-ents)] + [def-links (filter def-link? vec-ents)] + [var-arrows (filter var-arrow? arrows)] + [add-menus (map cdr (filter pair? vec-ents))]) + (unless (null? arrows) + (make-object menu-item% + (string-constant cs-tack/untack-arrow) + menu + (λ (item evt) (tack/untack-callback arrows)))) + (unless (null? def-links) + (let ([def-link (car def-links)]) + (make-object menu-item% + jump-to-definition + menu + (λ (item evt) + (jump-to-definition-callback def-link))))) + (unless (null? var-arrows) + (make-object menu-item% + jump-to-next-bound-occurrence + menu + (λ (item evt) (jump-to-next-callback pos text arrows))) + (make-object menu-item% + jump-to-binding + menu + (λ (item evt) (jump-to-binding-callback arrows)))) + (for-each (λ (f) (f menu)) add-menus) + (send (get-canvas) popup-menu menu + (+ 1 (inexact->exact (floor (send event get-x)))) + (+ 1 (inexact->exact (floor (send event get-y))))))])))) + (super on-event event)))] + [else (super on-event event)]) + (super on-event event))) + + (define/private (update-status-line eles) + (let ([has-txt? #f]) + (for-each (λ (ele) + (cond + [(string? ele) + (set! has-txt? #t) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line + 'drscheme:check-syntax:mouse-over + ele)))])) + eles) + (unless has-txt? + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))))) + + (define current-colored-region #f) + ;; update-docs-background : (or/c false/c (listof any)) -> void + (define/private (update-docs-background eles) + (let ([new-region (and eles (ormap (λ (x) (and (colored-region? x) x)) eles))]) + (unless (eq? current-colored-region new-region) + (when current-colored-region + (unhighlight-range (colored-region-start current-colored-region) + (colored-region-fin current-colored-region) + (send the-color-database find-color (colored-region-color current-colored-region)))) + (when new-region + (highlight-range (colored-region-start new-region) + (colored-region-fin new-region) + (send the-color-database find-color (colored-region-color new-region)))) + (set! current-colored-region new-region)))) + + ;; tack/untack-callback : (listof arrow) -> void + ;; callback for the tack/untack menu item + (define/private (tack/untack-callback arrows) + (let ([arrow-tacked? + (λ (arrow) + (hash-ref + tacked-hash-table + arrow + (λ () #f)))] + [untack-arrows? #f]) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))) + arrow)])) + arrows) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))) + arrow)])) + arrows)) + (invalidate-bitmap-cache)) + + ;; syncheck:jump-to-binding-occurrence : text -> void + ;; jumps to the next occurrence, based on the insertion point + (define/public (syncheck:jump-to-next-bound-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-next-callback pos text vec-ents)))) + + ;; syncheck:jump-to-binding-occurrence : text -> void + (define/public (syncheck:jump-to-binding-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-binding-callback vec-ents)))) + + (define/private (jump-to-binding/bound-helper text do-jump) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter var-arrow? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (do-jump pos text vec-ents)))))))) + + ;; jump-to-next-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-next-callback pos txt input-arrows) + (unless (null? input-arrows) + (let* ([arrow-key (car input-arrows)] + [orig-arrows (hash-ref bindings-table + (list (var-arrow-start-text arrow-key) + (var-arrow-start-pos-left arrow-key) + (var-arrow-start-pos-right arrow-key)) + (λ () '()))]) + (cond + [(null? orig-arrows) (void)] + [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))] + [else + (let loop ([arrows orig-arrows]) + (cond + [(null? arrows) (jump-to (car orig-arrows))] + [else (let ([arrow (car arrows)]) + (cond + [(and (object=? txt (list-ref arrow 0)) + (<= (list-ref arrow 1) pos (list-ref arrow 2))) + (jump-to (if (null? (cdr arrows)) + (car orig-arrows) + (cadr arrows)))] + [else (loop (cdr arrows))]))]))])))) + + ;; jump-to : (list text number number) -> void + (define/private (jump-to to-arrow) + (let ([end-text (list-ref to-arrow 0)] + [end-pos-left (list-ref to-arrow 1)] + [end-pos-right (list-ref to-arrow 2)]) + (send end-text set-position end-pos-left end-pos-right) + (send end-text set-caret-owner #f 'global))) + + ;; jump-to-binding-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-binding-callback arrows) + (unless (null? arrows) + (let* ([arrow (car arrows)] + [start-text (var-arrow-start-text arrow)] + [start-pos-left (var-arrow-start-pos-left arrow)] + [start-pos-right (var-arrow-start-pos-right arrow)]) + (send start-text set-position start-pos-left start-pos-right) + (send start-text set-caret-owner #f 'global)))) + + ;; syncheck:jump-to-definition : text -> void + (define/public (syncheck:jump-to-definition text) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter def-link? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (jump-to-definition-callback (car vec-ents))))))))) + + (define/private (jump-to-definition-callback def-link) + (let* ([filename (def-link-filename def-link)] + [id-from-def (def-link-id def-link)] + [frame (fw:handler:edit-file filename)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback id-from-def)))) + + (define/augment (after-set-next-settings settings) + (let ([frame (get-top-level-window)]) + (when frame + (send frame update-button-visibility/settings settings))) + (inner (void) after-set-next-settings settings)) + + (super-new))))) + + (define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask)) + + (define syncheck-frame<%> + (interface () + syncheck:button-callback + syncheck:error-report-visible?)) + + (define tab-mixin + + (mixin (drscheme:unit:tab<%>) () + (inherit is-current-tab? get-defs get-frame) + + (define report-error-text (new (fw:text:ports-mixin fw:scheme:text%))) + (define error-report-visible? #f) + (send report-error-text auto-wrap #t) + (send report-error-text set-autowrap-bitmap #f) + (send report-error-text lock #t) + + (define/public (get-error-report-text) report-error-text) + (define/public (get-error-report-visible?) error-report-visible?) + (define/public (turn-on-error-report) (set! error-report-visible? #t)) + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (syncheck:clear-error-message) + (syncheck:clear-highlighting)) + + (define/public (syncheck:clear-error-message) + (set! error-report-visible? #f) + (send report-error-text clear-output-ports) + (send report-error-text lock #f) + (send report-error-text delete/io 0 (send report-error-text last-position)) + (send report-error-text lock #t) + (when (is-current-tab?) + (send (get-frame) hide-error-report))) + + (define cleanup-texts '()) + (define/public (syncheck:clear-highlighting) + (let* ([definitions (get-defs)] + [locked? (send definitions is-locked?)]) + (send definitions begin-edit-sequence #f) + (send definitions lock #f) + (send definitions syncheck:clear-arrows) + (for-each (λ (text) + (send text thaw-colorer)) + cleanup-texts) + (set! cleanup-texts '()) + (send definitions lock locked?) + (send definitions end-edit-sequence))) + + (define/augment (can-close?) + (and (send report-error-text can-close?) + (inner #t can-close?))) + + (define/augment (on-close) + (send report-error-text on-close) + (send (get-defs) syncheck:clear-arrows) + (inner (void) on-close)) + + ;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void + (define/public (syncheck:add-to-cleanup-texts txt) + (unless (memq txt cleanup-texts) + (send txt freeze-colorer) + (set! cleanup-texts (cons txt cleanup-texts)))) + + (super-new))) + + (define unit-frame-mixin + (mixin (drscheme:unit:frame<%>) (syncheck-frame<%>) + + (inherit get-button-panel + get-definitions-canvas + get-definitions-text + get-interactions-text + get-current-tab) + + (define/augment (on-tab-change old-tab new-tab) + (inner (void) on-tab-change old-tab new-tab) + (if (send new-tab get-error-report-visible?) + (show-error-report) + (hide-error-report)) + (send report-error-canvas set-editor (send new-tab get-error-report-text)) + (update-button-visibility/tab new-tab)) + + (define/private (update-button-visibility/tab tab) + (update-button-visibility/settings (send (send tab get-defs) get-next-settings))) + (define/public (update-button-visibility/settings settings) + (let* ([lang (drscheme:language-configuration:language-settings-language settings)] + [visible? (send lang capability-value 'drscheme:check-syntax-button)]) + (send check-syntax-button-parent-panel change-children + (λ (l) + (if visible? + (list check-syntax-button) + '()))))) + + (define/augment (enable-evaluation) + (send check-syntax-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send check-syntax-button enable #f) + (inner (void) disable-evaluation)) + + (define report-error-parent-panel 'uninitialized-report-error-parent-panel) + (define report-error-panel 'uninitialized-report-error-panel) + (define report-error-canvas 'uninitialized-report-error-editor-canvas) + (define/override (get-definitions/interactions-panel-parent) + (set! report-error-parent-panel + (make-object vertical-panel% + (super get-definitions/interactions-panel-parent))) + (set! report-error-panel (instantiate horizontal-panel% () + (parent report-error-parent-panel) + (stretchable-height #f) + (alignment '(center center)) + (style '(border)))) + (send report-error-parent-panel change-children (λ (l) null)) + (let ([message-panel (instantiate vertical-panel% () + (parent report-error-panel) + (stretchable-width #f) + (stretchable-height #f) + (alignment '(left center)))]) + (make-object message% (string-constant check-syntax) message-panel) + (make-object message% (string-constant cs-error-message) message-panel)) + (set! report-error-canvas (new editor-canvas% + (parent report-error-panel) + (editor (send (get-current-tab) get-error-report-text)) + (line-count 3) + (style '(no-hscroll)))) + (instantiate button% () + (label (string-constant hide)) + (parent report-error-panel) + (callback (λ (x y) (hide-error-report))) + (stretchable-height #t)) + (make-object vertical-panel% report-error-parent-panel)) + + (define/public-final (syncheck:error-report-visible?) + (and (is-a? report-error-parent-panel area-container<%>) + (member report-error-panel (send report-error-parent-panel get-children)))) + + (define/public (hide-error-report) + (when (syncheck:error-report-visible?) + (send report-error-parent-panel change-children + (λ (l) (remq report-error-panel l))))) + + (define/private (show-error-report) + (unless (syncheck:error-report-visible?) + (send report-error-parent-panel change-children + (λ (l) (cons report-error-panel l))))) + + (define rest-panel 'uninitialized-root) + (define super-root 'uninitialized-super-root) + (define/override (make-root-area-container % parent) + (let* ([s-root (super make-root-area-container + vertical-panel% + parent)] + [r-root (make-object % s-root)]) + (set! super-root s-root) + (set! rest-panel r-root) + r-root)) + + (inherit open-status-line close-status-line update-status-line ensure-rep-hidden) + ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void) + ;; this is the only function that has any code running on the user's thread + (define/public syncheck:button-callback + (case-lambda + [() (syncheck:button-callback #f)] + [(jump-to-id) + (when (send check-syntax-button is-enabled?) + (open-status-line 'drscheme:check-syntax) + (update-status-line 'drscheme:check-syntax status-init) + (ensure-rep-hidden) + (let-values ([(expanded-expression expansion-completed) (make-traversal)]) + (let* ([definitions-text (get-definitions-text)] + [drs-eventspace (current-eventspace)] + [the-tab (get-current-tab)]) + (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)]) + (let* ([user-namespace #f] + [user-directory #f] + [user-custodian #f] + [normal-termination? #f] + + [show-error-report/tab + (λ () ; =drs= + (send the-tab turn-on-error-report) + (send (send the-tab get-error-report-text) scroll-to-position 0) + (when (eq? (get-current-tab) the-tab) + (show-error-report)))] + [cleanup + (λ () ; =drs= + (send the-tab set-breakables old-break-thread old-custodian) + (send the-tab enable-evaluation) + (send definitions-text end-edit-sequence) + (close-status-line 'drscheme:check-syntax) + + ;; do this with some lag ... not great, but should be okay. + (thread + (λ () + (flush-output (send (send the-tab get-error-report-text) get-err-port)) + (queue-callback + (λ () + (unless (= 0 (send (send the-tab get-error-report-text) last-position)) + (show-error-report/tab)))))))] + [kill-termination + (λ () + (unless normal-termination? + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian))))))] + [error-display-semaphore (make-semaphore 0)] + [uncaught-exception-raised + (λ () ;; =user= + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (yield error-display-semaphore) ;; let error display go first + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian)))))] + [error-port (send (send the-tab get-error-report-text) get-err-port)] + [init-proc + (λ () ; =user= + (send the-tab set-breakables (current-thread) (current-custodian)) + (set-directory definitions-text) + (current-error-port error-port) + (error-display-handler + (λ (msg exn) ;; =user= + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (show-error-report/tab)))) + + (drscheme:debug:error-display-handler/stacktrace + msg + exn + '()) + + (semaphore-post error-display-semaphore))) + + (error-print-source-location #f) ; need to build code to render error first + (uncaught-exception-handler + (let ([oh (uncaught-exception-handler)]) + (λ (exn) + (uncaught-exception-raised) + (oh exn)))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (set! user-custodian (current-custodian)) + (set! user-directory (current-directory)) ;; set by set-directory above + (set! user-namespace (current-namespace)))]) + (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. + (send definitions-text begin-edit-sequence #f) + (with-lock/edit-sequence + definitions-text + (λ () + (send the-tab clear-annotations) + (send the-tab reset-offer-kill) + (send (send the-tab get-defs) syncheck:init-arrows) + + (drscheme:eval:expand-program + (drscheme:language:make-text/pos definitions-text 0 (send definitions-text last-position)) + (send definitions-text get-next-settings) + #t + init-proc + kill-termination + (λ (sexp loop) ; =user= + (cond + [(eof-object? sexp) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (parameterize ([currently-processing-drscheme-frame this]) + (expansion-completed user-namespace user-directory) + (send definitions-text syncheck:sort-bindings-table)))) + (cleanup) + (custodian-shutdown-all user-custodian))))] + [else + (update-status-line 'drscheme:check-syntax status-eval-compile-time) + (eval-compile-time-part-of-top-level sexp) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (open-status-line 'drscheme:check-syntax) + (force-xref (λ () (update-status-line 'drscheme:check-syntax status-loading-docs-index))) + (update-status-line 'drscheme:check-syntax status-coloring-program) + (parameterize ([currently-processing-drscheme-frame this]) + (expanded-expression user-namespace user-directory sexp jump-to-id)) + (close-status-line 'drscheme:check-syntax)))))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (loop)]))))))))))])) + + ;; set-directory : text -> void + ;; sets the current-directory and current-load-relative-directory + ;; based on the file saved in the definitions-text + (define/private (set-directory definitions-text) + (let* ([tmp-b (box #f)] + [fn (send definitions-text get-filename tmp-b)]) + (unless (unbox tmp-b) + (when fn + (let-values ([(base name dir?) (split-path fn)]) + (current-directory base) + (current-load-relative-directory base)))))) + + ;; with-lock/edit-sequence : text (-> void) -> void + ;; sets and restores some state of the definitions text + ;; so that edits to the definitions text work out. + (define/private (with-lock/edit-sequence definitions-text thnk) + (let* ([locked? (send definitions-text is-locked?)]) + (send definitions-text begin-edit-sequence) + (send definitions-text lock #f) + (thnk) + (send definitions-text end-edit-sequence) + (send definitions-text lock locked?))) + + (super-new) + + (define check-syntax-button-parent-panel + (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f] + [stretchable-height #f])) + (define check-syntax-button + (new switchable-button% + (label (string-constant check-syntax)) + (bitmap syncheck-bitmap) + (parent check-syntax-button-parent-panel) + (callback (λ (button) (syncheck:button-callback))))) + (inherit register-toolbar-button) + (register-toolbar-button check-syntax-button) + (define/public (syncheck:get-button) check-syntax-button) + (send (get-button-panel) change-children + (λ (l) + (cons check-syntax-button-parent-panel + (remove check-syntax-button-parent-panel l)))) + (update-button-visibility/tab (get-current-tab)))) + + (define report-error-style (make-object style-delta% 'change-style 'italic)) + (send report-error-style set-delta-foreground "red") + + (define (add-check-syntax-key-bindings keymap) + (send keymap add-function + "check syntax" + (λ (obj evt) + (when (is-a? obj editor<%>) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback)))))))) + + (let ([jump-callback + (λ (send-msg) + (λ (obj evt) + (when (is-a? obj text%) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (let ([defs (send frame get-definitions-text)]) + (when (is-a? defs syncheck-text<%>) + (send-msg defs obj))))))))))]) + (send keymap add-function + "jump to binding occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-binding-occurrence obj)))) + (send keymap add-function + "jump to next bound occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-next-bound-occurrence obj)))) + (send keymap add-function + "jump to definition (in other file)" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-definition obj))))) + + (send keymap map-function "f6" "check syntax") + (send keymap map-function "c:c;c:c" "check syntax") + (send keymap map-function "c:x;b" "jump to binding occurrence") + (send keymap map-function "c:x;n" "jump to next bound occurrence") + (send keymap map-function "c:x;d" "jump to definition (in other file)")) + + (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound) + (define imported-variable-style-pref 'drscheme:check-syntax:imported) + + (define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref)) + (define imported-variable-style-name (symbol->string imported-variable-style-pref)) + + (define error-style-name (fw:scheme:short-sym->style-name 'error)) + ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant)) + + (define (syncheck-add-to-preferences-panel parent) + (fw:color-prefs:build-color-selection-panel parent + lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (string-constant cs-lexical-variable)) + (fw:color-prefs:build-color-selection-panel parent + imported-variable-style-pref + imported-variable-style-name + (string-constant cs-imported-variable))) + + (fw:color-prefs:register-color-preference lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (make-object color% 81 112 203) + (make-object color% 50 163 255)) + (fw:color-prefs:register-color-preference imported-variable-style-pref + imported-variable-style-name + (make-object color% 68 0 203) + (make-object color% 166 0 255)) + + + + + + ; + ; + ; + ; ; + ; ; + ; ; ; ; + ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; + ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; + ; ; + ; ; + ; ; + + + + ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) + ;; (namespace string[directory] -> void)) + ;; returns a pair of functions that close over some state that + ;; represents the top-level of a single program. The first value + ;; is called once for each top-level expression and the second + ;; value is called once, after all expansion is complete. + (define (make-traversal) + (let* ([tl-low-binders (make-id-set)] + [tl-high-binders (make-id-set)] + [tl-low-varrefs (make-id-set)] + [tl-high-varrefs (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] + [tl-templrefs (make-id-set)] + [tl-requires (make-hash)] + [tl-require-for-syntaxes (make-hash)] + [tl-require-for-templates (make-hash)] + [tl-require-for-labels (make-hash)] + [source-editor-cache (make-hasheq)] + [expanded-expression + (λ (user-namespace user-directory sexp jump-to-id) + (parameterize ([current-load-relative-directory user-directory]) + (let ([is-module? (syntax-case sexp (module) + [(module . rest) #t] + [else #f])]) + (cond + [is-module? + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] + [varrefs (make-id-set)] + [high-varrefs (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] + [templrefs (make-id-set)] + [requires (make-hash)] + [require-for-syntaxes (make-hash)] + [require-for-templates (make-hash)] + [require-for-labels (make-hash)]) + (annotate-basic sexp source-editor-cache + user-namespace user-directory jump-to-id + low-binders high-binders varrefs high-varrefs low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (annotate-variables source-editor-cache + user-namespace + user-directory + low-binders + high-binders + varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels))] + [else + (annotate-basic sexp source-editor-cache + user-namespace user-directory jump-to-id + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)]))))] + [expansion-completed + (λ (user-namespace user-directory) + (parameterize ([current-load-relative-directory user-directory]) + (annotate-variables source-editor-cache + user-namespace + user-directory + tl-low-binders + tl-high-binders + tl-low-varrefs + tl-high-varrefs + tl-low-tops + tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)))]) + (values expanded-expression expansion-completed))) + + + ;; type req/tag = (make-req/tag syntax sexp boolean) + (define-struct req/tag (req-stx req-sexp used?)) + + ;; annotate-basic : syntax + ;; hash-table[source-editor-cache] + ;; namespace + ;; string[directory] + ;; syntax[id] + ;; id-set (six of them) + ;; hash-table[require-spec -> syntax] (three of them) + ;; -> void + (define (annotate-basic sexp + source-editor-cache + user-namespace user-directory jump-to-id + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + + (let ([tail-ht (make-hasheq)] + [maybe-jump + (λ (vars) + (when jump-to-id + (for-each (λ (id) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to source-editor-cache id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; tops are used here because a binding free use of a set!'d variable + ;; is treated just the same as (#%top . x). + (when (syntax-original? (syntax var)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure source-editor-cache (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure source-editor-cache (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open source-editor-cache user-namespace user-directory) (syntax lang)) + + (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (with-syntax ([((require-specs ...) ...) + (map (lambda (spec) + (syntax-case spec (just-meta) + [(just-meta m spec ...) + #'(spec ...)] + [else (list spec)])) + (syntax->list #'(require-specs ...)))]) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ... ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open source-editor-cache + user-namespace + user-directory) + new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ... ...))))))]))]) + (for-each (lambda (spec) + (let loop ([spec spec]) + (syntax-case* spec (for-syntax for-template for-label for-meta just-meta) + (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(just-meta phase specs ...) + (for-each loop (syntax->list #'(specs ...)))] + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-meta 1 specs ...) + (at-phase #'(for-syntax specs ...) require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-meta -1 specs ...) + (at-phase #'(for-template specs ...) require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [(for-meta #f specs ...) + (at-phase #'(for-label specs ...) require-for-labels)] + [(for-meta 0 specs ...) + (at-phase #'(for-run specs ...) requires)] + [(for-meta . _) (void)] + [else + (at-phase (list #f spec) requires)]))) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links source-editor-cache tail-ht))) + + (define (hash-cons! ht k v) + (hash-set! ht k (cons v (hash-ref ht k '())))) + + ;; add-disappeared-bindings : syntax id-set -> void + (define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + + ;; add-disappeared-uses : syntax id-set -> void + (define (add-disappeared-uses stx id-set) + (let ([prop (syntax-property stx 'disappeared-use)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-id id-set prop)]))))) + + ;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] + ;; -> sexp[require-spec] + ;; syntax + ;; -> void + (define (add-require-spec require-ht) + (λ (raw-spec syntax) + (when (syntax-original? syntax) + (let ([key (syntax->datum raw-spec)]) + (hash-set! require-ht + key + (cons syntax + (hash-ref require-ht + key + (λ () '())))))))) + + ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void + ;; colors in and draws arrows for variables, according to their classifications + ;; in the various id-sets + (define (annotate-variables source-editor-cache + user-namespace + user-directory + low-binders + high-binders + low-varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels) + + (let ([rename-ht + ;; hash-table[(list source number number) -> (listof syntax)] + (make-hash)] + [unused-requires (make-hash)] + [unused-require-for-syntaxes (make-hash)] + [unused-require-for-templates (make-hash)] + [unused-require-for-labels (make-hash)] + ;; there is no define-for-template form, thus no for-template binders + [template-binders (make-id-set)] + [label-binders (make-id-set)] + [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) + + (hash-for-each requires + (λ (k v) (hash-set! unused-requires k #t))) + (hash-for-each require-for-syntaxes + (λ (k v) (hash-set! unused-require-for-syntaxes k #t))) + (hash-for-each require-for-templates + (lambda (k v) (hash-set! unused-require-for-templates k #t))) + (hash-for-each require-for-labels + (lambda (k v) (hash-set! unused-require-for-labels k #t))) + + (for-each (λ (vars) + (for-each (λ (var) + (when (syntax-original? var) + (color-variable source-editor-cache var identifier-binding) + (document-variable var identifier-binding) + (record-renamable-var rename-ht var))) + vars)) + (append (get-idss high-binders) + (get-idss low-binders))) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable source-editor-cache var identifier-binding) + (document-variable var identifier-binding) + (connect-identifier source-editor-cache + var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss low-varrefs)) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable source-editor-cache var identifier-transformer-binding) + (document-variable var identifier-transformer-binding) + (connect-identifier source-editor-cache + var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss high-varrefs)) + + (for-each (lambda (vars) (for-each + (lambda (var) + ;; no color variable + (connect-identifier source-editor-cache + var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #f) + (connect-identifier source-editor-cache + var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #f) + (connect-identifier source-editor-cache + var + rename-ht + template-binders ;; dummy; always empty + unused-require-for-templates + require-for-templates + identifier-template-binding + user-namespace + user-directory + #f) + (connect-identifier source-editor-cache + var + rename-ht + label-binders ;; dummy; always empty + unused-require-for-labels + require-for-labels + identifier-label-binding + user-namespace + user-directory + #f)) + vars)) + (get-idss templrefs)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top source-editor-cache rename-ht user-namespace user-directory low-binders var)) + vars)) + (get-idss low-tops)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top source-editor-cache rename-ht user-namespace user-directory high-binders var)) + vars)) + (get-idss high-tops)) + + (color-unused source-editor-cache require-for-labels unused-require-for-labels) + (color-unused source-editor-cache require-for-templates unused-require-for-templates) + (color-unused source-editor-cache require-for-syntaxes unused-require-for-syntaxes) + (color-unused source-editor-cache requires unused-requires) + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu source-editor-cache stxs id-sets))))) + + ;; record-renamable-var : rename-ht syntax -> void + (define (record-renamable-var rename-ht stx) + (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) + (hash-set! rename-ht + key + (cons stx (hash-ref rename-ht key '()))))) + + ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void + (define (color-unused source-editor-cache requires unused) + (hash-for-each + unused + (λ (k v) + (for-each (λ (stx) (color source-editor-cache stx error-style-name)) + (hash-ref requires k))))) + + ;; connect-identifier : hash-table[source-editor-cache] + ;; syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; (listof id-set) + ;; namespace + ;; directory + ;; boolean + ;; -> void + ;; adds arrows and rename menus for binders/bindings + (define (connect-identifier source-editor-cache var rename-ht all-binders + unused requires get-binding user-namespace user-directory actual?) + (connect-identifier/arrow source-editor-cache var all-binders + unused requires get-binding user-namespace user-directory actual?) + (when (and actual? (get-ids all-binders var)) + (record-renamable-var rename-ht var))) + + ;; connect-identifier/arrow : syntax + ;; hash-table[source-editor-cache] + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; boolean + ;; -> void + ;; adds the arrows that correspond to binders/bindings + (define (connect-identifier/arrow source-editor-cache var all-binders unused requires get-binding user-namespace user-directory actual?) + (let ([binders (get-ids all-binders var)]) + (when binders + (for-each (λ (x) + (when (syntax-original? x) + (connect-syntaxes source-editor-cache x var actual?))) + binders)) + + (when (and unused requires) + (let ([req-path/pr (get-module-req-path (get-binding var))]) + (when req-path/pr + (let* ([req-path (car req-path/pr)] + [id (cdr req-path/pr)] + [req-stxes (hash-ref requires req-path (λ () #f))]) + (when req-stxes + (hash-remove! unused req-path) + (for-each (λ (req-stx) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (add-jump-to-definition + source-editor-cache + var + id + (get-require-filename req-path user-namespace user-directory))) + (add-mouse-over source-editor-cache + var + (fw:gui-utils:format-literal-label + (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes source-editor-cache req-stx var actual?))) + req-stxes)))))))) + + (define (id/require-match? var id req-stx) + (cond + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix)) + (let ([prefix (list-ref req-stx 1)]) + (equal? (format "~a~a" prefix id) + (symbol->string var)))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix-all-except)) + (let ([prefix (list-ref req-stx 1)]) + (and (not (memq id (cdddr req-stx))) + (equal? (format "~a~a" prefix id) + (symbol->string var))))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'rename)) + (eq? (list-ref req-stx 2) + var)] + [else (eq? var id)])) + + + ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) + ;; argument is the result of identifier-binding or identifier-transformer-binding + (define (get-module-req-path binding) + (and (pair? binding) + (let ([mod-path (list-ref binding 2)]) + (cond + [(module-path-index? mod-path) + (let-values ([(base offset) (module-path-index-split mod-path)]) + (cons base (list-ref binding 3)))] + [(symbol? mod-path) + (cons mod-path (list-ref binding 3))])))) + + ;; color/connect-top : namespace directory id-set syntax -> void + (define (color/connect-top source-editor-cache rename-ht user-namespace user-directory binders var) + (let ([top-bound? + (or (get-ids binders var) + (parameterize ([current-namespace user-namespace]) + (let/ec k + (namespace-variable-value (syntax-e var) #t (λ () (k #f))) + #t)))]) + (if top-bound? + (color source-editor-cache var lexically-bound-variable-style-name) + (color source-editor-cache var error-style-name)) + (connect-identifier source-editor-cache var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + + ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void + (define (color-variable source-editor-cache var get-binding) + (let* ([b (get-binding var)] + [lexical? + (or (not b) + (eq? b 'lexical) + (and (pair? b) + (let ([path (caddr b)]) + (and (module-path-index? path) + (let-values ([(a b) (module-path-index-split path)]) + (and (not a) + (not b)))))))]) + (cond + [lexical? (color source-editor-cache var lexically-bound-variable-style-name)] + [(pair? b) (color source-editor-cache var imported-variable-style-name)]))) + + ;; add-var : hash-table -> syntax -> void + ;; adds the variable to the hash table. + (define (add-var ht) + (λ (var) + (let* ([key (syntax-e var)] + [prev (hash-ref ht key (λ () null))]) + (hash-set! ht key (cons var prev))))) + + ;; connect-syntaxes : syntax[original] syntax[original] boolean -> void + ;; adds an arrow from `from' to `to', unless they have the same source loc. + (define (connect-syntaxes source-editor-cache from to actual?) + (let ([from-source (find-source-editor source-editor-cache from)] + [to-source (find-source-editor source-editor-cache to)] + [defs-text (get-defs-text)]) + (when (and from-source to-source defs-text) + (let ([pos-from (syntax-position from)] + [span-from (syntax-span from)] + [pos-to (syntax-position to)] + [span-to (syntax-span to)]) + (when (and pos-from span-from pos-to span-to) + (let* ([from-pos-left (- (syntax-position from) 1)] + [from-pos-right (+ from-pos-left (syntax-span from))] + [to-pos-left (- (syntax-position to) 1)] + [to-pos-right (+ to-pos-left (syntax-span to))]) + (unless (= from-pos-left to-pos-left) + (send defs-text syncheck:add-arrow + from-source from-pos-left from-pos-right + to-source to-pos-left to-pos-right + actual?)))))))) + + ;; add-mouse-over : hash-table[source-editor-cache] syntax[original] string -> void + ;; registers the range in the editor so that a mouse over + ;; this area shows up in the status line. + (define (add-mouse-over source-editor-cache stx str) + (let* ([source (find-source-editor source-editor-cache stx)] + [defs-text (get-defs-text)]) + (when (and defs-text + source + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-mouse-over-status + source pos-left pos-right str))))) + + ;; add-jump-to-definition : hash-table[source-editor-cache] syntax symbol path -> void + ;; registers the range in the editor so that the + ;; popup menu in this area allows the programmer to jump + ;; to the definition of the id. + (define (add-jump-to-definition source-editor-cache stx id filename) + (let ([source (find-source-editor source-editor-cache stx)] + [defs-text (get-defs-text)]) + (when (and source + defs-text + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-jump-to-definition + source + pos-left + pos-right + id + filename))))) + + ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) + (define (find-syncheck-text text) + (let loop ([text text]) + (cond + [(is-a? text syncheck-text<%>) text] + [else + (let ([admin (send text get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-editor-snip (send admin get-snip)] + [editor-snip-admin (send enclosing-editor-snip get-admin)] + [enclosing-editor (send editor-snip-admin get-editor)]) + (loop enclosing-editor))))]))) + + ;; annotate-tail-position/last : (listof syntax) -> void + (define (annotate-tail-position/last orig-stx stxs tail-ht) + (unless (null? stxs) + (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + + ;; annotate-tail-position : syntax -> void + ;; colors the parens (if any) around the argument + ;; to indicate this is a tail call. + (define (annotate-tail-position orig-stx tail-stx tail-ht) + (hash-set! + tail-ht + orig-stx + (cons + tail-stx + (hash-ref + tail-ht + orig-stx + (λ () null))))) + + ;; annotate-require-open : hash-table[source-editor-cache] namespace string -> (stx -> void) + ;; relies on current-module-name-resolver, which in turn depends on + ;; current-directory and current-namespace + (define (annotate-require-open source-editor-cache user-namespace user-directory) + (λ (require-spec) + (when (syntax-original? require-spec) + (let ([source (find-source-editor source-editor-cache require-spec)]) + (when (and (is-a? source text%) + (syntax-position require-spec) + (syntax-span require-spec)) + (let ([defs-text (get-defs-text)]) + (when defs-text + (let* ([start (- (syntax-position require-spec) 1)] + [end (+ start (syntax-span require-spec))] + [file (get-require-filename (syntax->datum require-spec) + user-namespace + user-directory)]) + (when file + (send defs-text syncheck:add-menu + source + start end + #f + (make-require-open-menu file))))))))))) + + ;; get-require-filename : sexp namespace string[directory] -> filename + ;; finds the filename corresponding to the require in stx + (define (get-require-filename datum user-namespace user-directory) + (let ([mp + (parameterize ([current-namespace user-namespace] + [current-directory user-directory] + [current-load-relative-directory user-directory]) + (with-handlers ([exn:fail? (λ (x) #f)]) + ((current-module-name-resolver) datum #f #f)))]) + (and (resolved-module-path? mp) + (resolved-module-path-name mp)))) + + ;; make-require-open-menu : path -> menu -> void + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)))) + + ;; possible-suffixes : (listof string) + ;; these are the suffixes that are checked for the reverse + ;; module-path mapping. + (define possible-suffixes '(".ss" ".scm" "")) + + ;; module-name-sym->filename : symbol -> (union #f string) + (define (module-name-sym->filename sym) + (let ([str (symbol->string sym)]) + (and ((string-length str) . > . 1) + (char=? (string-ref str 0) #\,) + (let ([fn (substring str 1 (string-length str))]) + (ormap (λ (x) + (let ([test (string->path (string-append fn x))]) + (and (file-exists? test) + test))) + possible-suffixes))))) + + ;; add-origins : sexp id-set -> void + (define (add-origins sexp id-set) + (let ([origin (syntax-property sexp 'origin)]) + (when origin + (let loop ([ct origin]) + (cond + [(pair? ct) + (loop (car ct)) + (loop (cdr ct))] + [(syntax? ct) + (when (syntax-original? ct) + (add-id id-set ct))] + [else (void)]))))) + + ;; FIXME: handle for-template and for-label + ;; extract-provided-vars : syntax -> (listof syntax[identifier]) + (define (extract-provided-vars stx) + (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? + [identifier + (identifier? (syntax identifier)) + (list (syntax identifier))] + + [(rename local-identifier export-identifier) + (list (syntax local-identifier))] + + ;; why do I even see this?!? + [(struct struct-identifier (field-identifier ...)) + null] + + [(all-from module-name) null] + [(all-from-except module-name identifier ...) + null] + [(all-defined-except identifier ...) + (syntax->list #'(identifier ...))] + [_ + null])) + + + ;; trim-require-prefix : syntax -> syntax + (define (trim-require-prefix require-spec) + (syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare? + [(only module-name identifer ...) + (syntax module-name)] + [(prefix identifier module-name) + (syntax module-name)] + [(all-except module-name identifer ...) + (syntax module-name)] + [(prefix-all-except module-name identifer ...) + (syntax module-name)] + [(rename module-name local-identifer exported-identifer) + (syntax module-name)] + [_ require-spec])) + + (define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) + + ;; add-binders : syntax id-set -> void + ;; transforms an argument list into a bunch of symbols/symbols + ;; and puts them into the id-set + ;; effect: colors the identifiers + (define (add-binders stx id-set) + (let loop ([stx stx]) + (let ([e (if (syntax? stx) (syntax-e stx) stx)]) + (cond + [(cons? e) + (let ([fst (car e)] + [rst (cdr e)]) + (if (syntax? fst) + (begin + (when (syntax-original? fst) + (add-id id-set fst)) + (loop rst)) + (loop rst)))] + [(null? e) (void)] + [else + (when (syntax-original? stx) + (add-id id-set stx))])))) + + ;; annotate-raw-keyword : syntax id-map -> void + ;; annotates keywords when they were never expanded. eg. + ;; if someone just types `(λ (x) x)' it has no 'origin + ;; field, but there still are keywords. + (define (annotate-raw-keyword stx id-map) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) + + ;; color-internal-structure : syntax str -> void + (define (color-internal-structure source-editor-cache stx style-name) + (let ([ht (make-hasheq)]) + ;; ht : stx -o> true + ;; indicates if we've seen this syntax object before + + (let loop ([stx stx] + [datum (syntax->datum stx)]) + (unless (hash-ref ht datum (λ () #f)) + (hash-set! ht datum #t) + (cond + [(pair? stx) + (loop (car stx) (car datum)) + (loop (cdr stx) (cdr datum))] + [(syntax? stx) + (when (syntax-original? stx) + (color source-editor-cache stx style-name)) + (let ([stx-e (syntax-e stx)]) + (cond + [(cons? stx-e) + (loop (car stx-e) (car datum)) + (loop (cdr stx-e) (cdr datum))] + [(null? stx-e) + (void)] + [(vector? stx-e) + (for-each loop + (vector->list stx-e) + (vector->list datum))] + [(box? stx-e) + (loop (unbox stx-e) (unbox datum))] + [else (void)]))]))))) + + ;; jump-to : hash-table[source-editor-cache] syntax -> void + (define (jump-to source-editor-cache stx) + (let ([src (find-source-editor source-editor-cache stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src set-position (- pos 1) (+ pos span -1))))) + + ;; color : syntax[original] str -> void + ;; colors the syntax with style-name's style + (define (color source-editor-cache stx style-name) + (let ([source (find-source-editor source-editor-cache stx)]) + (when (and (is-a? source text%) + (syntax-position stx) + (syntax-span stx)) + (let ([pos (- (syntax-position stx) 1)] + [span (syntax-span stx)]) + (color-range source pos (+ pos span) style-name))))) + + ;; color-range : text start finish style-name + ;; colors a range in the text based on `style-name' + (define (color-range source start finish style-name) + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (add-to-cleanup-texts source) + (send source change-style style start finish #f))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + (define (add-tail-ht-links source-editor-cache tail-ht) + (begin + (collapse-tail-links source-editor-cache tail-ht) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each (λ (stx-to) (add-tail-ht-link source-editor-cache stx-from stx-to)) + stx-tos))))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + ;; take something like a transitive closure, except + ;; only when there are non-original links in between + + (define (collapse-tail-links source-editor-cache tail-ht) + (let loop () + (let ([found-one? #f]) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each + (λ (stx-to) + (let ([stx-to-tos (hash-ref tail-ht stx-to '())]) + (for-each + (λ (stx-to-to) + (unless (and (add-tail-link? source-editor-cache stx-from stx-to) + (add-tail-link? source-editor-cache stx-to stx-to-to)) + (unless (memq stx-to-to (hash-ref tail-ht stx-from '())) + (set! found-one? #t) + (hash-cons! tail-ht stx-from stx-to-to)))) + stx-to-tos))) + stx-tos))) + + ;; this takes O(n^3) in general, so we just do + ;; one iteration. This doesn't work for case + ;; expressions but it seems to for most others. + ;; turning this on makes this function go from about + ;; 55 msec to about 2400 msec on my laptop, + ;; (a 43x slowdown) when checking the syntax of this file. + + #; + (when found-one? + (loop))))) + + ;; add-tail-ht-link : syntax syntax -> void + (define (add-tail-ht-link source-editor-cache from-stx to-stx) + (let* ([to-src (find-source-editor source-editor-cache to-stx)] + [from-src (find-source-editor source-editor-cache from-stx)] + [defs-text (get-defs-text)]) + (when (and to-src from-src defs-text) + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (when (and from-pos to-pos) + (send defs-text syncheck:add-tail-arrow + from-src (- from-pos 1) + to-src (- to-pos 1))))))) + + ;; add-tail-link? : syntax syntax -> boolean + (define (add-tail-link? source-editor-cache from-stx to-stx) + (let* ([to-src (find-source-editor source-editor-cache to-stx)] + [from-src (find-source-editor source-editor-cache from-stx)] + [defs-text (get-defs-text)]) + (and to-src from-src defs-text + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (and from-pos to-pos))))) + + ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void + (define (add-to-cleanup-texts ed) + (let ([ed (find-outermost-editor ed)]) + (when (is-a? ed drscheme:unit:definitions-text<%>) + (let ([tab (send ed get-tab)]) + (send tab syncheck:add-to-cleanup-texts ed))))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) + + ;; find-source-editor : cache stx -> editor or false + (define (find-source-editor source-editor-cache stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (find-source-editor/defs source-editor-cache stx defs-text)))) + + ;; find-source-editor : cache stx text -> editor or false + (define (find-source-editor/defs source-editor-cache stx defs-text) + (cond + [(not (syntax-source stx)) #f] + [else + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (eq? (hash-ref source-editor-cache text #f) + (syntax-source stx))) + text] + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + (hash-set! source-editor-cache text (syntax-source stx)) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))])) + ;; get-defs-text : -> text or false + (define (get-defs-text) + (let ([drs-frame (currently-processing-drscheme-frame)]) + (and drs-frame + (send drs-frame get-definitions-text)))) + + +; +; +; ; +; ; ; +; ; ; ; +; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;; +; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ; +; +; +; + + + ;; document-variable : stx identifier-binding -> void + (define (document-variable stx get-binding) + (when (syntax-original? stx) + (let ([defs-frame (currently-processing-drscheme-frame)]) + (when defs-frame + (let* ([defs-text (send defs-frame get-definitions-text)] + [binding-info (get-binding stx)]) + (when (and (pair? binding-info) + (syntax-position stx) + (syntax-span stx)) + (let* ([start (- (syntax-position stx) 1)] + [fin (+ start (syntax-span stx))] + [xref (get-xref)]) + (when xref + (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) + (when definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (when path + (let ([index-entry (xref-tag->index-entry xref definition-tag)]) + (when index-entry + (send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx)) + (send defs-text syncheck:add-menu + defs-text + start + fin + (syntax-e stx) + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) + (callback + (λ (x y) + (let* ([url (path->url path)] + [url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)]) + (send-url (url->string url2)))))))))))))))))))))) + + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void + (define (make-rename-menu source-editor-cache stxs id-sets) + (let ([defs-frame (currently-processing-drscheme-frame)]) + (when defs-frame + (let* ([defs-text (send defs-frame get-definitions-text)] + [source (syntax-source (car stxs))] ;; all stxs in the list must have the same source + [source-editor (find-source-editor source-editor-cache (car stxs))]) + (when (is-a? source-editor text%) + (let* ([start (- (syntax-position (car stxs)) 1)] + [fin (+ start (syntax-span (car stxs)))]) + (send defs-text syncheck:add-menu + source-editor + start + fin + (syntax-e (car stxs)) + (λ (menu) + (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) + (callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback source-editor-cache + name-to-offer + defs-text + stxs + id-sets + frame-parent)))))))))))))) + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (listof syntax[original]) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback source-editor-cache name-to-offer defs-text stxs id-sets parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (let* ([new-sym (format "~s" (string->symbol new-str))] + [to-be-renamed + (remove-duplicates + (sort + (apply + append + (map (λ (id-set) + (apply + append + (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) + id-sets)) + (λ (x y) + ((syntax-position x) . >= . (syntax-position y)))))] + [do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))]) + (when do-renaming? + (unless (null? to-be-renamed) + (let ([txts (list defs-text)]) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source-editor (find-source-editor/defs source-editor-cache stx defs-text)]) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (for-each + (λ (txt) (send txt end-edit-sequence)) + txts)))))))) + + ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean + ;; returns #t if the name chosen would be the same as another name in this scope. + (define (name-duplication? to-be-renamed id-sets new-str) + (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) + to-be-renamed)]) + (ormap (λ (id-set) + (ormap (λ (new-id) (get-ids id-set new-id)) + new-ids)) + id-sets))) + + ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) + ;; removes duplicates, based on the source locations of the identifiers + (define (remove-duplicates ids) + (cond + [(null? ids) null] + [else (let loop ([fst (car ids)] + [rst (cdr ids)]) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + (= (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) + + + ; + ; + ; + ; ; ; + ; ; + ; ; ; + ; ; ;; ; ;;; ;;; ;;;; ;;; + ; ; ; ;; ; ; ; ; ; + ; ; ; ; ;; ; ; ; ;; + ; ; ; ; ;; ;;;;;; ; ;; + ; ; ; ; ; ; ; ; + ; ; ; ;; ; ; ; ; + ; ; ;; ; ;;; ;;;; ;; ;;; + ; + ; + ; + + ;; make-id-set : -> id-set + (define (make-id-set) (make-module-identifier-mapping)) + + ;; add-id : id-set identifier -> void + (define (add-id mapping id) + (let* ([old (module-identifier-mapping-get mapping id (λ () '()))] + [new (cons id old)]) + (module-identifier-mapping-put! mapping id new))) + + ;; get-idss : id-set -> (listof (listof identifier)) + (define (get-idss mapping) + (module-identifier-mapping-map mapping (λ (x y) y))) + + ;; get-ids : id-set identifier -> (union (listof identifier) #f) + (define (get-ids mapping var) + (module-identifier-mapping-get mapping var (λ () #f))) + + ;; for-each-ids : id-set ((listof identifier) -> void) -> void + (define (for-each-ids mapping f) + (module-identifier-mapping-for-each mapping (λ (x y) (f y)))) + + + ; + ; + ; + ; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;; ; ; ; ;; + ; ; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ;; ; + ; ; ; ; ; ;;;; ;; ; ; ;; + ; ; + ; ; + ; ; + + + (add-check-syntax-key-bindings (drscheme:rep:get-drs-bindings-keymap)) + (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax) + syncheck-add-to-preferences-panel) + (drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) + (drscheme:get/extend:extend-definitions-text make-syncheck-text%) + (drscheme:get/extend:extend-unit-frame unit-frame-mixin #f) + (drscheme:get/extend:extend-tab tab-mixin))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss new file mode 100644 index 0000000000..e5e1ee978a --- /dev/null +++ b/collects/drscheme/tool-lib.ss @@ -0,0 +1,1383 @@ +#reader scribble/reader +#lang scheme/base + +#| + +This first time this is loaded, it loads all of drscheme and invokes +the main unit, starting up drscheme. After that, it just provides +all of the names in the tools library, for use defining keybindings + +|# +(require scheme/class + scheme/gui/base + scheme/unit + scheme/contract + scheme/class + + drscheme/private/link + drscheme/private/drsig + + framework + framework/splash + + scribble/srcdoc + drscheme/private/language-object-contract) + +(require (for-syntax scheme/base)) + +(require/doc drscheme/private/ts scheme/base scribble/manual) + +(shutdown-splash) +(define-values/invoke-unit/infer drscheme@) +(close-splash) +(provide-signature-elements drscheme:tool-cm^) ;; provide all of the classes & interfaces + +(provide drscheme:unit:program-editor-mixin) +(define-syntax (drscheme:unit:program-editor-mixin stx) + (syntax-case stx () + [(_ a ...) + #'((drscheme:unit:get-program-editor-mixin) a ...)] + [_ #'(drscheme:unit:get-program-editor-mixin)])) + +(language-object-abstraction drscheme:language:object/c #t) + +(provide/doc + + ; + ; + ; + ; ; + ; ; + ; ; + ; ;;; ; ; ;;; ; + ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; + ; ;;;;;; ; ; ;;;; ; + ; ; ; ; ; ; ; + ; ; ; ; ; ; + ; ;;;; ; ;;;;; ; + ; + ; + ; + + + (proc-doc/names + drscheme:eval:set-basic-parameters + (-> (listof (is-a?/c snip-class%)) void?) + (snipclasses) + @{sets the parameters that are shared between the repl's + initialization and @scheme[drscheme:eval:build-user-eventspace/custodian] + + Specifically, it sets these parameters: + @itemize{ + @item{ @scheme[current-namespace] has been set to a newly + created empty namespace. This namespace has the following modules + copied (with @scheme[namespace-attach-module]) + from DrScheme's original namespace: + @itemize{ + @item{ @scheme['mzscheme] + }@item{ @scheme['(lib "mred.ss" "mred")] + }} + + }@item{ + @scheme[read-curly-brace-as-paren] + is @scheme[#t], + }@item{ + @scheme[read-square-bracket-as-paren] + is @scheme[#t], + }@item{ + @scheme[error-print-width] is set to 250. + }@item{ + @scheme[current-ps-setup] + is set to a newly created + @scheme[ps-setup%] + object. + }@item{ The @scheme[exit-handler] is set to + a parameter that kills the user's custodian. + }@item{ The snip-class-list, returned by + @scheme[get-the-snip-class-list] + is initialized with all of the snipclasses in DrScheme's eventspace's snip-class-list. + + }}}) + + (proc-doc/names + drscheme:eval:get-snip-classes + (-> (listof (is-a?/c snip-class%))) + () + @{Returns a list of all of the snipclasses in the current eventspace.}) + + (proc-doc/names + drscheme:eval:expand-program + (-> (or/c port? drscheme:language:text/pos?) + drscheme:language-configuration:language-settings? + boolean? + (-> void?) + (-> void?) + (-> (or/c eof-object? syntax? (cons/c string? any/c)) + (-> any) + any) + void?) + (input language-settings eval-compile-time-part? init kill-termination iter) + + @{Use this function to expand the contents of the definitions + window for use with external program processing tools. + + This function uses + @scheme[drscheme:eval:build-user-eventspace/custodian] + to build the user's environment. + The arguments @scheme[language-settings], @scheme[init], and + @scheme[kill-termination] are passed to + @scheme[drscheme:eval:build-user-eventspace/custodian]. + + The @scheme[input] argument specifies the source of the program. + + The @scheme[eval-compile-time-part?] argument indicates if + @scheme[expand] + is called or if + @scheme[expand-top-level-with-compile-time-evals] + is called when the program is expanded. + Roughly speaking, if your tool will evaluate each expression + itself by calling + @scheme[eval] + then pass @scheme[#f]. Otherwise, if your tool + just processes the expanded program, be sure to pass + @scheme[#t]. + + This function calls + @scheme[drscheme:language:language front-end/complete-program<%>] + to expand the program. + + The first argument to @scheme[iter] is the expanded program + (represented as syntax) or eof. + The @scheme[iter] argument is called for each expression in the + expanded program and once more with eof, unless an error is + raised during expansion. + It is called from the user's thread. + If an exception is raised during expansion of the + user's program, @scheme[iter] is not called. + Consider setting the exception-handler during @scheme[init] to + handle this situation. + + The second argument to @scheme[iter] is a thunk that + continues expanding the rest of the contents of the + definitions window. If the first argument to @scheme[iter] was + eof, this argument is just the primitive + @scheme[void]. + + See also + @scheme[drscheme:eval:expand-program/multiple].}) + + (proc-doc/names + drscheme:eval:traverse-program/multiple + (drscheme:language-configuration:language-settings? + (-> void?) + (-> void?) + . -> . + ((or/c port? drscheme:language:text/pos?) + ((or/c eof-object? syntax? (cons/c string? any/c)) + (-> any) + . -> . + any) + boolean? + . -> . + void?)) + (language-settings init kill-termination) + + @{This function is similar to + @scheme[drscheme:eval:expand-program/multiple] + The only difference is that it does not + expand the program in the editor; instead + the processing function can decide how to + expand the program.}) + + (proc-doc/names + drscheme:eval:expand-program/multiple + (-> drscheme:language-configuration:language-settings? + boolean? + (-> void?) + (-> void?) + (-> (or/c port? drscheme:language:text/pos?) + (-> (or/c eof-object? syntax? (cons/c string? any/c)) + (-> any) + any) + boolean? + void?)) + (language-settings eval-compile-time-part? init kill-termination) + + @{This function is just like + @scheme[drscheme:eval:expand-program] + except that it is curried and the second application + can be used multiple times. + Use this function if you want to initialize the user's + thread (and namespace, etc) once but have program text + that comes from multiple sources. + + The extra boolean argument to the result function + determines if + @scheme[drscheme:language:language front-end/complete-program<%>] + or + @scheme[drscheme:language:language front-end/interaction<%>] + is called.}) + + (proc-doc/names + drscheme:eval:build-user-eventspace/custodian + (->* (drscheme:language-configuration:language-settings? + (-> void?) + (-> void?)) + () + (values eventspace? custodian?)) + ((language-settings init kill-termination) ()) + + @{This function creates a custodian and an eventspace (on the + new custodian) to expand the user's program. It does not + kill this custodian, but it can safely be shutdown (with + @scheme[custodian-shutdown-all]) after the + expansion is finished. + + It initializes the + user's eventspace's main thread with several parameters: + @itemize{ + @item{ @scheme[current-custodian] is set to a new custodian. + }@item{ + In addition, it calls + @scheme[drscheme:eval:set-basic-parameters]. + }} + + The @scheme[language-settings] argument is the current + language and its settings. See + @scheme[drscheme:language-configuration:make-language-settings] + for details on that structure. + + If the program is associated with a DrScheme + frame, get the frame's language settings from the + @method[drscheme:unit:definitions-text<%> get-next-settings] + method of + @scheme[drscheme:unit:definitions-text<%>]. Also, the most recently chosen language in + the language dialog is saved via the framework's + preferences. Apply + @scheme[preferences:get] + to + @scheme[drscheme:language-configuration:get-settings-preferences-symbol] + for that @scheme[language-settings]. + + The @scheme[init] argument is called after the user's parameters + are all set, but before the program is run. It is called on + the user's thread. The + @scheme[current-directory] and + @scheme[current-load-relative-directory] + parameters are not set, so if there are appropriate directories, + the @scheme[init] argument is a good place to set them. + + The @scheme[kill-termination] argument is called when the main thread of + the eventspace terminates, no matter if the custodian was + shutdown, or the thread was killed. This procedure is also + called when the thread terminates normally. This procedure is + called from a new, dedicated thread (@italic{i. e.}, not the thread + created to do the expansion, nor the thread that + @scheme[drscheme:eval:build-user-eventspace/custodian] was called from.)}) + + + + ; + ; + ; + ; ; ; + ; ; ; + ; ; ; + ; ;; ; ;;; ; ;; ; ; ;; ; + ; ; ;; ; ; ;; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ;; ; ; ;; ; ;; + ; ;; ; ;;;; ; ;; ;; ; ;; ; + ; ; + ; ; ; + ; ;;;; + + (proc-doc/names + drscheme:debug:error-display-handler/stacktrace + (->* (string? any/c) + ((or/c false/c (listof srcloc?))) + any) + ((msg exn) ((stack #f))) + @{Displays the error message represented by the string, adding + embellishments like those that appears in the DrScheme REPL, + specifically a clickable icon for the stack trace (if the srcloc location is not empty), + and a clickable icon for the source of the error (read & syntax errors show their source + locations and otherwise the first place in the stack trace is shown). + + If @scheme[stack] is false, then the stack trace embedded in the @scheme[exn] argument (if any) is used. + + This should be called in the same eventspace and on the same thread as the error.}) + + (proc-doc/names + drscheme:debug:make-debug-error-display-handler + (-> (-> string? (or/c any/c exn?) any) + (-> string? (or/c any/c exn?) any)) + + (oedh) + + @{This function implements an error-display-handler in terms + of another error-display-handler. + + This function is designed to work in conjunction with + @scheme[drscheme:debug:make-debug-eval-handler]. + + See also MzScheme's + @scheme[error-display-handler] + parameter. + + If the current-error-port is the definitions window in + drscheme, this error handler inserts some debugging + annotations, calls @scheme[oedh], and then highlights the + source location of the runtime error.}) + + (proc-doc/names + drscheme:debug:make-debug-eval-handler + ((any/c . -> . any/c) + . -> . + (any/c . -> . any/c)) + + (odeh) + + @{This function implements an eval-handler in terms of another + eval-handler. + + This function is designed to work in conjunction with + @scheme[drscheme:debug:make-debug-error-display-handler]. + + See also MzScheme's @scheme[eval-handler] + parameter. + + The resulting eval-handler expands and annotates the input + expression and then passes it to the input eval-handler, + unless the input expression is already compiled, in which + case it just hands it directly to the input eval-handler.}) + + (proc-doc/names + drscheme:debug:hide-backtrace-window + (-> void?) + () + @{Hides the backtrace window.}) + + + (proc-doc/names + drscheme:debug:profiling-enabled + (case-> (boolean? . -> . void?) + (-> boolean?)) + ((enabled?) ()) + @{A parameter that controls if profiling information is recorded. + + Defaults to @scheme[#f]. + + Only applies if + @scheme[drscheme:debug:make-debug-eval-handler] + has been added to the eval handler.}) + + (proc-doc/names + drscheme:debug:add-prefs-panel + (-> void?) + () + @{Adds the profiling preferences panel.}) + + (proc-doc/names + drscheme:debug:open-and-highlight-in-file + (srcloc? . -> . void?) + (debug-info) + @{This function opens a DrScheme to display + @scheme[debug-info]. Only the src the position + and the span fields of the srcloc are considered. + + See also + @scheme[drscheme:debug:get-cm-key].}) + + (proc-doc/names + drscheme:debug:show-backtrace-window + (string? + (or/c exn? (listof srcloc?)) + . -> . + void?) + (error-message dis) + @{Shows the backtrace window you get when clicking on the bug in + DrScheme's REPL. + + The @scheme[error-message] argument is the text of the error, + @scheme[dis] is the debug information, extracted from the + continuation mark in the exception record, using + @scheme[drscheme:debug:get-cm-key].}) + + (proc-doc/names + drscheme:debug:get-cm-key + (-> any) + () + @{Returns a key used with @scheme[contination-mark-set->list]. + The contination mark set attached to an exception record + for the user's program may use this mark. If it does, + each mark on the continuation is a list of the fields + of a srcloc object.}) + + ; + ; + ; + ; ; + ; + ; ; + ; ; ; ; ;; ; ;;;; + ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; + ; ; ; ; ; ; ; + ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; + ; ;; ; ; ; ; ;; + ; + ; + ; + + + (proc-doc/names + drscheme:unit:get-program-editor-mixin + (-> ((subclass?/c text%) . -> . (subclass?/c text%))) + () + @{Returns a mixin that must be mixed in to any + @scheme[text%] object that might contain + program text (and thus can be in the source + field of some syntax object). + + See also + @scheme[drscheme:unit:add-to-program-editor-mixin].}) + + (proc-doc/names + drscheme:unit:add-to-program-editor-mixin + (((subclass?/c text%) . -> . (subclass?/c text%)) . -> . void?) + (mixin) + @{@phase[1] + + Adds @scheme[mixin] to the result of + @scheme[drscheme:unit:get-program-editor-mixin].}) + + (proc-doc/names + drscheme:unit:open-drscheme-window + (case-> + (-> (is-a?/c drscheme:unit:frame%)) + ((or/c string? false/c) . -> . (is-a?/c drscheme:unit:frame%))) + (() (filename)) + + @{Opens a drscheme frame that displays @scheme[filename], + or nothing if @scheme[filename] is @scheme[#f] or not supplied.}) + + + + ; + ; + ; + ; ; + ; ; + ; ; + ; ; ;; ;; ;;; ;; ; ;;; ;;; + ; ;; ;; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ;;;;;; ;; + ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; + ; ; ; ; ;;; ;; ; ;;;; ;;; + ; + ; + ; + + + (proc-doc/names + drscheme:modes:add-mode + (string? + (or/c false/c (is-a?/c mode:surrogate-text<%>)) + ((is-a?/c drscheme:rep:text%) number? . -> . boolean?) + ((or/c false/c (listof string?)) . -> . boolean?) + . -> . + drscheme:modes:mode?) + (name surrogate repl-submit matches-language) + @{Adds a mode to DrScheme. Returns a mode value + that identifies the mode. + + The first argument, @scheme[name], is the name + of the mode, used in DrScheme's GUI to allow + the user to select this mode. + + The @scheme[surrogate] argument is set to the + definitions text and the interactions text + (via the + @scheme[mode:host-text set-surrogate<%>] + method) whenever this mode is enabled. + + The @scheme[repl-submit] procedure is called + whenever the user types a return in the interactions + window. It is passed the interactions editor + and the position where the last prompt occurs. + If it + returns @scheme[#t], the text after the last + prompt is treated as a program fragment and + evaluated, according to the language settings. + If it returns @scheme[#f], the text is + assumed to be an incomplete program fragment, and + the keystroke is not treated specially. + + The @scheme[matches-language] predicate is called whenever + the language changes. If it returns @scheme[#t] + this mode is installed. It is passed the list of strings + that correspond to the names of the language in the + language dialog. + + Modes are tested in the opposite order that they are + added. That is, the last mode to be added gets tested + first when the filename changes or when the language + changes. + + See also + @scheme[drscheme:modes:get-modes].}) + + (proc-doc/names + drscheme:modes:mode? + (any/c . -> . boolean?) + (val) + @{Determines if @scheme[val] is a mode.}) + + (proc-doc/names + drscheme:modes:get-modes + (-> (listof drscheme:modes:mode?)) + () + @{Returns all of the modes currently added to DrScheme. + + See also + @scheme[drscheme:modes:add-mode].}) + + (proc-doc/names + drscheme:modes:mode-name + (drscheme:modes:mode? . -> . string?) + (mode) + @{Extracts the name of the mode. + + See also + @scheme[drscheme:modes:add-mode].}) + + (proc-doc/names + drscheme:modes:mode-surrogate + (drscheme:modes:mode? . -> . (or/c false/c (is-a?/c mode:surrogate-text<%>))) + (mode) + @{Extracts the surrogate of the mode. + + See also + @scheme[drscheme:modes:add-mode].}) + + (proc-doc/names + drscheme:modes:mode-repl-submit + (drscheme:modes:mode? . -> . any) + (mode) + @{Extracts the repl submission predicate of the mode. + + See also + @scheme[drscheme:modes:add-mode].}) + + (proc-doc/names + drscheme:modes:mode-matches-language + (drscheme:modes:mode? . -> . ((or/c false/c (listof string?)) . -> . boolean?)) + (mode) + @{Extracts the language matching predicate of the mode. + + See also + @scheme[drscheme:modes:add-mode].}) + + + ; + ; + ; + ; + ; + ; + ; ; ; ;;; ; ;; + ; ;; ; ; ;; ; + ; ; ; ; ; ; + ; ; ;;;;;; ; ; + ; ; ; ; ; + ; ; ; ;; ; + ; ; ;;;; ; ;; + ; ; + ; ; + ; ; + + + (proc-doc/names + drscheme:rep:get-welcome-delta + (-> (is-a?/c style-delta%)) + () + @{Returns a style delta that matches the style and color of the + phrase ``Welcome to'' in the beginning of the interactions window.}) + + (proc-doc/names + drscheme:rep:get-dark-green-delta + (-> (is-a?/c style-delta%)) + () + @{Returns a style delta that matches the style and color of the + name of a language in the interactions window.}) + + (proc-doc/names + drscheme:rep:get-drs-bindings-keymap + (-> (is-a?/c keymap%)) + () + @{Returns a keymap that binds various DrScheme-specific + keybindings. This keymap is used in the definitions + and interactions window. + + Defaultly binds C-x;o to a function that switches + the focus between the definitions and interactions + windows. Also binds f5 to Execute and f1 to Help Desk.}) + + (proc-doc/names + drscheme:rep:current-rep + (-> (or/c false/c (is-a?/c drscheme:rep:text%))) + () + + @{This is a parameter whose value should not be set by tools. + It is initialized to the repl that controls this evaluation + in the user's thread. + + It only returns @scheme[#f] if the program not running + in the context of a repl (eg, the test suite window).}) + + (proc-doc/names + drscheme:rep:current-value-port + (-> (or/c false/c port?)) + () + @{This is a parameter whose value is a port that + prints in the REPL in blue. It is used to print + the values of toplevel expressions in the REPL. + + It is only initialized on the user's thread.}) + + + ; + ; + ; + ; ; ; + ; ; ; + ; ; ; ; ; + ; ;; ; ;;; ;;;; ; ;;; ; ; ;;;; ;;; ; ;; ;; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;;; ; ; ;;;;;; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; + ; ;; ; ;;;; ;; ; ;;;; ; ; ;; ;;;; ; ; ;; ; + ; ; ; + ; ; ; ; + ; ;;;; + + + (proc-doc/names + drscheme:get/extend:extend-tab + (case-> + ((make-mixin-contract drscheme:unit:tab%) . -> . void?) + ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This class implements the tabs in drscheme. One is created for each tab + in a frame (each frame always has at least one tab, even if the tab bar is not shown) + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#t].}) + + (proc-doc/names + drscheme:get/extend:extend-interactions-text + (case-> + ((make-mixin-contract drscheme:rep:text<%>) . -> . void?) + ((make-mixin-contract drscheme:rep:text<%>) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This text is used in the bottom window of drscheme frames. + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#t].}) + + (proc-doc/names + drscheme:get/extend:get-interactions-text + (-> (implementation?/c drscheme:rep:text<%>)) + () + + @{Once this function is called, + @scheme[drscheme:get/extend:extend-interactions-text] + raises an error, disallowing any more extensions.}) + + (proc-doc/names + drscheme:get/extend:extend-definitions-text + (case-> + ((make-mixin-contract drscheme:unit:definitions-text<%>) . -> . void?) + ((make-mixin-contract drscheme:unit:definitions-text<%>) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This text is used in the top window of drscheme frames. + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#f].}) + + (proc-doc/names + drscheme:get/extend:get-definitions-text + (-> (implementation?/c drscheme:unit:definitions-text<%>)) + () + + @{Once this function is called, + @scheme[drscheme:get/extend:extend-definitions-text] + raises an error, disallowing any more extensions.}) + + (proc-doc/names + drscheme:get/extend:extend-interactions-canvas + (case-> + ((make-mixin-contract drscheme:unit:interactions-canvas%) . -> . void?) + ((make-mixin-contract drscheme:unit:interactions-canvas%) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This canvas is used in the bottom window of drscheme frames. + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#f].}) + + (proc-doc/names + drscheme:get/extend:get-interactions-canvas + (-> (subclass?/c drscheme:unit:interactions-canvas%)) + () + + @{Once this function is called, + @scheme[drscheme:get/extend:extend-interactions-canvas] + raises an error, disallowing any more extensions.}) + + (proc-doc/names + drscheme:get/extend:extend-definitions-canvas + (case-> + ((make-mixin-contract drscheme:unit:definitions-canvas%) . -> . void?) + ((make-mixin-contract drscheme:unit:definitions-canvas%) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This canvas is used in the top window of drscheme frames. + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#f].}) + + (proc-doc/names + drscheme:get/extend:get-definitions-canvas + (-> (subclass?/c drscheme:unit:definitions-canvas%)) + () + + @{Once this function is called, + @scheme[drscheme:get/extend:extend-definitions-canvas] + raises an error, disallowing any more extensions.}) + + (proc-doc/names + drscheme:get/extend:extend-unit-frame + (case-> + ((make-mixin-contract drscheme:unit:frame%) . -> . void?) + ((make-mixin-contract drscheme:unit:frame%) boolean? . -> . void?)) + ((mixin) (mixin before?)) + + @{This is the frame that implements the main drscheme window. + + The argument, @scheme[before], controls if the mixin is applied before or + after already installed mixins. + If unsupplied, this is the same as supplying @scheme[#f].}) + + (proc-doc/names + drscheme:get/extend:get-unit-frame + (-> (subclass?/c drscheme:unit:frame%)) + () + + @{Once this function is called, + @scheme[drscheme:get/extend:extend-unit-frame] + raises an error, disallowing any more extensions.}) + + + ; + ; + ; + ; ; + ; ; + ; ; + ; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; + ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; + ; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; + ; ; ; + ; ; ; ; ; + ; ;;;; ;;;; + ; + ; + ; + ; ;;; ; ; + ; ; + ; ; ; + ; ;;; ;;; ; ;; ;;;; ; ;; ; ; ; ; ; ;;; ;;;; ; ;;; ; ;; + ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; + ; ;;; ;;; ; ; ; ; ;; ; ;; ; ; ;;;;; ;; ; ;;; ; ; + ; ; + ; ; ; + ; ;;;; + + (proc-doc/names + drscheme:language-configuration:get-languages + (-> (listof (is-a?/c drscheme:language:language<%>))) + () + @{This can only be called after all of the tools initialization phases have completed. + + Returns the list of all of the languages installed in DrScheme.}) + + (proc-doc/names + drscheme:language-configuration:add-language + ((and/c (is-a?/c drscheme:language:language<%>) drscheme:language:object/c) + . -> . void?) + (language) + + @{@phase[2] + + Adds @scheme[language] to the languages offerend by DrScheme.}) + + (proc-doc/names + drscheme:language-configuration:get-settings-preferences-symbol + (-> symbol?) + () + @{Returns the symbol that is used to store the user's language + settings. Use as an argument to either + @scheme[preferences:get] + or + @scheme[preferences:set].}) + + (proc-doc/names + drscheme:language-configuration:make-language-settings + ((or/c (is-a?/c drscheme:language:language<%>) drscheme:language:object/c) + any/c + . -> . + drscheme:language-configuration:language-settings?) + (language settings) + + @{This is the constructor for a record consisting of two + elements, a language and its settings. + + The settings is a language-specific record that holds a + value describing a parameterization of the language. + + It has two selectors, + @scheme[drscheme:language-configuration:language-settings-language] + and + @scheme[drscheme:language-configuration:language-settings-settings], and a predicate, + @scheme[drscheme:language-configuration:language-settings?]}) + + (proc-doc/names + drscheme:language-configuration:language-settings-settings + (-> drscheme:language-configuration:language-settings? + any/c) + (ls) + @{Extracts the settings field of a language-settings.}) + + (proc-doc/names + drscheme:language-configuration:language-settings-language + (drscheme:language-configuration:language-settings? + . -> . + (or/c (is-a?/c drscheme:language:language<%>) drscheme:language:object/c)) + (ls) + + @{Extracts the language field of a language-settings.}) + + (proc-doc/names + drscheme:language-configuration:language-settings? + (any/c . -> . boolean?) + (val) + + @{Determines if the argument is a language-settings or not.}) + + (proc-doc/names + drscheme:language-configuration:language-dialog + (->* (boolean? drscheme:language-configuration:language-settings?) + ((or/c false/c (is-a?/c top-level-window<%>))) + (or/c false/c drscheme:language-configuration:language-settings?)) + ((show-welcome? language-settings-to-show) + ((parent #t))) + @{Opens the language configuration dialog. + See also + @scheme[drscheme:language-configuration:fill-language-dialog]. + + The @scheme[show-welcome?] argument determines if + if a ``Welcome to DrScheme'' message and some + natural language buttons are shown. + + The @scheme[language-settings-to-show] argument + must be some default language settings that the dialog + is initialized to. + If unsure of a default, the currently set language + in the user's preferences can be obtained via: + @schemeblock[ + (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol)) + ] + + The @scheme[parent] argument is used as the parent + to the dialog. + + The result if @scheme[#f] when the user cancells the dialog, and + the selected language if they hit ok.}) + + (proc-doc/names + drscheme:language-configuration:fill-language-dialog + (->* + ((is-a?/c vertical-panel%) + (is-a?/c area-container<%>) + drscheme:language-configuration:language-settings?) + ((or/c false/c (is-a?/c top-level-window<%>)) + (-> symbol? void?)) + drscheme:language-configuration:language-settings?) + ((panel button-panel language-setting) + ((re-center #f) + (ok-handler void))) + @{This procedure accepts two parent panels and + fills them with the contents of the language dialog. + It is used to include language configuration controls + in some larger context in another dialog. + + The @scheme[panel] argument is the main panel where the + language controls will be placed. + The function adds buttons to the @scheme[button-panel] + to revert a language to its default settings and to + show the details of a language. + + The @scheme[language-setting] is the default + language to show in the dialog. + + The @scheme[re-center] argument is used when the @onscreen{Show Details} + button is clicked. If that argument is a @scheme[top-level-window<%>], + the @onscreen{Show Details} callback will recenter the window each time + it is clicked. Otherwise, the argument is not used. + + @scheme[ok-handler] is a function that is in charge of interfacing the OK + button. It should accept a symbol message: @scheme['enable] and + @scheme['disable] to toggle the button, and @scheme['execute] to run + the desired operation. (The language selection dialog also uses an + internal @scheme['enable-sync] message.)}) + + (proc-doc + drscheme:language:register-capability + (->d ([s symbol?] + [the-contract contract?] + [default the-contract]) + () + [res void?]) + @{Registers a new capability with a default value for each language + and a contract on the values the capability might have. + + By default, these capabilities are registered as DrScheme starts up: + @itemize{ + @item{ @scheme[(drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t)] + --- controls the visiblity of the check syntax button + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:language-menu-title (flat-contract string?) (string-constant scheme-menu-name))] + --- controls the name of the menu just to the right of the language menu (defaultly named ``Scheme'') + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:define-popup (or/c (cons/c string? string?) false/c) (cons "(define" "(define ...)"))] + --- specifies the prefix that the define popup should look for and what label it should have, + or @scheme[#f] if it should not appear at all. + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)] + --- determines if the insert fraction menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)] + --- determines if the insert lambda menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)] + --- determines if the insert large letters menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)] + --- determines if the insert image menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)] + --- determines if the insert comment box menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t)] + --- determines if the insert gui menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:slideshow-menu-item (flat-contract boolean?) #t)] + --- determines if the insert pict box menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:insert-text-box (flat-contract boolean?) #t)] + --- determines if the insert text box menu item in the special menu is visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t)] + --- determines if the insert scheme box, insert scheme splice box, and the insert xml box menu item ins the special menu are visible + }@item{ @scheme[(drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '())] + --- determines the list of words that are used when completing words in this language + }}}) + + (proc-doc/names + drscheme:language:capability-registered? + (-> symbol? boolean?) + (s) + @{Indicates if + @scheme[drscheme:language:register-capability] + has been called with @scheme[s].}) + (proc-doc + drscheme:language:get-capability-default + (->d ([s (and/c symbol? drscheme:language:capability-registered?)]) + () + [res (drscheme:language:get-capability-contract s)]) + @{Returns the default for a particular capability.}) + (proc-doc/names + drscheme:language:get-capability-contract + (-> (and/c symbol? drscheme:language:capability-registered?) + contract?) + (s) + @{Returns the contract for a given capability, which was specified + when @scheme[drscheme:langauge:register-capability] was called.}) + + + ; + ; + ; + ; ; + ; ; + ; ; + ; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; + ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; + ; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; + ; ; ; + ; ; ; ; ; + ; ;;;; ;;;; + + + (proc-doc/names + drscheme:language:add-snip-value + (->* ((-> any/c boolean?) + (-> any/c (is-a?/c snip%))) + ((-> any/c)) + void?) + ((test-value convert-value) + ((setup-thunk void))) + @{Registers a handler to convert values into snips as they are printed in the REPL. + + The @scheme[test-snip] argument is called to determine if this handler can convert the value + and the @scheme[convert-value] argument is called to build a snip. + The (optional) @scheme[setup-thunk] is called just after the user's namespace and other + setings are built, but before any of the user's code is evaluated. + + All three functions are called on the user's thread and with the user's settings.}) + + (proc-doc/names + drscheme:language:extend-language-interface + (-> interface? + (make-mixin-contract drscheme:language:language<%>) + void?) + (interface default-implementation) + + @{@phase[1] + + Each language added passed to + @scheme[drscheme:language-configuration:add-language] + must implement @scheme[interface]. + + The @scheme[default-implementation] is a mixin + that provides a default implementation of + @scheme[interface]. Languages that are unaware of + the specifics of @scheme[extension] use + @scheme[default-implementation] via + @scheme[drscheme:language:get-default-mixin].}) + + (proc-doc + drscheme:language:get-default-mixin + (-> (make-mixin-contract drscheme:language:language<%>)) + + @{@phase[2] + + The result of this function is the composite of all of the + @scheme[default-implementation] arguments passed + to + @scheme[drscheme:language:extend-language-interface].}) + + (proc-doc/names + drscheme:language:get-language-extensions + (-> (listof interface?)) + () + @{@phase[2] + + Returns a list of the interfaces passed to + @scheme[drscheme:language:extend-language-interface].}) + + (proc-doc/names + drscheme:language:put-executable + ((is-a?/c top-level-window<%>) + path? + (or/c boolean? (symbols 'launcher 'standalone 'distribution)) + boolean? + string? + . -> . (or/c false/c path?)) + (parent program-filename mode mred? title) + @{Calls the MrEd primitive + @scheme[put-file] + with arguments appropriate for creating an executable + from the file @scheme[program-filename]. + + The arguments @scheme[mred?] and @scheme[mode] indicates + what type of executable this should be (and the dialog + may be slightly different on some platforms, depending + on these arguments). For historical reasons, @scheme[#f] + is allowed for @scheme[mode] as an alias for @scheme['launcher], and + @scheme[#t] is allowed for @scheme[mode] as an alias for @scheme['stand-alone]. + + The @scheme[title] argument is used as the title to the primitive + @scheme[put-file] + or + @scheme[get-directory] + primitive.}) + + (proc-doc/names + drscheme:language:create-executable-gui + ((or/c false/c (is-a?/c top-level-window<%>)) + (or/c false/c string?) + (or/c (λ (x) (eq? x #t)) (symbols 'launcher 'standalone 'distribution)) + (or/c (λ (x) (eq? x #t)) (symbols 'mzscheme 'mred)) + . -> . + (or/c false/c + (list/c (symbols 'no-show 'launcher 'stand-alone 'distribution) + (symbols 'no-show 'mred 'mzscheme) + string?))) + (parent program-name show-type show-base) + @{Opens a dialog to prompt the user about their choice of executable. + If @scheme[show-type] is @scheme[#t], the user is prompted about + a choice of executable: stand-alone, + launcher, or distribution; otherwise, the symbol determines the type. + If @scheme[show-base] + is @scheme[#t], the user is prompted about a choice of base + binary: mzscheme or mred; otherwise the symbol determines the base. + + The @scheme[program-name] argument is used to construct the default + executable name in a platform-specific manner. + + The @scheme[parent] argument is used for the parent of the dialog. + + The result of this function is @scheme[#f] if the user cancel's + the dialog and a list of three items indicating what options + they chose. If either @scheme[show-type] or @scheme[show-base] + was not @scheme[#t], the corresponding result will be @scheme['no-show], + otherwise it will indicate the user's choice.}) + + (proc-doc/names + drscheme:language:create-module-based-stand-alone-executable + ((or/c path? string?) + (or/c path? string?) any/c any/c any/c boolean? boolean? + . -> . + void?) + (program-filename + executable-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + + @{This procedure creates a stand-alone executable in the file + @scheme[executable-filename] that runs the program + @scheme[program-filename]. + + The arguments + @scheme[module-language-spec] and + @scheme[transformer-module-language-spec] specify the + settings of the initial namespace, both the transformer + portion and the regular portion. Both may be @scheme[#f] + to indicate there are no initial bindings. + + The @scheme[init-code] argument is an s-expression representing + the code for a module. This module is expected to provide + the identifer @scheme[init-code], bound to a procedure of no + arguments. That module is required and the @scheme[init-code] + procedure is executed to initialize language-specific + settings before the code in @scheme[program-filename] runs. + + The @scheme[gui?] argument indicates if a MrEd or MzScheme + stand-alone executable is created. + + The @scheme[use-copy?] argument indicates if the initial + namespace should be populated with + @scheme[namespace-require/copy] or + @scheme[namespace-require]. }) + + (proc-doc/names + drscheme:language:create-module-based-distribution + ((or/c path? string?) + (or/c path? string?) any/c any/c any/c boolean? boolean? + . -> . + void?) + (program-filename + distribution-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + + @{Like + @scheme[drscheme:language:create-module-based-stand-alone-executable], but packages the stand-alone executable into a distribution.}) + + (proc-doc/names + drscheme:language:create-distribution-for-executable + ((or/c path? string?) + boolean? + (-> path? void?) + . -> . + void?) + (distribution-filename + gui? + make-executable) + + @{Creates a distribution where the given @scheme[make-executable] procedure + creates the stand-alone executable to be distributed. + The @scheme[make-executable] procedure is given the name of the + executable to create. The @scheme[gui?] argument is needed in case the + executable's name (which @scheme[drscheme:language:create-distribution-for-executable] + must generate) depends on the type of executable. During the distribution-making + process, a progress dialog is shown to the user, and the user can click an + @onscreen{Abort} button that sends a break to the current thread.}) + + (proc-doc/names + drscheme:language:create-module-based-launcher + ((or/c path? string?) (or/c path? string?) any/c any/c any/c boolean? boolean? + . -> . + void?) + (program-filename + executable-filename + module-language-spec + transformer-module-language-spec + init-code + gui? + use-copy?) + + @{This procedure is identical to + @scheme[drscheme:language:create-module-based-stand-alone-executable], except that it creates a launcher instead of a + stand-alone executable.}) + + (proc-doc/names + drscheme:language:text/pos-text + (drscheme:language:text/pos? . -> . (is-a?/c text%)) + (text/pos) + + @{Selects the @scheme[text%] from a text/pos.}) + + (proc-doc/names + drscheme:language:text/pos-start + (drscheme:language:text/pos? . -> . number?) + (text/pos) + + @{Selects the starting position from a text/pos.}) + + (proc-doc/names + drscheme:language:text/pos-end + (drscheme:language:text/pos? . -> . number?) + (text/pos) + + @{Selects the ending position from a text/pos.}) + + (proc-doc/names + drscheme:language:text/pos? + (any/c . -> . boolean?) + (val) + + @{Returns @scheme[#t] if @scheme[val] is a text/pos, and @scheme[#f] + otherwise.}) + + (proc-doc/names + drscheme:language:make-text/pos + ((is-a?/c text%) number? number? + . -> . + drscheme:language:text/pos?) + (text start end) + + @{Constructs a text/pos.}) + + (proc-doc/names + drscheme:language:simple-settings-case-sensitive + (drscheme:language:simple-settings? . -> . boolean?) + (simple-settings) + + @{Extracts the case-sensitive setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings-printing-style + (drscheme:language:simple-settings? + . -> . + (symbols 'constructor 'quasiquote 'write)) + (simple-settings) + + @{Extracts the printing-style setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings-fraction-style + (drscheme:language:simple-settings? + . -> . + (symbols 'mixed-fraction + 'mixed-fraction-e + 'repeating-decimal + 'repeating-decimal-e)) + (simple-settings) + + @{Extracts the fraction-style setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings-show-sharing + (drscheme:language:simple-settings? + . -> . + boolean?) + (simple-settings) + + @{Extracts the show-sharing setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings-insert-newlines + (drscheme:language:simple-settings? + . -> . + boolean?) + (simple-settings) + + @{Extracts the insert-newline setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings-annotations + (drscheme:language:simple-settings? + . -> . + (symbols 'none 'debug 'debug/profile 'test-coverage)) + (simple-settings) + + @{Extracts the debugging setting from a simple-settings.}) + + (proc-doc/names + drscheme:language:simple-settings? + (any/c . -> . boolean?) + (val) + + @{Determines if @scheme[val] is a simple-settings.}) + + (proc-doc/names + drscheme:language:make-simple-settings + (-> boolean? + (symbols 'constructor 'quasiquote 'write) + (symbols 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e) + boolean? + boolean? + (symbols 'none 'debug 'debug/profile 'test-coverage) + drscheme:language:simple-settings?) + (case-sensitive + printing-style + fraction-style + show-sharing + insert-newlines + annotations) + + @{Constructs a simple settings.}) + + (proc-doc/names + drscheme:language:simple-settings->vector + (drscheme:language:simple-settings? . -> . vector?) + (simple-settings) + + @{Constructs a vector whose elements are the fields of @scheme[simple-settings].})) diff --git a/collects/drscheme/tool.ss b/collects/drscheme/tool.ss new file mode 100644 index 0000000000..7fd1b8188c --- /dev/null +++ b/collects/drscheme/tool.ss @@ -0,0 +1,4 @@ +(module tool mzscheme + (require "private/drsig.ss") + (provide drscheme:tool^ + drscheme:tool-exports^))