diff --git a/collects/drscheme/acks.ss b/collects/drscheme/acks.ss deleted file mode 100644 index fecf97b005..0000000000 --- a/collects/drscheme/acks.ss +++ /dev/null @@ -1,82 +0,0 @@ -(module acks mzscheme - (provide get-general-acks - get-translating-acks - get-authors) - - (define (get-authors) - (get-general-acks)) - - (define (get-general-acks) - (string-append - "The following individuals contributed to the implementation" - " and documentation of PLT Scheme: " - "Yavuz Arkun, " - "Ian Barland, " - "Eli Barzilay, " - "Gann Bierner, " - "Filipe Cabecinhas, " - "Richard Cleis, " - "John Clements, " - "Richard Cobbe, " - "Greg Cooper, " - "Ryan Culpepper, " - "Carl Eastlund, " - "Moy Easwaran, " - "Will Farr, " - "Matthias Felleisen, " - "Robby Findler, " - "Kathi Fisler, " - "Cormac Flanagan, " - "Matthew Flatt, " - "Sebastian Good, " - "Paul Graunke, " - "Kathy Gray, " - "Dan Grossman, " - "Dave Gurnell, " - "Bruce Hauman, " - "Dave Herman, " - "Mark Krentel, " - "Shriram Krishnamurthi, " - "Mario Latendresse, " - "Guillaume Marceau, " - "Jacob Matthews, " - "Jay McCarthy, " - "Philippe Meunier, " - "Scott Owens, " - "Jamie Raymond, " - "Grant Rettke, " - "Paul Schlie, " - "Dorai Sitaram, " - "Mike Sperber, " - "Paul Steckler, " - "Jens Axel Søgaard, " - "Francisco Solsona, " - "Sam Tobin-Hochstadt, " - "Neil W. Van Dyke, " - "David Van Horn, " - "Anton van Straaten, " - "Dale Vaillancourt, " - "Dimitris Vyzovitis, " - "Stephanie Weirich, " - "Noel Welsh, " - "Adam Wick, " - "Danny Yoo, " - "and " - "ChongKai Zhu.")) - - (define (get-translating-acks) - (string-append - "Thanks to " - "ChongKai Zhu, " - "Ian Barland, " - "Biep Durieux, " - "Tim Hanson, " - "Chihiro Kuraya, " - "Philippe Meunier, " - "Jens Axel Søgaard, " - "Francisco Solsona, " - "Mike Sperber, " - "Reini Urban, " - "and " - "Paolo Zoppetti " - "for their help translating DrScheme's GUI to other languages."))) diff --git a/collects/drscheme/arrow.ss b/collects/drscheme/arrow.ss deleted file mode 100644 index 64501ef4ee..0000000000 --- a/collects/drscheme/arrow.ss +++ /dev/null @@ -1,195 +0,0 @@ - -(module arrow mzscheme - (require mzlib/class - mzlib/list - mzlib/math - mred) - - (provide draw-arrow) - - (define largest 16383) - (define smallest -16383) - - (define arrow-head-angle (/ pi 8)) - (define cos-arrow-head-angle (cos arrow-head-angle)) - (define sin-arrow-head-angle (sin arrow-head-angle)) - - (define arrow-head-size 8) - (define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle)) - (define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle)) - - (define arrow-root-radius 2.5) - (define arrow-root-diameter (* 2 arrow-root-radius)) - - ; If alpha is the angle between the x axis and the Start->End vector: - ; - ; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle) - ; = end-x - arrow-head-size * cos(alpha - arrow-head-angle) - ; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle)) - ; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha - ; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha - ; - ; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle) - ; = end-y - arrow-head-size * sin(alpha - arrow-head-angle) - ; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle)) - ; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha - ; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha - ; - ; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle) - ; = end-x - arrow-head-size * cos(alpha + arrow-head-angle) - ; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle)) - ; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha - ; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha - ; - ; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle) - ; = end-y - arrow-head-size * sin(alpha + arrow-head-angle) - ; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle)) - ; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha - ; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha - - ; dc<%> real real real real real real -> void - ; draw one arrow - ; The reason of the "-0.5" in the definition of start-x and end-x in the let - ; right below is because, well, after numerous experiments done under carefully - ; controlled conditions by a team of independent experts, it was thought to - ; be The Right Thing for the arrows to be drawn correctly, maybe. - (define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy) - (let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)] - [uncropped-start-y (+ uncropped-pre-start-y dy)] - [uncropped-end-x (+ uncropped-pre-end-x dx -0.5)] - [uncropped-end-y (+ uncropped-pre-end-y dy)] - [old-smoothed (send dc get-smoothing)]) - (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)] - [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)]) - (send dc set-smoothing 'aligned) - (send dc draw-line start-x start-y end-x end-y) - (when (and (< smallest start-x largest) - (< smallest end-x largest)) - (send dc draw-ellipse - (- start-x arrow-root-radius) (- start-y arrow-root-radius) - arrow-root-diameter arrow-root-diameter)) - (when (and (< smallest end-x largest) - (< smallest end-y largest)) - (unless (and (= start-x end-x) (= start-y end-y)) - (let* ([offset-x (- end-x start-x)] - [offset-y (- end-y start-y)] - [arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))] - [cos-alpha (/ offset-x arrow-length)] - [sin-alpha (/ offset-y arrow-length)] - [arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)] - [arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)] - [arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)] - [arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)] - ; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1 - [pt1 (make-object point% end-x end-y)] - [pt2 (make-object point% - (- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha) - (+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))] - [pt3 (make-object point% - (+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha) - (- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))]) - (send dc draw-polygon (list pt1 pt2 pt3))))) - (send dc set-smoothing old-smoothed)))) - - ;; crop-to : number number number number -> (values number number) - ;; returns x,y if they are in the range defined by largest and smallest - ;; otherwise returns the coordinates on the line from x,y to ox,oy - ;; that are closest to x,y and are in the range specified by - ;; largest and smallest - (define (crop-to x y ox oy) - (cond - [(and (< smallest x largest) (< smallest y largest)) - (values x y)] - [else - (let* ([xy-pr (cons x y)] - [left-i (find-intersection x y ox oy smallest smallest smallest largest)] - [top-i (find-intersection x y ox oy smallest smallest largest smallest)] - [right-i (find-intersection x y ox oy largest smallest largest largest)] - [bottom-i (find-intersection x y ox oy smallest largest largest largest)] - [d-top (and top-i (dist top-i xy-pr))] - [d-bottom (and bottom-i (dist bottom-i xy-pr))] - [d-left (and left-i (dist left-i xy-pr))] - [d-right (and right-i (dist right-i xy-pr))]) - (cond - [(smallest? d-top d-bottom d-left d-right) - (values (car top-i) (cdr top-i))] - [(smallest? d-bottom d-top d-left d-right) - (values (car bottom-i) (cdr bottom-i))] - [(smallest? d-left d-top d-bottom d-right) - (values (car left-i) (cdr left-i))] - [(smallest? d-right d-top d-bottom d-left) - (values (car right-i) (cdr right-i))] - [else - ;; uh oh... if this case happens, that's bad news... - (values x y)]))])) - - ;; smallest? : (union #f number)^4 -> boolean - ;; returns #t if can is less and o1, o2, and o3 - ;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them - (define (smallest? can o1 o2 o3) - (and can - (andmap (λ (x) (< can x)) - (filter (λ (x) x) - (list o1 o2 o3))))) - - - ;; inside? : (union #f (cons number number)) -> (union #f (cons number number)) - ;; returns the original pair if the coordinates are between smallest and largest - ;; and returns #f if the pair is #f or the coordinates are outside. - (define (inside? pr) - (and pr - (let ([x (car pr)] - [y (cdr pr)]) - (if (and (< smallest x largest) - (< smallest y largest)) - pr - #f)))) - - ;; find-intersection : (number^2)^2 -> (union (cons number number) #f) - ;; finds the intersection between the lines specified by - ;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4) - (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4) - (cond - [(and (= x1 x2) (= x3 x4)) - #f] - [(and (= x1 x2) (not (= x3 x4))) - (let* ([m2 (/ (- y3 y4) (- x3 x4))] - [b2 (- y3 (* m2 x3))]) - (cons x1 - (+ (* m2 x1) b2)))] - [(and (not (= x1 x2)) (= x3 x4)) - (let* ([m1 (/ (- y1 y2) (- x1 x2))] - [b1 (- y1 (* m1 x1))]) - (cons x3 - (+ (* m1 x3) b1)))] - [(and (not (= x1 x2)) (not (= x3 x4))) - (let* ([m1 (/ (- y1 y2) (- x1 x2))] - [b1 (- y1 (* m1 x1))] - [m2 (/ (- y3 y4) (- x3 x4))] - [b2 (- y3 (* m2 x3))]) - (if (= m1 m2) - #f - (let* ([x (/ (- b1 b2) (- m2 m1))] - [y (+ (* m1 x) b1)]) - (cons x y))))])) - - ;; dist : (cons number number) (cons number number) -> number - (define (dist p1 p2) - (sqrt (+ (sqr (- (car p1) (car p2))) - (sqr (- (cdr p1) (cdr p2)))))) - - ;; localled defined test code.... :( - ;; use module language to run tests - (define (tests) - (and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f) - (equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0)) - (equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0)) - (equal? (find-intersection 0 0 3 3 2 2 4 4) #f) - (equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0)) - (equal? (smallest? 3 1 2 3) #f) - (equal? (smallest? 0 1 2 3) #t) - (equal? (smallest? 1 0 2 3) #f) - (equal? (smallest? 1 0 #f 4) #f) - (equal? (smallest? 1 #f #f 4) #t) - (equal? (smallest? 1 #f #f #f) #t) - (equal? (dist (cons 1 1) (cons 4 5)) 5)))) diff --git a/collects/drscheme/default-code-style.ss b/collects/drscheme/default-code-style.ss deleted file mode 100644 index b4ea007e2d..0000000000 --- a/collects/drscheme/default-code-style.ss +++ /dev/null @@ -1,27 +0,0 @@ -(module default-code-style mzscheme - (provide color-default-code-styles - bw-default-code-styles - code-style-color - code-style-slant? - code-style-bold? - code-style-underline?) - - (define-struct code-style (color slant? bold? underline?)) - ;; code-style = (make-code-style (union (list number number number) string) bolean boolean) - - ;; bw-default-code-styles : (listof (list symbol code-style - (define bw-default-code-styles - (list (list 'lexically-bound-variable (make-code-style "black" #f #f #t)) - (list 'lexically-bound-syntax (make-code-style "black" #f #f #t)) - (list 'imported-variable (make-code-style "black" #f #f #t)) - (list 'imported-syntax (make-code-style "black" #f #f #t)) - (list 'unbound-variable (make-code-style "black" #t #f #f)) - (list 'constant (make-code-style '(51 135 39) #f #f #f)))) - - ;; color-default-code-styles : (listof (list symbol code-style)) - (define color-default-code-styles - (list (list 'keyword (make-code-style '(40 25 15) #f #f #f)) - (list 'unbound-variable (make-code-style "red" #f #f #f)) - (list 'bound-variable (make-code-style "navy" #f #f #f)) - (list 'primitive (make-code-style "navy" #f #f #f)) - (list 'constant (make-code-style '(51 135 39) #f #f #f))))) diff --git a/collects/drscheme/doc.icns b/collects/drscheme/doc.icns deleted file mode 100644 index 7d726a4974..0000000000 Binary files a/collects/drscheme/doc.icns and /dev/null differ diff --git a/collects/drscheme/drscheme.creator b/collects/drscheme/drscheme.creator deleted file mode 100644 index 8e31ad43ae..0000000000 --- a/collects/drscheme/drscheme.creator +++ /dev/null @@ -1,2 +0,0 @@ -DrSc -(This code is registered with Apple.) diff --git a/collects/drscheme/drscheme.filetypes b/collects/drscheme/drscheme.filetypes deleted file mode 100644 index c833614f95..0000000000 --- a/collects/drscheme/drscheme.filetypes +++ /dev/null @@ -1,20 +0,0 @@ -((("CFBundleTypeName" - "Scheme Source") - ("CFBundleTypeIconFile" - "doc") - ("CFBundleTypeRole" - "Editor") - ("CFBundleTypeOSTypes" - (array "TEXT" "WXME")) - ("CFBundleTypeExtensions" - (array "scm" "ss"))) - (("CFBundleTypeName" - "Package") - ("CFBundleTypeIconFile" - "pltdoc") - ("CFBundleTypeRole" - "Viewer") - ("CFBundleTypeOSTypes" - (array "PLT_" "WXME")) - ("CFBundleTypeExtensions" - (array "plt")))) diff --git a/collects/drscheme/drscheme.ss b/collects/drscheme/drscheme.ss deleted file mode 100644 index fedf1a14d5..0000000000 --- a/collects/drscheme/drscheme.ss +++ /dev/null @@ -1,47 +0,0 @@ -(module drscheme mzscheme - (require "private/key.ss") - - (define debugging? (getenv "PLTDRDEBUG")) - - (define install-cm? (and (not debugging?) - (getenv "PLTDRCM"))) - - (define cm-trace? (or (equal? (getenv "PLTDRCM") "trace") - (equal? (getenv "PLTDRDEBUG") "trace"))) - - (when debugging? - (printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n") - (let-values ([(zo-compile - make-compilation-manager-load/use-compiled-handler - manager-trace-handler) - (parameterize ([current-namespace (make-namespace)] - [use-compiled-file-paths '()]) - (values - (dynamic-require '(lib "zo-compile.ss" "errortrace") 'zo-compile) - (dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler) - (dynamic-require 'mzlib/cm 'manager-trace-handler)))]) - (current-compile zo-compile) - (use-compiled-file-paths (list (build-path "compiled" "errortrace"))) - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (error-display-handler (dynamic-require '(lib "errortrace-lib.ss" "errortrace") - 'errortrace-error-display-handler)) - (when cm-trace? - (printf "PLTDRDEBUG: enabling CM tracing\n") - (manager-trace-handler - (λ (x) (display "1: ") (display x) (newline)))))) - - (when install-cm? - (printf "PLTDRCM: installing compilation manager\n") - (let-values ([(make-compilation-manager-load/use-compiled-handler - manager-trace-handler) - (parameterize ([current-namespace (make-namespace)]) - (values - (dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler) - (dynamic-require 'mzlib/cm 'manager-trace-handler)))]) - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (when cm-trace? - (printf "PLTDRCM: enabling CM tracing\n") - (manager-trace-handler - (λ (x) (display "1: ") (display x) (newline)))))) - - (dynamic-require 'drscheme/private/drscheme-normal #f)) diff --git a/collects/drscheme/drscheme.utiexports b/collects/drscheme/drscheme.utiexports deleted file mode 100644 index 7d0c93b5ea..0000000000 --- a/collects/drscheme/drscheme.utiexports +++ /dev/null @@ -1,15 +0,0 @@ -((("UTTypeConformsTo" - (array - "public.text" - "public.plain-text")) - ("UTTypeDescription" - "PLT Scheme program source") - ("UTTypeIdentifier" - "org.plt-scheme.source") - ("UTTypeTagSpecification" - (dict - (assoc-pair "com.apple.ostype" - "TEXT") - (assoc-pair "public.filename-extension" - (array "ss" - "scm")))))) diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss deleted file mode 100644 index 9f6556b3cd..0000000000 --- a/collects/drscheme/info.ss +++ /dev/null @@ -1,6 +0,0 @@ -#lang setup/infotab - -(define tools (list "syncheck.ss" (list "time-keystrokes.ss" "private"))) -(define tool-names (list "Check Syntax" "Time Keystrokes")) -(define mred-launcher-names (list "DrScheme")) -(define mred-launcher-libraries (list "drscheme.ss")) diff --git a/collects/drscheme/installer.ss b/collects/drscheme/installer.ss deleted file mode 100644 index 79c6c2883f..0000000000 --- a/collects/drscheme/installer.ss +++ /dev/null @@ -1,21 +0,0 @@ -(module installer mzscheme - (require mzlib/file - mzlib/etc - launcher) - (provide installer) - - (define (installer plthome) - (do-installation) - (set! do-installation void)) - - (define (do-installation) - (for-each install-variation (available-mred-variants))) - - (define (install-variation variant) - (parameterize ([current-launcher-variant variant]) - (make-mred-launcher - (list "-ZmvqL" "drscheme.ss" "drscheme") - (mred-program-launcher-path "DrScheme") - (cons - `(exe-name . "DrScheme") - (build-aux-from-path (build-path (collection-path "drscheme") "drscheme"))))))) diff --git a/collects/drscheme/main.ss b/collects/drscheme/main.ss deleted file mode 100644 index f5202c93ea..0000000000 --- a/collects/drscheme/main.ss +++ /dev/null @@ -1,2 +0,0 @@ -(module main scheme/base - (require "drscheme.ss")) diff --git a/collects/drscheme/pltdoc.icns b/collects/drscheme/pltdoc.icns deleted file mode 100644 index c90a814c94..0000000000 Binary files a/collects/drscheme/pltdoc.icns and /dev/null differ diff --git a/collects/drscheme/private/app.ss b/collects/drscheme/private/app.ss deleted file mode 100644 index 818d068dc6..0000000000 --- a/collects/drscheme/private/app.ss +++ /dev/null @@ -1,420 +0,0 @@ -#lang scheme/unit - -(require mzlib/class - mzlib/list - scheme/file - string-constants - mred - framework - (lib "external.ss" "browser") - (lib "getinfo.ss" "setup") - "drsig.ss" - "../acks.ss") - -(import [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix help-desk: drscheme:help-desk^] - [prefix drscheme:tools: drscheme:tools^]) -(export drscheme:app^) - -(define about-frame% - (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) - (init-field main-text) - (define/private (edit-menu:do const) - (send main-text do-edit-operation const)) - [define/override file-menu:create-revert? (λ () #f)] - [define/override file-menu:create-save? (λ () #f)] - [define/override file-menu:create-save-as? (λ () #f)] - [define/override file-menu:between-close-and-quit (λ (x) (void))] - [define/override edit-menu:between-redo-and-cut (λ (x) (void))] - [define/override edit-menu:between-select-all-and-find (λ (x) (void))] - [define/override edit-menu:copy-callback (λ (menu evt) (edit-menu:do 'copy))] - [define/override edit-menu:select-all-callback (λ (menu evt) (edit-menu:do 'select-all))] - [define/override edit-menu:create-find? (λ () #f)] - (super-new - (label (string-constant about-drscheme-frame-title))))) - - -(define (same-widths items) - (let ([max-width (apply max (map (λ (x) (send x get-width)) items))]) - (for-each (λ (x) (send x min-width max-width)) items))) - -(define (same-heights items) - (let ([max-height (apply max (map (λ (x) (send x get-height)) items))]) - (for-each (λ (x) (send x min-height max-height)) items))) - -(define wrap-edit% - (class text:hide-caret/selection% - (inherit begin-edit-sequence end-edit-sequence - get-max-width find-snip position-location) - (define/augment (on-set-size-constraint) - (begin-edit-sequence) - (let ([snip (find-snip 1 'after-or-none)]) - (when (is-a? snip editor-snip%) - (send (send snip get-editor) begin-edit-sequence))) - (inner (void) on-set-size-constraint)) - (define/augment (after-set-size-constraint) - (inner (void) after-set-size-constraint) - (let ([width (get-max-width)] - [snip (find-snip 1 'after-or-none)]) - (when (is-a? snip editor-snip%) - (let ([b (box 0)]) - (position-location 1 b #f #f #t) - (let ([new-width (- width 4 (unbox b))]) - (when (> new-width 0) - (send snip resize new-width - 17) ; smallest random number - (send snip set-max-height 'none)))) - (send (send snip get-editor) end-edit-sequence))) - (end-edit-sequence)) - (super-new))) - -(define (get-plt-bitmap) - (make-object bitmap% - (build-path (collection-path "icons") - (if (< (get-display-depth) 8) - "pltbw.gif" - "PLT-206.png")))) - - - - - - -; -; -; -; ; ; -; ; ; -; ; ; ; -; ;;; ; ;;; ;;;; ; ; ;;;; ;;; ; ; ;; ;;;; -; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;;; ; ; ; ; ; ; ; ; ; ; ;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; -; ;;;;; ; ;;; ;;;; ;;; ; ;; ;;; ; ; ;;;; -; -; -; - - -(define (about-drscheme) - (let* ([e (make-object wrap-edit%)] - [main-text (make-object wrap-edit%)] - [plt-bitmap (get-plt-bitmap)] - [plt-icon (if (send plt-bitmap ok?) - (make-object image-snip% plt-bitmap) - (let ([i (make-object string-snip%)] - [label "[lambda]"]) - (send i insert label (string-length label) 0) - i))] - [editor-snip (make-object editor-snip% e #f)] - [f (make-object about-frame% main-text)] - [main-panel (send f get-area-container)] - [editor-canvas (make-object editor-canvas% main-panel)] - [button-panel (make-object horizontal-panel% main-panel)] - [top (make-object style-delta% 'change-alignment 'top)] - [d-usual (make-object style-delta% 'change-family 'decorative)] - [d-dr (make-object style-delta%)] - [d-http (make-object style-delta%)] - - [insert/clickback - (λ (str clickback) - (send e change-style d-http) - (let* ([before (send e get-start-position)] - [_ (send e insert str)] - [after (send e get-start-position)]) - (send e set-clickback before after - (λ (a b c) (clickback)) - d-http)) - (send e change-style d-usual))] - - [insert-url/external-browser - (λ (str url) - (insert/clickback str (λ () (send-url url))))]) - - (send* d-http - (copy d-usual) - (set-delta-foreground "BLUE") - (set-delta 'change-underline #t)) - (send* d-usual - (set-delta-foreground "BLACK") - (set-delta 'change-underline #f)) - - (send* d-dr (copy d-usual) (set-delta 'change-bold)) - (send d-usual set-weight-on 'normal) - (send* editor-canvas - (set-editor main-text) - (stretchable-width #t) - (stretchable-height #t)) - - (if (send plt-bitmap ok?) - (send* editor-canvas - (min-width (floor (+ (* 5/2 (send plt-bitmap get-width)) 50))) - (min-height (+ (send plt-bitmap get-height) 50))) - (send* editor-canvas - (min-width 500) - (min-height 400))) - - (send* e - (change-style d-dr) - (insert (format (string-constant welcome-to-drscheme-version/language) - (version:version) - (this-language))) - (change-style d-usual)) - - (send e insert " by ") - - (insert-url/external-browser "PLT" "http://www.plt-scheme.org/") - - (send* e - (insert ".\n\n") - (insert (get-authors)) - (insert "\n\nFor licensing information see ")) - - (insert/clickback "our software license" - (λ () (help-desk:goto-plt-license))) - - (send* e - (insert ".\n\nBased on:\n ") - (insert (banner))) - - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (send* e - (insert " The A List (c) 1997-2001 Kyle Hammond\n"))) - - (let ([tools (sort (drscheme:tools:get-successful-tools) - (lambda (a b) - (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 deleted file mode 100644 index d0cc135c12..0000000000 --- a/collects/drscheme/private/auto-language.ss +++ /dev/null @@ -1,62 +0,0 @@ -(module auto-language mzscheme - (require mred - mzlib/class) - - (provide pick-new-language looks-like-module?) - - (define reader-tag "#reader") - - (define (pick-new-language text all-languages module-language module-language-settings) - (with-handlers ([exn:fail:read? (λ (x) (values #f #f))]) - (let ([found-language? #f] - [settings #f]) - - (for-each - (λ (lang) - (let ([lang-spec (send lang get-reader-module)]) - (when lang-spec - (let* ([lines (send lang get-metadata-lines)] - [str (send text get-text - 0 - (send text paragraph-end-position (- lines 1)))] - [sp (open-input-string str)]) - (when (regexp-match #rx"#reader" sp) - (let ([spec-in-file (read sp)]) - (when (equal? lang-spec spec-in-file) - (set! found-language? lang) - (set! settings (send lang metadata->settings str)) - (send text while-unlocked - (λ () - (send text delete 0 (send text paragraph-start-position lines))))))))))) - all-languages) - - ;; check to see if it looks like the module language. - (unless found-language? - (when module-language - (when (looks-like-module? text) - (set! found-language? module-language) - (set! settings module-language-settings)))) - - (values found-language? - settings)))) - - (define (looks-like-module? text) - (or (looks-like-new-module-style? text) - (looks-like-old-module-style? text))) - - (define (looks-like-old-module-style? text) - (with-handlers ((exn:fail:read? (λ (x) #f))) - (let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)] - [r1 (parameterize ([read-accept-reader #f]) (read tp))] - [r2 (parameterize ([read-accept-reader #f]) (read tp))]) - (and (eof-object? r2) - (pair? r1) - (eq? (car r1) 'module))))) - - (define (looks-like-new-module-style? text) - (let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)] - [l1 (with-handlers ([exn:fail? (lambda (exn) eof)]) - ;; If tp contains a snip, read-line fails. - (read-line tp))]) - (and (string? l1) - (regexp-match #rx"#lang .*$" l1))))) diff --git a/collects/drscheme/private/bindings-browser.ss b/collects/drscheme/private/bindings-browser.ss deleted file mode 100644 index aea142053f..0000000000 --- a/collects/drscheme/private/bindings-browser.ss +++ /dev/null @@ -1,305 +0,0 @@ -#| - -CODE COPIED (with permission ...) from syntax-browser.ss -desperately seeking abstraction. - -Marshalling (and hence the 'read' method of the snipclass omitted for fast prototyping - -|# - -(module bindings-browser mzscheme - (require mzlib/pretty - mzlib/list - mzlib/class - mred - mzlib/match - mzlib/string - (lib "marks.ss" "stepper" "private") - mzlib/contract) - - (provide render-bindings/snip) - - (define (render-bindings/snip stx) (make-object bindings-snip% stx)) - - (define bindings-snipclass% - (class snip-class% - - ; not overriding read - (super-instantiate ()))) - - (define bindings-snipclass (make-object bindings-snipclass%)) - (send bindings-snipclass set-version 1) - (send bindings-snipclass set-classname "drscheme:bindings-snipclass%") - (send (get-the-snip-class-list) add bindings-snipclass) - - (define bindings-snip% - (class editor-snip% - (init-field bindings) - - (unless ((flat-contract-predicate (listof (list/c syntax? any/c))) bindings) - (error 'bindings-snip% "expected bindings association list, given ~v" bindings)) - - (define/public (get-bindings) bindings) - - (define/override (copy) (make-object bindings-snip% bindings)) - (define/override (write stream) - (error 'bindings-snip "'write' not implemented for bindings-snip")) - - (define output-text (make-object text%)) - (define output-port (make-text-port output-text)) - - (define/private (make-modern text) - (send text change-style - (make-object style-delta% 'change-family 'modern) - 0 - (send text last-position))) - - (begin (parameterize ([current-output-port output-port] - [pretty-print-columns 30]) - (for-each - (λ (binding-pair) - (let* ([stx (car binding-pair)] - [value (cadr binding-pair)]) - ; this totally destroys the 'output-port' abstraction. I don't know - ; how to enrich the notion of an output-port to get 'bold'ing to - ; work otherwise... - (let* ([before (send output-text last-position)]) - (pretty-print (syntax-object->datum stx)) - (let* ([post-newline (send output-text last-position)]) - (send output-text delete post-newline) ; delete the trailing \n. yuck! - (send output-text insert " ") - (send output-text change-style - (make-object style-delta% 'change-bold) - before (- post-newline 1))) - (pretty-print value)))) - bindings)) - (send output-text delete (send output-text last-position)) ; delete final trailing \n - (make-modern output-text)) - - (define outer-t (make-object text%)) - - (super-new - (editor outer-t) - (with-border? #f) - (left-margin 3) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 1) - (top-inset 0) - (right-inset 0) - (bottom-inset 0)) - - (define inner-t (make-object text%)) - (define inner-es (instantiate editor-snip% () - (editor inner-t) - (with-border? #f) - (left-margin 0) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 0) - (top-inset 0) - (right-inset 0) - (bottom-inset 0))) - - (define details-shown? #t) - - (inherit show-border set-tight-text-fit) - (define/private (hide-details) - (when details-shown? - (send outer-t lock #f) - (show-border #f) - (set-tight-text-fit #t) - (send outer-t release-snip inner-es) - (send outer-t delete (send outer-t last-position)) - (send outer-t lock #t) - (set! details-shown? #f))) - - (define/private (show-details) - (unless details-shown? - (send outer-t lock #f) - (show-border #t) - (set-tight-text-fit #f) - (send outer-t insert #\newline - (send outer-t last-position) - (send outer-t last-position)) - (send outer-t insert inner-es - (send outer-t last-position) - (send outer-t last-position)) - (send outer-t lock #t) - (set! details-shown? #t))) - - (send outer-t insert (make-object turn-snip% - (λ () (hide-details)) - (λ () (show-details)))) - (send outer-t insert (format "bindings\n")) - (send outer-t insert inner-es) - (make-modern outer-t) - - (send inner-t insert (instantiate editor-snip% () - (editor output-text) - (with-border? #f) - (left-margin 0) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 0) - (top-inset 0) - (right-inset 0) - (bottom-inset 0))) - (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2) - - (send output-text hide-caret #t) - (send inner-t hide-caret #t) - (send outer-t hide-caret #t) - (send output-text lock #t) - (send inner-t lock #t) - (send outer-t lock #t) - - (hide-details) - - (inherit set-snipclass) - (set-snipclass bindings-snipclass))) - - (define black-style-delta (make-object style-delta% 'change-normal-color)) - (define green-style-delta (make-object style-delta%)) - (send green-style-delta set-delta-foreground "forest green") - - (define turn-snip% - (class snip% - - (init-field on-up on-down) - - ;; state : (union 'up 'down 'up-click 'down-click)) - (init-field [state 'up]) - - (define/override (copy) - (instantiate turn-snip% () - (on-up on-up) - (on-down on-down) - (state state))) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (let ([bitmap (case state - [(up) up-bitmap] - [(down) down-bitmap] - [(up-click) up-click-bitmap] - [(down-click) down-click-bitmap])]) - (cond - [(send bitmap ok?) - (send dc draw-bitmap bitmap x y)] - [(send dc draw-rectangle x y 10 10) - (send dc drawline x y 10 10)]))) - - - (define/override (get-extent dc x y w h descent space lspace rspace) - (set-box/f! descent 0) - (set-box/f! space 0) - (set-box/f! lspace 0) - (set-box/f! rspace 0) - (set-box/f! w arrow-snip-width) - (set-box/f! h arrow-snip-height)) - - (define/override (on-event dc x y editorx editory evt) - (let ([snip-evt-x (- (send evt get-x) x)] - [snip-evt-y (- (send evt get-y) y)]) - (cond - [(send evt button-down? 'left) - (set-state (case state - [(up) 'up-click] - [(down) 'down-click] - [else 'down-click]))] - [(and (send evt button-up? 'left) - (<= 0 snip-evt-x arrow-snip-width) - (<= 0 snip-evt-y arrow-snip-height)) - (set-state (case state - [(up up-click) - (on-down) - 'down] - [(down down-click) - (on-up) - 'up] - [else 'down]))] - [(send evt button-up? 'left) - (set-state (case state - [(up up-click) 'up] - [(down down-click) 'down] - [else 'up]))] - [(and (send evt get-left-down) - (send evt dragging?) - (<= 0 snip-evt-x arrow-snip-width) - (<= 0 snip-evt-y arrow-snip-height)) - (set-state (case state - [(up up-click) 'up-click] - [(down down-click) 'down-click] - [else 'up-click]))] - [(and (send evt get-left-down) - (send evt dragging?)) - (set-state (case state - [(up up-click) 'up] - [(down down-click) 'down] - [else 'up-click]))] - [else - (super on-event dc x y editorx editory evt)]))) - - (inherit get-admin) - (define/private (set-state new-state) - (unless (eq? state new-state) - (set! state new-state) - (let ([admin (get-admin)]) - (when admin - (send admin needs-update this 0 0 arrow-snip-width arrow-snip-height))))) - - (define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor) - - (super-instantiate ()) - - (inherit get-flags set-flags) - (set-flags (cons 'handles-events (get-flags))))) - - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - - (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png"))) - (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png"))) - (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png"))) - (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png"))) - (define arrow-snip-height - (max 10 - (send up-bitmap get-height) - (send down-bitmap get-height) - (send up-click-bitmap get-height) - (send down-click-bitmap get-height))) - (define arrow-snip-width - (max 10 - (send up-bitmap get-width) - (send down-bitmap get-width) - (send up-click-bitmap get-width) - (send down-click-bitmap get-width))) - (define arrow-snip-cursor (make-object cursor% 'arrow)) - - ;; make-text-port : text -> port - ;; builds a port from a text object. - (define (make-text-port text) - (make-output-port #f - always-evt - (λ (s start end flush?) - (send text insert (substring s start end) - (send text last-position) - (send text last-position)) - (- end start)) - void))) - -; one trivial test case: -; -;(require bindings-browser) -; -;(let ([es (render-bindings/snip `((,#`a 3) (,#`b 4) (,#`c (1 3 4))))]) -; (define f (make-object frame% "frame" #f 850 500)) -; (define mb (make-object menu-bar% f)) -; (define edit-menu (make-object menu% "Edit" mb)) -; (define t (make-object text%)) -; (define ec (make-object editor-canvas% f t)) -; (append-editor-operation-menu-items edit-menu) -; (send t insert es) -; (send f show #t)) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss deleted file mode 100644 index 3fca8ff589..0000000000 --- a/collects/drscheme/private/debug.ss +++ /dev/null @@ -1,2005 +0,0 @@ -#| - -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 deleted file mode 100644 index be42f76008..0000000000 --- a/collects/drscheme/private/drscheme-normal.ss +++ /dev/null @@ -1,280 +0,0 @@ - -(module drscheme-normal mzscheme - (require mred - mzlib/class - mzlib/cmdline - (lib "bday.ss" "framework" "private")) - - ; (current-load text-editor-load-handler) - - (define files-to-open - (command-line - (case (system-type) - [(windows) "DrScheme.exe"] - [(macosx) "drscheme" #;"DrScheme"] - [else "drscheme"]) - (current-command-line-arguments) - (args filenames filenames))) - - (define icons-bitmap - (let ([icons (collection-path "icons")]) - (lambda (name) - (make-object bitmap% (build-path icons name))))) - - ;; updates the command-line-arguments with only the files - ;; to open. See also main.ss. - (current-command-line-arguments (apply vector files-to-open)) - - (define-values (texas-independence-day? halloween?) - (let* ([date (seconds->date (current-seconds))] - [month (date-month date)] - [day (date-day date)]) - (values (and (= 3 month) (= 2 day)) - (and (= 10 month) (= 31 day))))) - - (define high-color? ((get-display-depth) . > . 8)) - (define special-state #f) - (define normal-bitmap #f) ; set by load-magic-images - - (define-struct magic-image (chars filename bitmap)) - - (define (magic-img str img) - (make-magic-image (reverse (string->list str)) img #f)) - - ;; magic strings and their associated images. There should not be a string - ;; in this list that is a prefix of another. - (define magic-images - (list (magic-img "larval" "PLT-206-larval.png") - (magic-img "mars" "PLT-206-mars.jpg"))) - - (define (load-magic-images) - (set! load-magic-images void) ; run only once - (unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png"))) - (for-each (λ (magic-image) - (unless (magic-image-bitmap magic-image) - (set-magic-image-bitmap! - magic-image - (icons-bitmap (magic-image-filename magic-image))))) - magic-images)) - - (define longest-magic-string - (apply max (map (λ (s) (length (magic-image-chars s))) magic-images))) - - (define key-codes null) - - (define (find-magic-image) - (define (prefix? l1 l2) - (or (null? l1) - (and (pair? l2) - (eq? (car l1) (car l2)) - (prefix? (cdr l1) (cdr l2))))) - (ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i)) - magic-images)) - - (define (add-key-code new-code) - (set! key-codes - (cons - new-code - (let loop ([n (- longest-magic-string 2)] [l key-codes]) - (cond [(null? l) null] - [(zero? n) null] - [else (let ([p (loop (sub1 n) (cdr l))]) - (if (eq? p (cdr l)) - l - (cons (car l) p)))]))))) - - (let ([set-splash-bitmap - (dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)]) - ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer) - (λ (evt) - (let ([ch (send evt get-key-code)]) - (when (char? ch) - ;; as soon as something is typed, load the bitmaps - (load-magic-images) - (add-key-code ch) - (let ([match (find-magic-image)]) - (when match - (set! key-codes null) - (set-splash-bitmap - (if (eq? special-state match) - (begin (set! special-state #f) normal-bitmap) - (begin (set! special-state match) - (magic-image-bitmap match))))))))))) - - (when (eb-bday?) - (let () - (define main-size 260) - (define pi (atan 0 -1)) - - (define eli (icons-bitmap "eli-purple.jpg")) - (define bitmap (make-object bitmap% main-size main-size)) - (define bdc (make-object bitmap-dc% bitmap)) - - (define outer-color (send the-color-database find-color "darkorange")) - (define inner-color (send the-color-database find-color "green")) - (define omega-str "(λ (x) (x x)) (λ (x) (x x)) ") - (define hebrew-str " ףוס ןיא ףוס ןיא") - - (define (draw-letter dc cx cy angle radius letter color) - (let ([x (+ cx (* (cos angle) radius))] - [y (- cy (* (sin angle) radius))]) - (send bdc set-text-foreground color) - (send dc draw-text letter x y #f 0 (- angle (/ pi 2))))) - - (define (draw-single-loop str dc offset cx cy radius font-size color) - (send dc set-font (send the-font-list find-or-create-font font-size 'modern)) - (let loop ([i (string-length str)]) - (unless (zero? i) - (draw-letter dc - cx - cy - (normalize-angle - (+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str)))) - (/ pi 2) - offset)) - radius - (string (string-ref str (- i 1))) - color) - (loop (- i 1))))) - - (define (normalize-angle angle) - (cond - [(<= 0 angle (* 2 pi)) angle] - [(< angle 0) (normalize-angle (+ angle (* 2 pi)))] - [else (normalize-angle (- angle (* 2 pi)))])) - - (define splash-canvas ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-canvas))) - (define (draw-single-step dc offset) - (send bdc draw-bitmap eli 0 0) - (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color) - (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color) - (send splash-canvas on-paint)) - - (define gc-b - (with-handlers ([exn:fail? (lambda (x) - (printf "~s\n" (exn-message x)) - #f)]) - (let ([b (icons-bitmap "recycle.gif")]) - (cond - [(send b ok?) - (let ([gbdc (make-object bitmap-dc% b)] - [ebdc (make-object bitmap-dc% eli)] - [color1 (make-object color%)] - [color2 (make-object color%)] - [avg (lambda (x y) (floor (* (/ x 255) y)))] - [ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))] - [oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))]) - (let loop ([i (send b get-width)]) - (unless (zero? i) - (let loop ([j (send b get-height)]) - (unless (zero? j) - (let ([x (- i 1)] - [y (- j 1)]) - (send gbdc get-pixel x y color1) - (send ebdc get-pixel (+ x ox) (+ y oy) color2) - (send color1 set - (avg (send color1 red) (send color2 red)) - (avg (send color1 green) (send color2 green)) - (avg (send color1 blue) (send color2 blue))) - (send gbdc set-pixel x y color1) - (loop (- j 1))))) - (loop (- i 1)))) - (send gbdc set-bitmap #f) - (send ebdc set-bitmap #f) - b)] - [else #f])))) - - - (define (eli-paint dc) - (send dc draw-bitmap bitmap 0 0)) - (define (eli-event evt) - (cond - [(send evt leaving?) - ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) orig-paint) - (when gc-b - (unregister-collecting-blit splash-canvas)) - (send splash-canvas refresh) - (when draw-thread - (kill-thread draw-thread) - (set! draw-thread #f))] - [(send evt entering?) - ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-paint-callback) eli-paint) - (when gc-b - (register-collecting-blit splash-canvas - (floor (- (/ main-size 2) - (/ (send gc-b get-width) 2))) - (floor (- (/ main-size 2) - (/ (send gc-b get-height) 2))) - (send gc-b get-width) - (send gc-b get-height) - gc-b gc-b)) - (send splash-canvas refresh) - (unless draw-thread - (start-thread))])) - - (define splash-eventspace ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-eventspace))) - (define draw-next-state - (let ([o 0]) - (lambda () - (let ([s (make-semaphore 0)]) - (parameterize ([current-eventspace splash-eventspace]) - (queue-callback - (λ () - (draw-single-step bdc o) - (semaphore-post s)))) - (semaphore-wait s)) - (let ([next (+ o (/ pi 60))]) - (set! o (if (< next (* 2 pi)) - next - (- next (* 2 pi)))))))) - - (define draw-thread #f) - (define (start-thread) - (set! draw-thread - (thread - (λ () - (let loop () - (draw-next-state) - (sleep .01) - (loop)))))) - (define orig-paint ((dynamic-require '(lib "splash.ss" "framework") 'get-splash-paint-callback))) - - (draw-next-state) - ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-event-callback) eli-event) - (send splash-canvas refresh))) - - ((dynamic-require '(lib "splash.ss" "framework") 'start-splash) - (build-path (collection-path "icons") - (cond - [texas-independence-day? - "texas-plt-bw.gif"] - [(and halloween? high-color?) - "PLT-pumpkin.png"] - [high-color? "PLT-206.png"] - [(= (get-display-depth) 1) - "pltbw.gif"] - [else - "plt-flat.gif"])) - "DrScheme" - 99) - - (when (getenv "PLTDRBREAK") - (printf "PLTDRBREAK: creating break frame\n") - (let ([to-break (eventspace-handler-thread (current-eventspace))]) - (parameterize ([current-eventspace (make-eventspace)]) - (let* ([f (new frame% (label "Break DrScheme"))] - [b (new button% - (label "Break Main Thread") - (callback - (λ (x y) - (break-thread to-break))) - (parent f))] - [b (new button% - (label "Break All Threads") - (callback - (λ (x y) - ((dynamic-require '(lib "key.ss" "drscheme" "private") 'break-threads)))) - (parent f))]) - (send f show #t))))) - - (dynamic-require '(lib "tool-lib.ss" "drscheme") #f)) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss deleted file mode 100644 index 53fb85803a..0000000000 --- a/collects/drscheme/private/drsig.ss +++ /dev/null @@ -1,316 +0,0 @@ - -(module drsig scheme/base - (require scheme/unit) - - (provide drscheme:eval^ - drscheme:debug^ - drscheme:module-language^ - drscheme:get-collection^ - drscheme:main^ - drscheme:init^ - drscheme:language-configuration^ - drscheme:language-configuration/internal^ - drscheme:tools^ - drscheme:get/extend^ - drscheme:unit^ - drscheme:frame^ - drscheme:program^ - drscheme:text^ - drscheme:rep^ - drscheme:app^ - drscheme:draw-arrow^ - drscheme:help-desk^ - drscheme:language^ - drscheme:multi-file-search^ - drscheme:module-overview^ - drscheme:font^ - drscheme:modes^ - drscheme:tool-exports^ - drscheme:tool^ - drscheme:tool-cm^) - - (define-signature drscheme:modes-cm^ - ()) - (define-signature drscheme:modes^ extends drscheme:modes-cm^ - (add-mode - get-modes - add-initial-modes - (struct mode (name surrogate repl-submit matches-language) - #:omit-constructor))) - - (define-signature drscheme:font-cm^ - ()) - (define-signature drscheme:font^ extends drscheme:font-cm^ - (setup-preferences)) - - (define-signature drscheme:debug-cm^ - (profile-definitions-text-mixin - profile-tab-mixin - profile-unit-frame-mixin - test-coverage-interactions-text-mixin - test-coverage-definitions-text-mixin - test-coverage-tab-mixin)) - (define-signature drscheme:debug^ extends drscheme:debug-cm^ - (make-debug-error-display-handler - make-debug-eval-handler - error-display-handler/stacktrace - - test-coverage-enabled - profiling-enabled - - add-prefs-panel - - get-error-color - - hide-backtrace-window - show-backtrace-window - open-and-highlight-in-file - get-cm-key - - ;show-error-and-highlight - ;print-bug-to-stderr - ;display-srclocs-in-error - ;show-syntax-error-context - )) - - (define-signature drscheme:module-langauge-cm^ - (module-language<%>)) - (define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ - (add-module-language - module-language-put-file-mixin)) - - (define-signature drscheme:get-collection-cm^ ()) - (define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^ - (get-file/collection)) - - (define-signature drscheme:main-cm^ ()) - (define-signature drscheme:main^ extends drscheme:main-cm^ ()) - - (define-signature drscheme:init-cm^ - ()) - (define-signature drscheme:init^ extends drscheme:init-cm^ - (original-output-port - original-error-port - original-error-display-handler - primitive-eval - primitive-load - error-display-handler-message-box-title - system-custodian - system-eventspace - system-namespace - first-dir)) - - (define-signature drscheme:language-configuration-cm^ - ()) - (define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^ - (add-language - get-languages - (struct language-settings (language settings)) - get-settings-preferences-symbol - language-dialog - fill-language-dialog)) - - (define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^ - (add-info-specified-languages - get-default-language-settings - settings-preferences-symbol - get-all-scheme-manual-keywords - add-built-in-languages - not-a-language-language<%>)) - - (define-signature drscheme:tools-cm^ - ()) - (define-signature drscheme:tools^ extends drscheme:tools-cm^ - ((struct successful-tool (spec bitmap name url)) - get-successful-tools - only-in-phase - load/invoke-all-tools - add-prefs-panel)) - - (define-signature drscheme:get/extend-cm^ - ()) - (define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^ - (extend-tab - extend-interactions-text - extend-definitions-text - extend-interactions-canvas - extend-definitions-canvas - extend-unit-frame - get-tab - get-interactions-text - get-definitions-text - get-interactions-canvas - get-definitions-canvas - get-unit-frame)) - - (define-signature drscheme:unit-cm^ - (tab% - tab<%> - frame% - frame<%> - definitions-canvas% - get-definitions-text% - definitions-text<%> - interactions-canvas%)) - (define-signature drscheme:unit^ extends drscheme:unit-cm^ - (open-drscheme-window - find-symbol - get-program-editor-mixin - add-to-program-editor-mixin - (struct teachpack-callbacks (get-names remove add)))) - - (define-signature drscheme:frame-cm^ - (<%> - mixin - basics-mixin - basics<%>)) - (define-signature drscheme:frame^ extends drscheme:frame-cm^ - (create-root-menubar - add-keybindings-item - planet-spec?)) - - (define-signature drscheme:program-cm^ - (frame%)) - (define-signature drscheme:program^ extends drscheme:program-cm^ - ()) - - (define-signature drscheme:eval-cm^ - ()) - (define-signature drscheme:eval^ extends drscheme:eval-cm^ - (expand-program - expand-program/multiple - traverse-program/multiple - build-user-eventspace/custodian - set-basic-parameters - get-snip-classes)) - - (define-signature drscheme:text-cm^ - (text<%> - text%)) - (define-signature drscheme:text^ extends drscheme:text-cm^ - ()) - - (define-signature drscheme:setup-cm^ - ()) - (define-signature drscheme:setup^ extends drscheme:setup-cm^ - (do-setup)) - - (define-signature drscheme:rep-cm^ - (drs-bindings-keymap-mixin - text% - text<%> - context<%>)) - (define-signature drscheme:rep^ extends drscheme:rep-cm^ - (current-rep - current-language-settings - current-value-port - get-drs-bindings-keymap - error-delta - get-welcome-delta - get-dark-green-delta - drs-autocomplete-mixin)) - - (define-signature drscheme:app-cm^ - ()) - (define-signature drscheme:app^ extends drscheme:app-cm^ - (about-drscheme - add-language-items-to-help-menu - add-important-urls-to-help-menu - switch-language-to)) - - (define-signature drscheme:draw-arrow-cm^ - ()) - (define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^ - (draw-arrow)) - - (define-signature drscheme:help-desk-cm^ - ()) - (define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^ - (help-desk - goto-plt-license - get-docs)) - - (define-signature drscheme:language-cm^ - (language<%> - module-based-language<%> - simple-module-based-language<%> - simple-module-based-language% - simple-module-based-language->module-based-language-mixin - module-based-language->language-mixin)) - (define-signature drscheme:language^ extends drscheme:language-cm^ - (get-default-mixin - extend-language-interface - get-language-extensions - - create-module-based-launcher - create-module-based-stand-alone-executable - create-module-based-distribution - - create-distribution-for-executable - - create-executable-gui - put-executable - - ;(struct loc (source position line column span)) - - (struct text/pos (text start end)) - (struct simple-settings (case-sensitive - printing-style - fraction-style - show-sharing - insert-newlines - annotations)) - simple-settings->vector - - simple-module-based-language-config-panel - - add-snip-value - setup-setup-values - - register-capability - capability-registered? - get-capability-default - get-capability-contract)) - - (define-signature drscheme:multi-file-search-cm^ - ()) - (define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^ - (multi-file-search)) - - (define-signature drscheme:module-overview-cm^ - ()) - (define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^ - (module-overview - make-module-overview-pasteboard - fill-pasteboard)) - - (define-signature drscheme:tool-exports-cm^ - ()) - (define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^ - (phase1 - phase2)) - - (define-signature drscheme:tool-cm^ - ((open (prefix drscheme:debug: drscheme:debug-cm^)) - (open (prefix drscheme:unit: drscheme:unit-cm^)) - (open (prefix drscheme:rep: drscheme:rep-cm^)) - (open (prefix drscheme:frame: drscheme:frame-cm^)) - (open (prefix drscheme:get/extend: drscheme:get/extend-cm^)) - (open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^)) - (open (prefix drscheme:language: drscheme:language-cm^)) - (open (prefix drscheme:help-desk: drscheme:help-desk-cm^)) - (open (prefix drscheme:eval: drscheme:eval-cm^)) - (open (prefix drscheme:modes: drscheme:modes-cm^)))) - - (define-signature drscheme:tool^ - ((open (prefix drscheme:debug: drscheme:debug^)) - (open (prefix drscheme:unit: drscheme:unit^)) - (open (prefix drscheme:rep: drscheme:rep^)) - (open (prefix drscheme:frame: drscheme:frame^)) - (open (prefix drscheme:get/extend: drscheme:get/extend^)) - (open (prefix drscheme:language-configuration: drscheme:language-configuration^)) - (open (prefix drscheme:language: drscheme:language^)) - (open (prefix drscheme:help-desk: drscheme:help-desk^)) - (open (prefix drscheme:eval: drscheme:eval^)) - (open (prefix drscheme:modes: drscheme:modes^))))) - diff --git a/collects/drscheme/private/eval.ss b/collects/drscheme/private/eval.ss deleted file mode 100644 index 87b5ad3f6e..0000000000 --- a/collects/drscheme/private/eval.ss +++ /dev/null @@ -1,221 +0,0 @@ - -(module eval mzscheme - (require mred - mzlib/unit - mzlib/port - mzlib/class - syntax/toplevel - framework - "drsig.ss") - - ;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace - ;; these things are for effect only! - (require (lib "cache-image-snip.ss" "mrlib") - #; - (prefix foo htdp/matrix)) - - (define op (current-output-port)) - (define (oprintf . args) (apply fprintf op args)) - - (provide eval@) - (define-unit eval@ - (import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:init: drscheme:init^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:unit: drscheme:unit^]) - (export drscheme:eval^) - - (define (traverse-program/multiple language-settings - init - kill-termination) - (let-values ([(eventspace custodian) - (build-user-eventspace/custodian - language-settings - init - kill-termination)]) - (let ([language (drscheme:language-configuration:language-settings-language - language-settings)] - [settings (drscheme:language-configuration:language-settings-settings - language-settings)]) - (λ (input iter complete-program?) - (let-values ([(port src) - (cond - [(input-port? input) (values input #f)] - [else (values - (let* ([text (drscheme:language:text/pos-text input)] - [start (drscheme:language:text/pos-start input)] - [end (drscheme:language:text/pos-end input)] - [text-port (open-input-text-editor text start end values - (send text get-port-name))]) - (port-count-lines! text-port) - (let* ([line (send text position-paragraph start)] - [column (- start (send text paragraph-start-position line))] - [relocated-port (relocate-input-port text-port - (+ line 1) - column - (+ start 1))]) - (port-count-lines! relocated-port) - relocated-port)) - (drscheme:language:text/pos-text input))])]) - (parameterize ([current-eventspace eventspace]) - (queue-callback - (λ () - (let ([read-thnk - (if complete-program? - (send language front-end/complete-program port settings) - (send language front-end/interaction port settings))]) - (let loop () - (let ([in (read-thnk)]) - (cond - [(eof-object? in) - (iter in (λ () (void)))] - [else - (iter in (λ () (loop)))])))))))))))) - - (define (expand-program/multiple language-settings - eval-compile-time-part? - init - kill-termination) - (let ([res (traverse-program/multiple language-settings init kill-termination)]) - (λ (input iter complete-program?) - (let ([expanding-iter - (λ (rd cont) - (cond - [(eof-object? rd) (iter rd cont)] - [eval-compile-time-part? - (iter (expand-top-level-with-compile-time-evals rd) cont)] - [else (iter (expand rd) cont)]))]) - (res input - expanding-iter - complete-program?))))) - - (define (expand-program input - language-settings - eval-compile-time-part? - init - kill-termination - iter) - ((expand-program/multiple - language-settings - eval-compile-time-part? - init - kill-termination) - input - iter - #t)) - - - (define (build-user-eventspace/custodian language-settings init kill-termination) - (let* ([user-custodian (make-custodian)] - [eventspace (parameterize ([current-custodian user-custodian]) - (make-eventspace))] - [language (drscheme:language-configuration:language-settings-language - language-settings)] - [settings (drscheme:language-configuration:language-settings-settings - language-settings)] - [eventspace-main-thread #f] - [run-in-eventspace - (λ (thnk) - (parameterize ([current-eventspace eventspace]) - (let ([sema (make-semaphore 0)] - [ans #f]) - (queue-callback - (λ () - (let/ec k - (parameterize ([error-escape-handler - (let ([drscheme-expand-program-error-escape-handler - (λ () (k (void)))]) - drscheme-expand-program-error-escape-handler)]) - (set! ans (thnk)))) - (semaphore-post sema))) - (semaphore-wait sema) - ans)))] - [drs-snip-classes (get-snip-classes)]) - (run-in-eventspace - (λ () - (current-custodian user-custodian) - (set-basic-parameters drs-snip-classes) - (drscheme:rep:current-language-settings language-settings))) - (send language on-execute settings run-in-eventspace) - (run-in-eventspace - (λ () - (set! eventspace-main-thread (current-thread)) - (init) - (break-enabled #t))) - (thread - (λ () - (thread-wait eventspace-main-thread) - (kill-termination))) - (values eventspace user-custodian))) - - ;; get-snip-classes : -> (listof snipclass) - ;; returns a list of the snip classes in the current eventspace - (define (get-snip-classes) - (let loop ([n (send (get-the-snip-class-list) number)]) - (if (zero? n) - null - (cons (send (get-the-snip-class-list) nth (- n 1)) - (loop (- n 1)))))) - - ;; set-basic-parameters : (listof (is-a/c? snipclass%)) -> void - ;; sets the parameters that are shared between the repl's initialization - ;; and expand-program - (define (set-basic-parameters snip-classes) - (for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class)) - snip-classes) - - (current-thread-group (make-thread-group)) - (current-command-line-arguments #()) - (current-pseudo-random-generator (make-pseudo-random-generator)) - (current-evt-pseudo-random-generator (make-pseudo-random-generator)) - (read-curly-brace-as-paren #t) - (read-square-bracket-as-paren #t) - (error-print-width 250) - (current-ps-setup (make-object ps-setup%)) - - (current-namespace (make-namespace 'empty)) - (for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x)) - to-be-copied-module-names)) - - ;; these module specs are copied over to each new user's namespace - (define to-be-copied-module-specs - (list 'mzscheme - '(lib "mzlib/foreign.ss") - '(lib "mred/mred.ss") - '(lib "mrlib/cache-image-snip.ss") - '(lib "mrlib/matrix-snip.ss") - '(lib "mzlib/pconvert-prop.ss"))) - - ;; ensure that they are all here. - (for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs) - ;; get the names of those modules. - (define to-be-copied-module-names - (let ([get-name - (λ (spec) - (if (symbol? spec) - spec - ((current-module-name-resolver) spec #f #f)))]) - (map get-name to-be-copied-module-specs))) - - ;; build-input-port : string[file-exists?] -> (values input any) - ;; constructs an input port for the load handler. Also - ;; returns a value representing the source of code read from the file. - (define (build-input-port filename) - (let* ([p (open-input-file filename)] - [chars (list (read-char p) - (read-char p) - (read-char p) - (read-char p))]) - (close-input-port p) - (cond - [(equal? chars (string->list "WXME")) - (let ([text (make-object text%)]) - (send text load-file filename) - (let ([port (open-input-text-editor text)]) - (port-count-lines! port) - (values port text)))] - [else - (let ([port (open-input-file filename)]) - (port-count-lines! port) - (values port filename))]))))) diff --git a/collects/drscheme/private/font.ss b/collects/drscheme/private/font.ss deleted file mode 100644 index 6fe8d85e8d..0000000000 --- a/collects/drscheme/private/font.ss +++ /dev/null @@ -1,218 +0,0 @@ -(module font mzscheme - (require mzlib/unit - mzlib/class - "drsig.ss" - mred - framework - string-constants) - - (define sc-smoothing-label (string-constant font-smoothing-label)) - (define sc-smoothing-none (string-constant font-smoothing-none)) - (define sc-smoothing-some (string-constant font-smoothing-some)) - (define sc-smoothing-all (string-constant font-smoothing-all)) - (define sc-smoothing-default (string-constant font-smoothing-default)) - - (provide font@) - - (define-unit font@ - (import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]) - (export drscheme:font^) - - (define (setup-preferences) - (preferences:add-panel - (list (string-constant font-prefs-panel-title) - #;(string-constant drscheme)) ;; thre is no help desk font configuration anymore ... - (λ (panel) - (letrec ([main (make-object vertical-panel% panel)] - [min-size 1] - [max-size 72] - [options-panel (make-object horizontal-panel% main)] - [size-panel (new group-box-panel% - (parent options-panel) - (label (string-constant font-size)))] - [adjust-font-size - (λ (f) - (preferences:set - 'framework:standard-style-list:font-size - (f (preferences:get - 'framework:standard-style-list:font-size))))] - [size-slider - (new slider% - (label #f) - (min-value min-size) - (max-value max-size) - (parent size-panel) - (callback - (λ (size evt) - (adjust-font-size - (λ (old-size) - (send size get-value))))) - (init-value - (preferences:get 'framework:standard-style-list:font-size)))] - [size-hp (new horizontal-pane% (parent size-panel))] - [mk-size-button - (λ (label chng) - (new button% - (parent size-hp) - (stretchable-width #t) - (callback - (λ (x y) - (adjust-font-size - (λ (old-size) - (min max-size (max min-size (chng old-size))))))) - (label label)))] - [size-sub1 (mk-size-button "-1" sub1)] - [size-add1 (mk-size-button "+1" add1)] - - [mono-list 'mono-list-not-yet-computed] - [choice-panel - (new (class vertical-panel% - (define/private (force-cache receiver) - (when (eq? receiver font-name-control) - (when (symbol? mono-list) - (begin-busy-cursor) - (set! mono-list (get-face-list 'mono)) - (send font-name-control clear) - (for-each - (λ (x) (send font-name-control append x)) - (append mono-list (list (string-constant other...)))) - (let ([pref (preferences:get 'framework:standard-style-list:font-name)]) - (cond - [(member pref mono-list) - (send font-name-control set-string-selection pref)] - [else - (send font-name-control set-selection (length mono-list))])) - (end-busy-cursor)))) - (define/override (on-subwindow-event receiver evt) - (unless (or (send evt moving?) - (send evt entering?) - (send evt leaving?)) - (force-cache receiver)) - (super on-subwindow-event receiver evt)) - (define/override (on-subwindow-char receiver evt) - (force-cache receiver) - (super on-subwindow-char receiver evt)) - (super-new [parent options-panel])))] - [font-name-control - (let* ([choice - (new choice% - (label (string-constant font-name)) - (choices (list (preferences:get 'framework:standard-style-list:font-name))) - (parent choice-panel) - (stretchable-width #t) - (callback - (λ (font-name evt) - (let ([selection (send font-name get-selection)]) - (cond - [(< selection (length mono-list)) - (preferences:set - 'framework:standard-style-list:font-name - (list-ref mono-list selection))] - [else - (let* ([all-faces (get-face-list)] - [init-choices - (let ([init (preferences:get 'framework:standard-style-list:font-name)]) - (let loop ([faces all-faces] - [num 0]) - (cond - [(null? faces) null] - [else - (let ([face (car faces)]) - (if (equal? init face) - (list num) - (loop (cdr faces) - (+ num 1))))])))] - [choice (get-choices-from-user - (string-constant select-font-name) - (string-constant select-font-name) - all-faces - #f - init-choices)]) - (when choice - (preferences:set - 'framework:standard-style-list:font-name - (list-ref all-faces (car choice)))))])))))] - [font-name (preferences:get 'framework:standard-style-list:font-name)] - [set-choice-selection - (λ (font-name) - (cond - [(send choice find-string font-name) - (send choice set-string-selection font-name)] - [else - (send choice set-selection (- (send choice get-number) 1))]))]) - - (preferences:add-callback - 'framework:standard-style-list:font-name - (λ (p v) - (set-choice-selection v))) - (set-choice-selection font-name) - choice)] - [smoothing-contol - (new choice% - (label sc-smoothing-label) - (choices (list sc-smoothing-none - sc-smoothing-some - sc-smoothing-all - sc-smoothing-default)) - (parent choice-panel) - (stretchable-width #t) - (selection (case (preferences:get 'framework:standard-style-list:smoothing) - [(unsmoothed) 0] - [(partly-smoothed) 1] - [(smoothed) 2] - [(default) 3])) - (callback (λ (x y) - (preferences:set - 'framework:standard-style-list:smoothing - (case (send x get-selection) - [(0) 'unsmoothed] - [(1) 'partly-smoothed] - [(2) 'smoothed] - [(3) 'default])))))] - - [text (make-object (text:foreground-color-mixin - (editor:standard-style-list-mixin - text:basic%)))] - [ex-panel (make-object horizontal-panel% main)] - [msg (make-object message% (string-constant example-text) ex-panel)] - [canvas (make-object canvas:color% main text)] - [update-text - (λ (setting) - (send text begin-edit-sequence) - (send text lock #f) - (send text erase) - (send text insert - (format - ";; howmany : list-of-numbers -> number~ - \n;; to determine how many numbers are in `a-lon'~ - \n(define (howmany a-lon)~ - \n (cond~ - \n [(empty? a-lon) 0]~ - \n [else (+ 1 (howmany (rest a-lon)))]))~ - \n~ - \n;; examples as tests~ - \n(howmany empty)~ - \n\"should be\"~ - \n0~ - \n~ - \n(howmany (cons 1 (cons 2 (cons 3 empty))))~ - \n\"should be\"~ - \n3")) - (send text set-position 0 0) - (send text lock #t) - (send text end-edit-sequence))]) - (preferences:add-callback - 'framework:standard-style-list:font-size - (λ (p v) (send size-slider set-value v))) - (preferences:add-callback - drscheme:language-configuration:settings-preferences-symbol - (λ (p v) - (update-text v))) - (update-text (preferences:get drscheme:language-configuration:settings-preferences-symbol)) - (send ex-panel set-alignment 'left 'center) - (send ex-panel stretchable-height #f) - (send canvas allow-tab-exit #t) - (send options-panel stretchable-height #f) - (send options-panel set-alignment 'center 'top) - (send text lock #t) - main)))))) diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss deleted file mode 100644 index 12b55a20ee..0000000000 --- a/collects/drscheme/private/frame.ss +++ /dev/null @@ -1,595 +0,0 @@ - -#lang scheme/unit - (require string-constants - mzlib/match - mzlib/class - mzlib/string - mzlib/list - "drsig.ss" - mred - framework - net/url - net/head - (lib "plt-installer.ss" "setup") - (lib "bug-report.ss" "help") - scheme/file) - - (import [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:app: drscheme:app^] - [prefix help: drscheme:help-desk^] - [prefix drscheme:multi-file-search: drscheme:multi-file-search^] - [prefix drscheme:init: drscheme:init^]) - (export (rename drscheme:frame^ - [-mixin mixin])) - - (define basics<%> (interface (frame:standard-menus<%>))) - - (define last-keybindings-planet-attempt "") - - (define basics-mixin - (mixin (frame:standard-menus<%>) (basics<%>) - (inherit get-edit-target-window get-edit-target-object get-menu-bar) - (define/private (get-menu-bindings) - (let ([name-ht (make-hasheq)]) - (let loop ([menu-container (get-menu-bar)]) - (for-each - (λ (item) - (when (is-a? item selectable-menu-item<%>) - (let ([short-cut (send item get-shortcut)]) - (when short-cut - (let ([keyname - (string->symbol - (keymap:canonicalize-keybinding-string - (string-append - (menu-item->prefix-string item) - (case short-cut - [(#\;) "semicolon"] - [(#\:) "colon"] - [(#\space) "space"] - [else (string short-cut)]))))]) - (hash-set! name-ht keyname (send item get-plain-label)))))) - (when (is-a? item menu-item-container<%>) - (loop item))) - (send menu-container get-items))) - (when (eq? (system-type) 'windows) - (for-each (λ (top-level-menu) - (when (is-a? top-level-menu menu%) - (let ([amp-key - (let loop ([str (send top-level-menu get-label)]) - (cond - [(regexp-match #rx"[^&]*[&](.)(.*)" str) - => - (λ (m) - (let ([this-amp (list-ref m 1)] - [rest (list-ref m 2)]) - (cond - [(equal? this-amp "&") - (loop rest)] - [else - (string-downcase this-amp)])))] - [else #f]))]) - (when amp-key - (hash-set! name-ht - (format "m:~a" amp-key) - (format "~a menu" (send top-level-menu get-plain-label))) - (hash-set! name-ht - (format "m:s:~a" amp-key) - (format "~a menu" (send top-level-menu get-plain-label))))))) - (send (get-menu-bar) get-items))) - name-ht)) - - (define/private (menu-item->prefix-string item) - (apply - string-append - (map (λ (prefix) - (case prefix - [(alt) (if (eq? (system-type) 'windows) - "m:" - "a:")] - [(cmd) "d:"] - [(meta) "m:"] - [(ctl) "c:"] - [(shift) "s:"] - [(opt) "a:"])) - (send item get-shortcut-prefix)))) - - [define/private copy-hash-table - (λ (ht) - (let ([res (make-hasheq)]) - (hash-for-each - ht - (λ (x y) (hash-set! res x y))) - res))] - [define/private can-show-keybindings? - (λ () - (let ([edit-object (get-edit-target-object)]) - (and edit-object - (is-a? edit-object editor<%>) - (let ([keymap (send edit-object get-keymap)]) - (is-a? keymap keymap:aug-keymap<%>)))))] - - [define/private (show-keybindings) - (if (can-show-keybindings?) - (let* ([edit-object (get-edit-target-object)] - [keymap (send edit-object get-keymap)] - [menu-names (get-menu-bindings)] - [table (send keymap get-map-function-table)] - [bindings (hash-map table list)] - [w/menus - (append (hash-map menu-names list) - (filter (λ (binding) (not (bound-by-menu? binding menu-names))) - bindings))] - [structured-list - (sort - w/menus - (λ (x y) (string-ci<=? (cadr x) (cadr y))))]) - (show-keybindings-to-user structured-list this)) - (bell))] - - (define/private (bound-by-menu? binding menu-table) - (ormap (λ (constituent) - (hash-ref menu-table (string->symbol constituent) (λ () #f))) - (regexp-split #rx";" (symbol->string (car binding))))) - - (define/override (help-menu:before-about help-menu) - (make-help-desk-menu-item help-menu)) - - (define/override (help-menu:about-callback item evt) (drscheme:app:about-drscheme)) - (define/override (help-menu:about-string) (string-constant about-drscheme)) - (define/override (help-menu:create-about?) #t) - - (define/public (get-additional-important-urls) '()) - (define/override (help-menu:after-about menu) - (drscheme:app:add-important-urls-to-help-menu - menu - (get-additional-important-urls)) - (new menu-item% - (label (string-constant bug-report-submit-menu-item)) - (parent menu) - (callback - (λ (x y) - (help-desk:report-bug)))) - - (drscheme:app:add-language-items-to-help-menu menu)) - - (define/override (file-menu:new-string) (string-constant new-menu-item)) - (define/override (file-menu:open-string) (string-constant open-menu-item)) - - (define/override (file-menu:between-open-and-revert file-menu) - (make-object menu-item% - (string-constant install-plt-file-menu-item...) - file-menu - (λ (item evt) - (install-plt-file this))) - (super file-menu:between-open-and-revert file-menu)) - - (define/override (file-menu:between-print-and-close menu) - (super file-menu:between-print-and-close menu) - (instantiate menu-item% () - (label (string-constant mfs-multi-file-search-menu-item)) - (parent menu) - (callback - (λ (_1 _2) - (drscheme:multi-file-search:multi-file-search)))) - (new separator-menu-item% (parent menu))) - - (define/override (edit-menu:between-find-and-preferences menu) - (make-object separator-menu-item% menu) - (let ([keybindings-on-demand - (λ (menu-item) - (let ([last-edit-object (get-edit-target-window)]) - (send menu-item enable (can-show-keybindings?))))]) - (instantiate menu% () - (label (string-constant keybindings-menu-item)) - (parent menu) - (demand-callback - (λ (keybindings-menu) - (for-each (λ (old) (send old delete)) - (send keybindings-menu get-items)) - (new menu-item% - (parent keybindings-menu) - (label (string-constant keybindings-show-active)) - (callback (λ (x y) (show-keybindings))) - (help-string (string-constant keybindings-info)) - (demand-callback keybindings-on-demand)) - (new menu-item% - (parent keybindings-menu) - (label (string-constant keybindings-add-user-defined-keybindings)) - (callback - (λ (x y) - (with-handlers ([exn? (λ (x) - (printf "~a\n" (exn-message x)))]) - (let ([filename (finder:get-file - #f - (string-constant keybindings-choose-user-defined-file) - #f - "" - this)]) - (when filename - (add-keybindings-item/update-prefs filename))))))) - (new menu-item% - (parent keybindings-menu) - (label (string-constant keybindings-add-user-defined-keybindings/planet)) - (callback - (λ (x y) - (let ([planet-spec (get-text-from-user (string-constant drscheme) - (string-constant keybindings-type-planet-spec) - this - last-keybindings-planet-attempt)]) - (when planet-spec - (set! last-keybindings-planet-attempt planet-spec) - (cond - [(planet-string-spec? planet-spec) - => - (λ (planet-sexp-spec) - (add-keybindings-item/update-prefs planet-sexp-spec))] - [else - (message-box (string-constant drscheme) - (format (string-constant keybindings-planet-malformed-spec) - planet-spec))])))))) - (let ([ud (preferences:get 'drscheme:user-defined-keybindings)]) - (unless (null? ud) - (new separator-menu-item% (parent keybindings-menu)) - (for-each (λ (item) - (new menu-item% - (label (format (string-constant keybindings-menu-remove) - (if (path? item) - (path->string item) - (format "~s" item)))) - (parent keybindings-menu) - (callback - (λ (x y) (remove-keybindings-item item))))) - ud))))))) - (unless (current-eventspace-has-standard-menus?) - (make-object separator-menu-item% menu))) - - (super-new))) - - (define (add-keybindings-item/update-prefs item) - (when (add-keybindings-item item) - (preferences:set 'drscheme:user-defined-keybindings - (cons item - (preferences:get 'drscheme:user-defined-keybindings))))) - - (define (planet-string-spec? p) - (let ([sexp - (with-handlers ([exn:fail:read? (λ (x) #f)]) - (read (open-input-string p)))]) - (and sexp - (planet-spec? sexp) - sexp))) - - (define (planet-spec? p) - (match p - [`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?))) #t] - [`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?) ,(? number?))) #t] - [else #f])) - - ;; add-keybindings-item : keybindings-item[path or planet spec] -> boolean - ;; boolean indicates if the addition happened sucessfully - (define (add-keybindings-item item) - (with-handlers ([exn? (λ (x) - (message-box (string-constant drscheme) - (format (string-constant keybindings-error-installing-file) - (if (path? item) - (path->string item) - (format "~s" item)) - (exn-message x))) - #f)]) - (keymap:add-user-keybindings-file item) - #t)) - - (define (remove-keybindings-item item) - (keymap:remove-user-keybindings-file item) - (preferences:set - 'drscheme:user-defined-keybindings - (remove item - (preferences:get 'drscheme:user-defined-keybindings)))) - - ;; install-plt-file : (union #f dialog% frame%) -> void - ;; asks the user for a .plt file, either from the web or from - ;; a file on the disk and installs it. - (define (install-plt-file parent) - (define dialog - (instantiate dialog% () - (parent parent) - (alignment '(left center)) - (label (string-constant install-plt-file-dialog-title)))) - (define tab-panel - (instantiate tab-panel% () - (parent dialog) - (callback (λ (x y) (update-panels))) - (choices (list (string-constant install-plt-web-tab) - (string-constant install-plt-file-tab))))) - (define outer-swapping-panel (instantiate horizontal-panel% () - (parent tab-panel) - (stretchable-height #f))) - (define spacing-panel (instantiate horizontal-panel% () - (stretchable-width #f) - (parent outer-swapping-panel) - (min-width 20))) - (define swapping-panel (instantiate panel:single% () - (parent outer-swapping-panel) - (alignment '(left center)) - (stretchable-width #t) - (stretchable-height #f))) - (define file-panel (instantiate horizontal-panel% () - (parent swapping-panel) - (stretchable-width #t) - (stretchable-height #f))) - (define url-panel (instantiate horizontal-panel% () - (parent swapping-panel) - (stretchable-height #f))) - (define button-panel (instantiate horizontal-panel% () - (parent dialog) - (stretchable-height #f) - (alignment '(right center)))) - (define file-text-field (instantiate text-field% () - (parent file-panel) - (callback void) - (min-width 300) - (stretchable-width #t) - (label (string-constant install-plt-filename)))) - (define file-button (instantiate button% () - (parent file-panel) - (label (string-constant browse...)) - (callback (λ (x y) (browse))))) - (define url-text-field (instantiate text-field% () - (parent url-panel) - (label (string-constant install-plt-url)) - (min-width 300) - (stretchable-width #t) - (callback void))) - - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons - button-panel - (λ (x y) - (set! cancel? #f) - (send dialog show #f)) - (λ (x y) - (send dialog show #f)))) - - ;; browse : -> void - ;; gets the name of a file from the user and - ;; updates file-text-field - (define (browse) - (let ([filename (finder:get-file #f "" #f "" dialog)]) - (when filename - (send file-text-field set-value (path->string filename))))) - - ;; from-web? : -> boolean - ;; returns #t if the user has selected a web address - (define (from-web?) - (zero? (send tab-panel get-selection))) - - (define cancel? #t) - - (define (update-panels) - (send swapping-panel active-child - (if (from-web?) - url-panel - file-panel))) - - (update-panels) - (send dialog show #t) - - (cond - [cancel? (void)] - [(from-web?) - (install-plt-from-url (send url-text-field get-value) parent)] - [else - (parameterize ([error-display-handler drscheme:init:original-error-display-handler]) - (run-installer (string->path (send file-text-field get-value))))])) - - ;; install-plt-from-url : string (union #f dialog%) -> void - ;; downloads and installs a .plt file from the given url - (define (install-plt-from-url s-url parent) - (with-handlers ([(λ (x) #f) - (λ (exn) - (message-box (string-constant drscheme) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn))))]) - (let* ([url (string->url s-url)] - [tmp-filename (make-temporary-file "tmp~a.plt")] - [port (get-impure-port url)] - [header (purify-port port)] - [size (let* ([content-header (extract-field "content-length" header)] - [m (and content-header - (regexp-match "[0-9]+" content-header))]) - (and m (string->number (car m))))] - [d (make-object dialog% (string-constant downloading) parent)] - [message (make-object message% (string-constant downloading-file...) d)] - [gauge (if size - (make-object gauge% #f 100 d) - #f)] - [exn #f] - ; Semaphores to avoid race conditions: - [wait-to-start (make-semaphore 0)] - [wait-to-break (make-semaphore 0)] - ; Thread to perform the download: - [t (thread - (λ () - (semaphore-wait wait-to-start) - (with-handlers ([exn:fail? - (λ (x) - (set! exn x))] - [exn:break? ; throw away break exceptions - void]) - (semaphore-post wait-to-break) - (with-output-to-file tmp-filename - (λ () - (let loop ([total 0]) - (when gauge - (send gauge set-value - (inexact->exact - (floor (* 100 (/ total size)))))) - (let ([s (read-string 1024 port)]) - (unless (eof-object? s) - (unless (eof-object? s) - (display s) - (loop (+ total (string-length s)))))))) - #:mode 'binary #:exists 'truncate)) - (send d show #f)))]) - (send d center) - (make-object button% (string-constant &stop) - d - (λ (b e) - (semaphore-wait wait-to-break) - (set! tmp-filename #f) - (send d show #f) - (break-thread t))) - ; Let thread run only after the dialog is shown - (queue-callback (λ () (semaphore-post wait-to-start))) - (send d show #t) - (when exn (raise exn)) - (parameterize ([error-display-handler drscheme:init:original-error-display-handler]) - (run-installer tmp-filename - (λ () - (delete-file tmp-filename))))))) - - - (define keybindings-dialog% - (class dialog% - (override on-size) - [define on-size - (lambda (w h) - (preferences:set 'drscheme:keybindings-window-size (cons w h)) - (super on-size w h))] - (super-instantiate ()))) - - (define (show-keybindings-to-user bindings frame) - (letrec ([f (instantiate keybindings-dialog% () - (label (string-constant keybindings-frame-title)) - (parent frame) - (width (car (preferences:get 'drscheme:keybindings-window-size))) - (height (cdr (preferences:get 'drscheme:keybindings-window-size))) - (style '(resize-border)))] - [bp (make-object horizontal-panel% f)] - [search-field (new text-field% - [parent f] - [label (string-constant mfs-search-string)] - [callback (λ (a b) (update-bindings))])] - [b-name (make-object button% (string-constant keybindings-sort-by-name) - bp (λ x - (set! by-key? #f) - (update-bindings)))] - [b-key (make-object button% (string-constant keybindings-sort-by-key) - bp (λ x - (set! by-key? #t) - (update-bindings)))] - [lb - (make-object list-box% #f null f void)] - [bp2 (make-object horizontal-panel% f)] - [cancel (make-object button% (string-constant close) - bp2 (λ x (send f show #f)))] - [space (make-object grow-box-spacer-pane% bp2)] - [filter-search - (λ (bindings) - (let ([str (send search-field get-value)]) - (if (equal? str "") - bindings - (let ([reg (regexp (regexp-quote str #f))]) - (filter (λ (x) (or (regexp-match reg (cadr x)) - (regexp-match reg (format "~a" (car x))))) - bindings)))))] - [by-key? #f] - [update-bindings - (λ () - (let ([format-binding/name - (λ (b) (format "~a (~a)" (cadr b) (car b)))] - [format-binding/key - (λ (b) (format "~a (~a)" (car b) (cadr b)))] - [predicate/key - (λ (a b) (string-ci<=? (format "~a" (car a)) - (format "~a" (car b))))] - [predicate/name - (λ (a b) (string-ci<=? (cadr a) (cadr b)))]) - (send lb set - (if by-key? - (map format-binding/key (sort (filter-search bindings) predicate/key)) - (map format-binding/name (sort (filter-search bindings) predicate/name))))))]) - (send search-field focus) - (send bp stretchable-height #f) - (send bp set-alignment 'center 'center) - (send bp2 stretchable-height #f) - (send bp2 set-alignment 'right 'center) - (update-bindings) - (send f show #t))) - - (define <%> - (interface (frame:editor<%> basics<%> frame:text-info<%>) - get-show-menu - update-shown - add-show-menu-items)) - - (define -mixin - (mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>) - (inherit get-editor get-menu% get-menu-bar) - (define show-menu #f) - (define/public get-show-menu (λ () show-menu)) - (define/public update-shown (λ () (void))) - (define/public (add-show-menu-items show-menu) (void)) - (super-new) - (set! show-menu (make-object (get-menu%) (string-constant view-menu-label) - (get-menu-bar))) - (add-show-menu-items show-menu))) - - - (define (create-root-menubar) - (let* ([mb (new menu-bar% (parent 'root))] - [file-menu (new menu% - (label (string-constant file-menu)) - (parent mb))] - [help-menu (new menu% - (label (string-constant help-menu)) - (parent mb))]) - (new menu-item% - (label (string-constant new-menu-item)) - (parent file-menu) - (shortcut #\n) - (callback - (λ (x y) - (handler:edit-file #f) - #t))) - (new menu-item% - (label (string-constant open-menu-item)) - (parent file-menu) - (shortcut #\o) - (callback - (λ (x y) - (handler:open-file) - #t))) - (new menu% - (label (string-constant open-recent-menu-item)) - (parent file-menu) - (demand-callback - (λ (menu) - (handler:install-recent-items menu)))) - (instantiate menu-item% () - (label (string-constant mfs-multi-file-search-menu-item)) - (parent file-menu) - (callback - (λ (_1 _2) - (drscheme:multi-file-search:multi-file-search)))) - (unless (current-eventspace-has-standard-menus?) - (new separator-menu-item% (parent file-menu)) - (new menu-item% - (label (string-constant quit-menu-item-others)) - (parent file-menu) - (shortcut #\q) - (callback - (λ (x y) - (when (exit:user-oks-exit) - (exit:exit)) - #t)))) - (make-help-desk-menu-item help-menu))) - - (define (make-help-desk-menu-item help-menu) - (make-object menu-item% - (string-constant help-desk) - help-menu - (λ (item evt) - (help:help-desk) - #t))) diff --git a/collects/drscheme/private/get-extend.ss b/collects/drscheme/private/get-extend.ss deleted file mode 100644 index faa82d7040..0000000000 --- a/collects/drscheme/private/get-extend.ss +++ /dev/null @@ -1,84 +0,0 @@ -#lang scheme/unit - -(require scheme/class - "drsig.ss") - -(import [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:debug: drscheme:debug^]) -(export drscheme:get/extend^) - -(define make-extender - (λ (get-base% name) - (let ([extensions (λ (x) x)] - [built-yet? #f] - [built #f] - [verify - (λ (f) - (λ (%) - (let ([new% (f %)]) - (if (and (class? new%) - (subclass? new% %)) - new% - (error 'extend-% "expected output of extension to create a subclass of its input, got: ~a" - new%)))))]) - (values - (letrec ([add-extender - (case-lambda - [(extension) (add-extender extension #t)] - [(extension before?) - (when built-yet? - (error 'extender "cannot build a new extension of ~a after initialization" - name)) - (set! extensions - (if before? - (compose (verify extension) extensions) - (compose extensions (verify extension))))])]) - add-extender) - (λ () - (unless built-yet? - (set! built-yet? #t) - (set! built (extensions (get-base%)))) - built))))) - -(define (get-base-tab%) - (drscheme:debug:test-coverage-tab-mixin - (drscheme:debug:profile-tab-mixin - drscheme:unit:tab%))) - -(define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%)) - -(define (get-base-interactions-canvas%) - drscheme:unit:interactions-canvas%) - -(define-values (extend-interactions-canvas get-interactions-canvas) - (make-extender get-base-interactions-canvas% 'interactions-canvas%)) - -(define (get-base-definitions-canvas%) - drscheme:unit:definitions-canvas%) - -(define-values (extend-definitions-canvas get-definitions-canvas) - (make-extender get-base-definitions-canvas% 'definitions-canvas%)) - -(define (get-base-unit-frame%) - (drscheme:debug:profile-unit-frame-mixin - drscheme:unit:frame%)) - -(define-values (extend-unit-frame get-unit-frame) - (make-extender get-base-unit-frame% 'drscheme:unit:frame)) - -(define (get-base-interactions-text%) - (drscheme:debug:test-coverage-interactions-text-mixin - drscheme:rep:text%)) - -(define-values (extend-interactions-text get-interactions-text) - (make-extender get-base-interactions-text% 'interactions-text%)) - -(define (get-base-definitions-text%) - (drscheme:debug:test-coverage-definitions-text-mixin - (drscheme:debug:profile-definitions-text-mixin - (drscheme:unit:get-definitions-text%)))) - -(define-values (extend-definitions-text get-definitions-text) - (make-extender get-base-definitions-text% 'definitions-text%)) diff --git a/collects/drscheme/private/help-desk.ss b/collects/drscheme/private/help-desk.ss deleted file mode 100644 index b3ff09f57a..0000000000 --- a/collects/drscheme/private/help-desk.ss +++ /dev/null @@ -1,77 +0,0 @@ -#lang scheme/unit - -(require scheme/gui/base - browser/external - framework - scheme/class - net/url - setup/dirs - help/search - help/private/buginfo - "drsig.ss") - -(import [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]) -(export drscheme:help-desk^) - -(define (-add-help-desk-font-prefs b) '(add-help-desk-font-prefs b)) - -;; : -> string -(define (get-computer-language-info) - (let* ([language/settings (preferences:get - drscheme:language-configuration:settings-preferences-symbol)] - [language (drscheme:language-configuration:language-settings-language - language/settings)] - [settings (drscheme:language-configuration:language-settings-settings - language/settings)]) - (format - "~s" - (list - (send language get-language-position) - (send language marshall-settings settings))))) - -(set-bug-report-info! "Computer Language" get-computer-language-info) - -(define lang-message% - (class canvas% - (init-field button-release font) - (define/override (on-event evt) - (when (send evt button-up?) - (button-release))) - (field [msg ""]) - (define/public (set-msg l) (set! msg l) (on-paint)) - (inherit get-dc get-client-size) - (define/override (on-paint) - (let ([dc (get-dc)] - [dots "..."]) - (let-values ([(tw th _1 _2) (send dc get-text-extent msg)] - [(dw dh _3 _4) (send dc get-text-extent dots)] - [(cw ch) (get-client-size)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc set-font font) - (send dc draw-rectangle 0 0 cw ch) - (cond - [(tw . <= . cw) - (send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))] - [(cw . <= . dw) ;; just give up if there's not enough room to draw the dots - (void)] - [else - (send dc set-clipping-rect 0 0 (- cw dw 2) ch) - (send dc draw-text msg 0 (- (/ ch 2) (/ th 2))) - (send dc set-clipping-region #f) - (send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))])))) - (super-new))) - -(define (goto-plt-license) - (send-main-page "license/index.html")) - -(define (help-desk [key #f] #:module [mod #f] #:manual [man #f]) - (if (or key mod man) - (perform-search (string-append (or key "") - (if mod (format " L:~a" mod) "") - (if man (format " T:~a" man) ""))) - (send-main-page))) - -;; here for legacy code that should be removed -(define (get-docs) '()) diff --git a/collects/drscheme/private/init.ss b/collects/drscheme/private/init.ss deleted file mode 100644 index 8127337e68..0000000000 --- a/collects/drscheme/private/init.ss +++ /dev/null @@ -1,51 +0,0 @@ - -#lang scheme/unit - (require string-constants - "drsig.ss" - mzlib/list - mred) - - - (import) - (export drscheme:init^) - - (define original-output-port (current-output-port)) - (define original-error-port (current-error-port)) - - (define primitive-eval (current-eval)) - (define primitive-load (current-load)) - - (define system-custodian (current-custodian)) - (define system-eventspace (current-eventspace)) - (define system-thread (current-thread)) - (define system-namespace (current-namespace)) - (define first-dir (current-directory)) - - (define error-display-eventspace (make-eventspace)) - - (define original-error-display-handler (error-display-handler)) - - (define error-display-handler-message-box-title - (make-parameter (string-constant drscheme-internal-error))) - - ;; override error-display-handler to duplicate the error - ;; message in both the standard place (as defined by the - ;; current error-display-handler) and in a message box - ;; identifying the error as a drscheme internal error. - (error-display-handler - (λ (msg exn) - - ;; this may raise an exception if the port is gone. - (with-handlers ([exn:fail? (λ (x) (void))]) - (original-error-display-handler msg exn)) - - (let ([title (error-display-handler-message-box-title)]) - (let ([text (let ([p (open-output-string)]) - (parameterize ([current-error-port p] - [current-output-port p]) - (original-error-display-handler msg exn)) - (get-output-string p))]) - - (parameterize ([current-custodian system-custodian]) - (parameterize ([current-eventspace error-display-eventspace]) - (message-box title text #f '(stop ok)))))))) diff --git a/collects/drscheme/private/insert-large-letters.ss b/collects/drscheme/private/insert-large-letters.ss deleted file mode 100644 index 1ca789aa28..0000000000 --- a/collects/drscheme/private/insert-large-letters.ss +++ /dev/null @@ -1,172 +0,0 @@ -#lang scheme/base - -(require mred scheme/class string-constants framework) - -(provide insert-large-letters) - -(define (insert-large-letters comment-prefix comment-character edit parent) - (let ([str (make-large-letters-dialog comment-prefix comment-character #f)]) - (when (and str - (not (equal? str ""))) - (render-large-letters comment-prefix comment-character (get-chosen-font) str edit) - (void)))) - -(preferences:set-default 'drscheme:large-letters-font #f (λ (x) (or (and (pair? x) - (string? (car x)) - (number? (cdr x)) - (integer? (cdr x)) - (<= 1 (cdr x) 255)) - (not x)))) - -(define (get-default-font) - (send (send (editor:get-standard-style-list) - find-named-style - "Standard") - get-font)) - -(define (get-chosen-font) - (let ([pref-val (preferences:get 'drscheme:large-letters-font)]) - (cond - [pref-val - (let ([candidate (send the-font-list find-or-create-font (cdr pref-val) (car pref-val) 'default 'normal 'normal)]) - (if (equal? (send candidate get-face) (car pref-val)) - candidate - (get-default-font)))] - [else - (get-default-font)]))) - -(define columns-string "~a columns") - -;; make-large-letters-dialog : string char top-level-window<%> -> void -(define (make-large-letters-dialog comment-prefix comment-character parent) - (define dlg (new dialog% - [parent parent] - [width 700] - [label (string-constant large-semicolon-letters)])) - (define text-field (new text-field% - [parent dlg] - [label (string-constant text-to-insert)] - [callback (λ (x y) (update-txt (send text-field get-value)))])) - (define info-bar (new horizontal-panel% - [parent dlg] - [stretchable-height #f])) - (define font-choice (new choice% - [label (string-constant fonts)] - [parent info-bar] - [choices (get-face-list)] - [callback - (λ (x y) - (let ([old (preferences:get 'drscheme:large-letters-font)]) - (preferences:set 'drscheme:large-letters-font - (cons (send font-choice get-string-selection) - (if old - (cdr old) - (send (get-default-font) get-point-size)))) - (update-txt (send text-field get-value))))])) - (define count (new message% [label (format columns-string 1000)] [parent info-bar])) - (define pane1 (new horizontal-pane% (parent info-bar))) - (define dark-msg (new bitmap-message% [parent info-bar])) - (define pane2 (new horizontal-pane% (parent info-bar))) - - - (define txt (new scheme:text%)) - (define ec (new editor-canvas% [parent dlg] [editor txt])) - (define button-panel (new horizontal-panel% - [parent dlg] - [stretchable-height #f] - [alignment '(right center)])) - (define ok? #f) - (define-values (ok cancel) - (gui-utils:ok/cancel-buttons button-panel - (λ (x y) (set! ok? #t) (send dlg show #f)) - (λ (x y) (send dlg show #f)))) - (define (update-txt str) - (send txt begin-edit-sequence) - (send txt lock #f) - (send txt delete 0 (send txt last-position)) - (let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt)]) - (send ec set-line-count (+ 1 (send txt last-paragraph))) - (send txt lock #t) - (send txt end-edit-sequence) - (send count set-label (format columns-string (get-max-line-width txt))) - (send dark-msg set-bm bm))) - - (send font-choice set-string-selection (send (get-chosen-font) get-face)) - - (send txt auto-wrap #f) - (update-txt " ") - (send text-field focus) - (send dlg show #t) - (and ok? (send text-field get-value))) - -(define (get-max-line-width txt) - (let loop ([i (+ (send txt last-paragraph) 1)] - [m 0]) - (cond - [(zero? i) m] - [else (loop (- i 1) - (max m (- (send txt paragraph-end-position (- i 1)) - (send txt paragraph-start-position (- i 1)))))]))) - -(define bitmap-message% - (class canvas% - (inherit min-width min-height get-dc) - (define bm #f) - (define/override (on-paint) - (when bm - (let ([dc (get-dc)]) - (send dc draw-bitmap bm 0 0)))) - (define/public (set-bm b) - (set! bm b) - (min-width (send bm get-width)) - (min-height (send bm get-height))) - (super-new (stretchable-width #f) - (stretchable-height #f)))) - -(define (render-large-letters comment-prefix comment-character the-font str edit) - (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))) - (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font)) - (define th (let-values ([(_1 h _2 _3) (send bdc get-text-extent "X" the-font)]) - (max raw-th h))) - (define tmp-color (make-object color%)) - - (define (get-char x y) - (send bdc get-pixel x y tmp-color) - (let ([red (send tmp-color red)]) - (if (= red 0) - comment-character - #\space))) - (define bitmap - (make-object bitmap% - (max 1 (inexact->exact tw)) - (inexact->exact th) - #t)) - - (define (fetch-line y) - (let loop ([x (send bitmap get-width)] - [chars null]) - (cond - [(zero? x) (apply string chars)] - [else (loop (- x 1) (cons (get-char (- x 1) y) chars))]))) - - (send bdc set-bitmap bitmap) - (send bdc clear) - (send bdc set-font the-font) - (send bdc draw-text str 0 0) - - (send edit begin-edit-sequence) - (let ([start (send edit get-start-position)] - [end (send edit get-end-position)]) - (send edit delete start end) - (send edit insert "\n" start start) - (let loop ([y (send bitmap get-height)]) - (unless (zero? y) - (send edit insert (fetch-line (- y 1)) start start) - (send edit insert comment-prefix start start) - (send edit insert "\n" start start) - (loop (- y 1))))) - (send edit end-edit-sequence) - (send bdc set-bitmap #f) - bitmap) - -;(make-large-letters-dialog ";" #\; #f) diff --git a/collects/drscheme/private/key.ss b/collects/drscheme/private/key.ss deleted file mode 100644 index 2aedf9a5c9..0000000000 --- a/collects/drscheme/private/key.ss +++ /dev/null @@ -1,19 +0,0 @@ -(module key mzscheme - (provide break-threads) - (define super-cust (current-custodian)) - (define first-child (make-custodian)) - (current-custodian first-child) - - - (define (break-threads) - (parameterize ([current-custodian super-cust]) - (thread - (λ () - (let loop ([super-cust super-cust] - [current-cust first-child]) - (for-each (λ (man) - (when (thread? man) - (break-thread man)) - (when (custodian? man) - (loop current-cust man))) - (custodian-managed-list current-cust super-cust)))))))) diff --git a/collects/drscheme/private/label-frame-mred.ss b/collects/drscheme/private/label-frame-mred.ss deleted file mode 100644 index 1f890364f2..0000000000 --- a/collects/drscheme/private/label-frame-mred.ss +++ /dev/null @@ -1,28 +0,0 @@ -(module label-frame-mred mzscheme - (require mred - mzlib/class) - (provide (all-from-except mred frame%) - (rename registering-frame% frame%) - lookup-frame-name) - - (define (lookup-frame-name frame) - (semaphore-wait label-sema) - (begin0 - (hash-table-get label-ht frame (λ () #f)) - (semaphore-post label-sema))) - - (define label-sema (make-semaphore 1)) - (define label-ht (make-hash-table 'weak)) - - (define registering-frame% - (class frame% - (define/override (set-label x) - (semaphore-wait label-sema) - (hash-table-put! label-ht this x) - (semaphore-post label-sema) - (super set-label x)) - (inherit get-label) - (super-instantiate ()) - (semaphore-wait label-sema) - (hash-table-put! label-ht this (get-label)) - (semaphore-post label-sema)))) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss deleted file mode 100644 index 0ce1a6e989..0000000000 --- a/collects/drscheme/private/language-configuration.ss +++ /dev/null @@ -1,1784 +0,0 @@ - -(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 deleted file mode 100644 index dbb6eba60c..0000000000 --- a/collects/drscheme/private/language-object-contract.ss +++ /dev/null @@ -1,94 +0,0 @@ -#reader scribble/reader -#lang scheme/base -(require (for-syntax scheme/base) - scribble/srcdoc - scheme/class - scheme/gui/base - scheme/contract - "recon.ss") -(require/doc scheme/base scribble/manual) - -(require (for-meta 2 scheme/base)) - -(provide language-object-abstraction) - -(define-syntax (language-object-abstraction stx) - (syntax-case stx () - [(_ id provide?) - (let-syntax ([save-srcloc - (λ (s) - (define-struct sloc (inside loc) #:prefab) - (syntax-case s () - [(_ arg) - (with-syntax ([ans - (let loop ([s #'arg]) - (cond - [(syntax? s) - (let ([loc (vector (syntax-source s) - (syntax-line s) - (syntax-column s) - (syntax-position s) - (syntax-span s))]) - (make-sloc (loop (syntax-e s)) loc))] - [(pair? s) (cons (loop (car s)) (loop (cdr s)))] - [else s]))]) - #'ans)]))]) - (let* ([ctc - (save-srcloc - (object-contract - (config-panel (-> (is-a?/c area-container<%>) - (case-> (-> any/c void?) - (-> any/c)))) - (create-executable (-> any/c - (or/c (is-a?/c dialog%) (is-a?/c frame%)) - path? - void?)) - (default-settings (-> any/c)) - (default-settings? (-> any/c boolean?)) - (front-end/complete-program (-> input-port? - any/c - (-> any/c))) - (front-end/interaction (-> input-port? - any/c - (-> any/c))) - (get-language-name (-> string?)) - (get-language-numbers (-> (cons/c number? (listof number?)))) - (get-language-position (-> (cons/c string? (listof string?)))) - (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) - (get-comment-character (-> (values string? char?))) - (get-style-delta - (-> (or/c false/c - (is-a?/c style-delta%) - (listof - (list/c (is-a?/c style-delta%) - number? - number?))))) - (marshall-settings (-> any/c printable/c)) - (on-execute (-> any/c (-> (-> any) any) any)) - (render-value (-> any/c - any/c - output-port? - void?)) - (render-value/format (-> any/c - any/c - output-port? - (or/c number? (symbols 'infinity)) - any)) - (unmarshall-settings (-> printable/c any)) - - (capability-value - (->d ([s (and/c symbol? - drscheme:language:capability-registered?)]) - () - [res (drscheme:language:get-capability-contract s)]))))]) - #`(begin - (define id (reconstitute #,ctc provide?)) - #,@(if (syntax-e #'provide?) - (list - #`(require/doc drscheme/private/recon) - #`(provide/doc - (thing-doc id - contract? - ((reconstitute (schemeblock #,ctc) provide?))))) - '()))))])) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss deleted file mode 100644 index eb3d691d4e..0000000000 --- a/collects/drscheme/private/language.ss +++ /dev/null @@ -1,1171 +0,0 @@ -;; 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 deleted file mode 100644 index d7ce4e81ab..0000000000 --- a/collects/drscheme/private/launcher-bootstrap.ss +++ /dev/null @@ -1,50 +0,0 @@ -#lang scheme/base - -(provide startup) - -(require scheme/file) - -(define (read-from-string s) (read (open-input-string s))) - -(define (startup) - (define argv (current-command-line-arguments)) - ;; skip first six - (define program-argv (list->vector (cddr (cddddr (vector->list argv))))) - - (define init-code (read-from-string (vector-ref argv 0))) - (define program-filename (vector-ref argv 1)) - (define language-module-spec (read-from-string (vector-ref argv 2))) - (define transformer-module-spec (read-from-string (vector-ref argv 3))) - (define use-require/copy? (read-from-string (vector-ref argv 4))) - - (define init-code-tmp-filename (make-temporary-file "drs-launcher-init~a")) - (define-values (_1 init-code-mod-name _2) (split-path init-code-tmp-filename)) - - (define stupid-internal-define-syntax2 - (set! init-code (cons (car init-code) - (cons (string->symbol (path->string init-code-mod-name)) - (cddr init-code))))) - - (define stupid-internal-define-syntax1 - (call-with-output-file init-code-tmp-filename - (λ (port) - (write init-code port)) - #:exists 'truncate #:mode 'text)) - - (define init-code-proc (dynamic-require init-code-tmp-filename 'init-code)) - - (namespace-set-variable-value! 'argv program-argv) - (current-command-line-arguments program-argv) - (when language-module-spec - (namespace-require language-module-spec)) - (when use-require/copy? - (namespace-require/copy language-module-spec)) - (when transformer-module-spec - (namespace-require `(for-syntax ,transformer-module-spec))) - - (init-code-proc) - - ;; safe to do this earlier? - (delete-file init-code-tmp-filename) - - (load program-filename)) \ No newline at end of file diff --git a/collects/drscheme/private/launcher-mred-bootstrap.ss b/collects/drscheme/private/launcher-mred-bootstrap.ss deleted file mode 100644 index 20820223ab..0000000000 --- a/collects/drscheme/private/launcher-mred-bootstrap.ss +++ /dev/null @@ -1,9 +0,0 @@ -#lang scheme/base - -(require scheme/gui/base "launcher-bootstrap.ss") - -(current-namespace (make-gui-empty-namespace)) -(namespace-require 'scheme/gui/base) -(namespace-require 'scheme/class) - -(startup) diff --git a/collects/drscheme/private/launcher-mz-bootstrap.ss b/collects/drscheme/private/launcher-mz-bootstrap.ss deleted file mode 100644 index f591a62c7a..0000000000 --- a/collects/drscheme/private/launcher-mz-bootstrap.ss +++ /dev/null @@ -1,8 +0,0 @@ -#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 deleted file mode 100644 index 18c9b2f0c3..0000000000 --- a/collects/drscheme/private/link.ss +++ /dev/null @@ -1,55 +0,0 @@ -(module link mzscheme - (require "modes.ss" - "font.ss" - "eval.ss" - "module-browser.ss" - "multi-file-search.ss" - "debug.ss" - "module-language.ss" - "tools.ss" - mzlib/unit - "language.ss" - "language-configuration.ss" - "drsig.ss" - "init.ss" - "text.ss" - "app.ss" - "main.ss" - "rep.ss" - "frame.ss" - "unit.ss" - "get-extend.ss" - "help-desk.ss") - (provide drscheme@) - - - (define-compound-unit/infer drscheme-unit@ - (import) - (export drscheme:debug^ - drscheme:unit^ - drscheme:rep^ - drscheme:frame^ - drscheme:get/extend^ - drscheme:language-configuration^ - drscheme:language^ - drscheme:help-desk^ - drscheme:eval^ - drscheme:modes^) - (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ - module-overview@ unit@ debug@ multi-file-search@ get-extend@ - language-configuration@ font@ module-language@ help-desk@ app@ main@)) - - (define-unit/new-import-export drscheme@ - (import) (export drscheme:tool^) - (((prefix drscheme:debug: drscheme:debug^) - (prefix drscheme:unit: drscheme:unit^) - (prefix drscheme:rep: drscheme:rep^) - (prefix drscheme:frame: drscheme:frame^) - (prefix drscheme:get/extend: drscheme:get/extend^) - (prefix drscheme:language-configuration: drscheme:language-configuration^) - (prefix drscheme:language: drscheme:language^) - (prefix drscheme:help-desk: drscheme:help-desk^) - (prefix drscheme:eval: drscheme:eval^) - (prefix drscheme:modes: drscheme:modes^)) - drscheme-unit@))) - diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss deleted file mode 100644 index bac906ae27..0000000000 --- a/collects/drscheme/private/main.ss +++ /dev/null @@ -1,508 +0,0 @@ -#lang scheme/unit - -(require string-constants - mzlib/contract - "drsig.ss" - mred - framework - mzlib/class - mzlib/list - scheme/path - (lib "external.ss" "browser") - (lib "plt-installer.ss" "setup")) - -(import [prefix drscheme:app: drscheme:app^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:get/extend: drscheme:get/extend^] - [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:module-language: drscheme:module-language^] - [prefix drscheme:tools: drscheme:tools^] - [prefix drscheme:debug: drscheme:debug^] - [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:font: drscheme:font^] - [prefix drscheme:modes: drscheme:modes^] - [prefix drscheme:help-desk: drscheme:help-desk^]) -(export) - -(application-file-handler - (let ([default (application-file-handler)]) - (λ (name) - (if (null? (get-top-level-windows)) - (handler:edit-file name) - (default name))))) - -(application-quit-handler - (let ([default (application-quit-handler)]) - (λ () - (if (null? (get-top-level-windows)) - (when (exit:user-oks-exit) - (exit:exit)) - (default))))) - -(application-about-handler - (λ () - (drscheme:app:about-drscheme))) - -(drscheme:modes:add-initial-modes) - -(namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin) - -(finder:default-filters (list* '("Scheme (.ss)" "*.ss") - '("Scheme (.scm)" "*.scm") - (finder:default-filters))) -(application:current-app-name (string-constant drscheme)) - -(preferences:set-default 'drscheme:toolbar-state - '(#f . top) - (λ (x) (and (pair? x) - (boolean? (car x)) - (memq (cdr x) '(left top right))))) - -(preferences:set-default 'drscheme:htdp:last-set-teachpacks - '() - (λ (x) - (and (list? x) - (andmap (λ (x) - (and (list? x) - (pair? x) - (eq? (car x) 'lib) - (andmap string? (cdr x)))) - x)))) -(preferences:set-default 'drscheme:defs/ints-horizontal #f boolean?) -(preferences:set-default 'drscheme:unit-window-max? #f boolean?) -(preferences:set-default 'drscheme:frame:initial-position #f - (λ (x) (or (not x) - (and (pair? x) - (number? (car x)) - (number? (cdr x)))))) - -(preferences:set-default 'drscheme:limit-memory (* 1024 1024 128) - (λ (x) (or (boolean? x) - (integer? x) - (x . >= . (* 1024 1024 100))))) - -(preferences:set-default 'drscheme:recent-language-names - null - (λ (x) - (and (list? x) - (andmap - (λ (x) - (and (pair? x) - (string? (car x)))) - x)))) -(preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?) -(preferences:set-default 'drscheme:open-in-tabs #f boolean?) -(preferences:set-default 'drscheme:toolbar-shown #t boolean?) -(preferences:set-default 'drscheme:user-defined-keybindings - '() - (λ (x) (and (list? x) - (andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) - x)))) - -(preferences:set-un/marshall - 'drscheme:user-defined-keybindings - (λ (in) (map (λ (x) (if (path? x) (path->bytes x) x)) - in)) - (λ (ex) (if (list? ex) - (map (λ (x) (if (bytes? x) (bytes->path x) x)) ex) - '()))) - -(let ([number-between-zero-and-one? - (λ (x) (and (number? x) (<= 0 x 1)))]) - (preferences:set-default 'drscheme:unit-window-size-percentage - 1/2 - number-between-zero-and-one?) - (preferences:set-default 'drscheme:module-browser-size-percentage - 1/5 - number-between-zero-and-one?)) -(preferences:set-default 'drscheme:module-browser:name-length 1 - (λ (x) (memq x '(0 1 2)))) - -(let ([frame-width 600] - [frame-height 650] - [window-trimming-upper-bound-width 20] - [window-trimming-upper-bound-height 50]) - (let-values ([(w h) (get-display-size)]) - (set! frame-width (min frame-width (- w window-trimming-upper-bound-width))) - (set! frame-height (min frame-height (- h window-trimming-upper-bound-height)))) - (preferences:set-default 'drscheme:unit-window-width frame-width number?) - (preferences:set-default 'drscheme:unit-window-height frame-height number?)) - -(preferences:set-default 'drscheme:backtrace-window-width 400 number?) -(preferences:set-default 'drscheme:backtrace-window-height 300 number?) -(preferences:set-default 'drscheme:backtrace-window-x 0 number?) -(preferences:set-default 'drscheme:backtrace-window-y 0 number?) - -(preferences:set-default 'drscheme:profile-how-to-count 'time - (λ (x) - (memq x '(time count)))) -(preferences:set-default 'drscheme:profile:low-color - (make-object color% 150 255 150) - (λ (x) (is-a? x color%))) -(preferences:set-default 'drscheme:profile:high-color - (make-object color% 255 150 150) - (λ (x) (is-a? x color%))) -(preferences:set-default 'drscheme:profile:scale - 'linear - (λ (x) (memq x '(sqrt linear square)))) - -(preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?) - -;; size is in editor positions -(preferences:set-default 'drscheme:repl-buffer-size - '(#t . 1000) - (λ (x) - (and (pair? x) - (boolean? (car x)) - (integer? (cdr x)) - (<= 1 (cdr x) 10000)))) - -(let ([marshall-color - (λ (c) - (list (send c red) (send c green) (send c blue)))] - [unmarshall-color - (λ (l) - (if (and (list? l) - (= 3 (length l)) - (andmap (λ (x) (and number? (<= 0 x 255))) - l)) - (make-object color% (car l) (cadr l) (caddr l)) - (make-object color% 0 0 0)))]) - (preferences:set-un/marshall - 'drscheme:profile:low-color - marshall-color - unmarshall-color) - (preferences:set-un/marshall - 'drscheme:profile:high-color - marshall-color - unmarshall-color)) - -(preferences:set-default - 'drscheme:keybindings-window-size - (cons 200 400) - (λ (x) (and (pair? x) - (number? (car x)) - (number? (cdr x))))) - -(preferences:set-default - 'drscheme:execute-warning-once - #f - (λ (x) - (or (eq? x #t) - (not x)))) - -(preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?) - -(preferences:set-default - 'drscheme:default-tools-configuration - 'load - (lambda (p) - (memq p '(load skip)))) - -(preferences:set-default - 'drscheme:tools-configuration - null - list?) - -(drscheme:font:setup-preferences) -(color-prefs:add-background-preferences-panel) -(scheme:add-preferences-panel) -(scheme:add-coloring-preferences-panel) -(preferences:add-editor-checkbox-panel) -(preferences:add-warnings-checkbox-panel) -(preferences:add-scheme-checkbox-panel) - -(let ([make-check-box - (λ (pref-sym string parent) - (let ([q (make-object check-box% - string - parent - (λ (checkbox evt) - (preferences:set - pref-sym - (send checkbox get-value))))]) - (preferences:add-callback pref-sym (λ (p v) (send q set-value v))) - (send q set-value (preferences:get pref-sym))))]) - (preferences:add-to-editor-checkbox-panel - (λ (editor-panel) - (make-check-box 'drscheme:open-in-tabs - (string-constant open-files-in-tabs) - editor-panel) - (make-check-box 'drscheme:show-interactions-on-execute - (string-constant show-interactions-on-execute) - editor-panel) - - (make-check-box 'drscheme:switch-to-module-language-automatically? - (string-constant switch-to-module-language-automatically) - editor-panel) - - (make-check-box 'drscheme:defs/ints-horizontal - (string-constant interactions-beside-definitions) - editor-panel) - ;; come back to this one. - #; - (letrec ([hp (new horizontal-panel% - (parent editor-panel) - (alignment '(left top)) - (stretchable-height #f))] - [cb (new check-box% - (label (string-constant limit-interactions-size)) - (parent hp) - (callback (λ (cb v) (cb-callback))))] - [sl (new slider% - (label #f) - (parent hp) - (min-value 1) - (max-value 10000) - (callback - (λ (sl _) (sl-callback))))] - [cb-callback - (λ () - (preferences:set 'drscheme:repl-buffer-size - (cons (send cb get-value) - (cdr (preferences:get 'drscheme:repl-buffer-size)))))] - [sl-callback - (λ () - (preferences:set 'drscheme:repl-buffer-size - (cons (car (preferences:get 'drscheme:repl-buffer-size)) - (send sl get-value))))] - [update-controls - (λ (v) - (let ([on? (car v)]) - (send sl enable on?) - (send cb set-value on?) - (send sl set-value (cdr v))))]) - (preferences:add-callback 'drscheme:repl-buffer-size (λ (p v) (update-controls v))) - (update-controls (preferences:get 'drscheme:repl-buffer-size))))) - - (preferences:add-to-warnings-checkbox-panel - (λ (warnings-panel) - (make-check-box 'drscheme:execute-warning-once - (string-constant only-warn-once) - warnings-panel) - (make-check-box 'drscheme:test-coverage-ask-about-clearing? - (string-constant test-coverage-ask?) - warnings-panel)))) -(drscheme:debug:add-prefs-panel) -(install-help-browser-preference-panel) -(drscheme:tools:add-prefs-panel) - -(drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '()) -(drscheme:language:register-capability 'drscheme:define-popup - (or/c (cons/c string? string?) false/c) - (cons "(define" "(define ...)")) - -(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t) -(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t) -(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t) -(drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t) -(drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t) -(drscheme:language:register-capability 'drscheme:language-menu-title - (flat-contract string?) - (string-constant scheme-menu-name)) - -(drscheme:language:register-capability 'drscheme:teachpack-menu-items - (or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?)) - #f) - -(handler:current-create-new-window - (let ([drscheme-current-create-new-window - (λ (filename) - (drscheme:unit:open-drscheme-window filename))]) - drscheme-current-create-new-window)) - -;; add a catch-all handler to open drscheme files -(handler:insert-format-handler - "Units" - (λ (filename) #t) - drscheme:unit:open-drscheme-window) - -;; add a handler to open .plt files. -(handler:insert-format-handler - "PLT Files" - (λ (filename) - (let ([ext (filename-extension filename)]) - (and ext - (or (bytes=? #"PLT" ext) - (bytes=? #"plt" ext)) - (gui-utils:get-choice - (format (string-constant install-plt-file) filename) - (string-constant install-plt-file/yes) - (string-constant install-plt-file/no))))) - (λ (filename) - (run-installer filename) - #f)) - -(drscheme:tools:load/invoke-all-tools - (λ () (void)) - (λ () - (drscheme:language-configuration:add-built-in-languages) - (drscheme:module-language:add-module-language) - (drscheme:language-configuration:add-info-specified-languages))) - -;; no more extension after this point -(drscheme:get/extend:get-interactions-canvas) -(drscheme:get/extend:get-definitions-canvas) -(drscheme:get/extend:get-unit-frame) -(drscheme:get/extend:get-interactions-text) -(drscheme:get/extend:get-definitions-text) -(drscheme:language-configuration:get-languages) - -;; this default can only be set *after* the -;; languages have all be registered by tools -(preferences:set-default - drscheme:language-configuration:settings-preferences-symbol - (drscheme:language-configuration:get-default-language-settings) - drscheme:language-configuration:language-settings?) - -;; if the unmarshaller returns #f, that will fail the -;; test for this preference, reverting back to the default. -;; In that case, the default is specified in the pref.ss file -;; of the default collection and may not be the default -;; specified above (of course). -(preferences:set-un/marshall - drscheme:language-configuration:settings-preferences-symbol - (λ (x) - (let ([lang (drscheme:language-configuration:language-settings-language x)] - [settings (drscheme:language-configuration:language-settings-settings x)]) - (list (send lang get-language-numbers) - (send lang marshall-settings settings)))) - (λ (x) - (and (list? x) - (= 2 (length x)) - (let* ([lang-nums (first x)] - [marshalled-settings (second x)] - [lang (ormap - (λ (x) - (and (or (equal? (send x get-language-numbers) lang-nums) - - ;; this second branch of the `or' corresdponds - ;; to preferences saved from earlier versions of - ;; drscheme, for a sort of backwards compatibility - (equal? (send x get-language-position) lang-nums)) - x)) - (drscheme:language-configuration:get-languages))]) - (and lang - (let ([settings (send lang unmarshall-settings marshalled-settings)]) - (drscheme:language-configuration:make-language-settings - lang - (or settings (send lang default-settings))))))))) - -(let ([drs-handler-recent-items-super% - (class (drscheme:frame:basics-mixin - (frame:standard-menus-mixin - frame:basic%)) - (define/override (edit-menu:between-select-all-and-find menu) - (void)) - (super-new))]) - (handler:set-recent-items-frame-superclass drs-handler-recent-items-super%)) - -(cond - [(current-eventspace-has-menu-root?) - (drscheme:frame:create-root-menubar) - (preferences:set 'framework:exit-when-no-frames #f)] - [else - (preferences:set 'framework:exit-when-no-frames #t)]) - - -(let* ([sl (editor:get-standard-style-list)] - [sd (make-object style-delta%)]) - (send sd set-delta-foreground (make-object color% 255 0 0)) - (send sl new-named-style - "drscheme:text:ports err" - (send sl find-or-create-style - (send sl find-named-style "text:ports err") - sd))) -(define repl-error-pref 'drscheme:read-eval-print-loop:error-color) -(define repl-out-pref 'drscheme:read-eval-print-loop:out-color) -(define repl-value-pref 'drscheme:read-eval-print-loop:value-color) -(color-prefs:register-color-preference repl-value-pref - "text:ports value" - (make-object color% 0 0 175) - (make-object color% 57 89 216)) -(color-prefs:register-color-preference repl-error-pref - "text:ports err" - (let ([sd (make-object style-delta% 'change-italic)]) - (send sd set-delta-foreground (make-object color% 255 0 0)) - sd)) -(color-prefs:register-color-preference repl-out-pref - "text:ports out" - (make-object color% 150 0 150) - (make-object color% 192 46 214)) -(color-prefs:add-to-preferences-panel - (string-constant repl-colors) - (λ (parent) - (color-prefs:build-color-selection-panel parent - repl-value-pref - "text:ports value" - (string-constant repl-value-color)) - (color-prefs:build-color-selection-panel parent - repl-error-pref - "text:ports err" - (string-constant repl-error-color)) - (color-prefs:build-color-selection-panel parent - repl-out-pref - "text:ports out" - (string-constant repl-out-color)))) - -;; Check for any files lost last time. -;; Ignore the framework's empty frames test, since -;; the autosave information window may appear and then -;; go away (leaving no frames temporarily) but we are -;; not going to be exiting yet. -(autosave:restore-autosave-files/gui) - -;; install user's keybindings -(for-each drscheme:frame:add-keybindings-item - (preferences:get 'drscheme:user-defined-keybindings)) - -;; the initial window doesn't set the -;; unit object's state correctly, yet. -(define (make-basic) - (let* ([frame (drscheme:unit:open-drscheme-window)] - [interactions-edit (send frame get-interactions-text)] - [definitions-edit (send frame get-interactions-text)] - [filename (send definitions-edit get-filename)]) - (unless filename - (send frame update-shown) - (send (send frame get-interactions-canvas) focus)) - (send frame show #t))) - -(define (remove-duplicates files) - (let loop ([files files]) - (cond - [(null? files) null] - [else (if (member (car files) (cdr files)) - (loop (cdr files)) - (cons (car files) (loop (cdr files))))]))) - -;; NOTE: drscheme-normal.ss sets current-command-line-arguments to -;; the list of files to open, after parsing out flags like -h -(let* ([files-to-open - (if (preferences:get 'drscheme:open-in-tabs) - (vector->list (current-command-line-arguments)) - (reverse (vector->list (current-command-line-arguments))))] - [normalized/filtered - (let loop ([files files-to-open]) - (cond - [(null? files) null] - [else (let ([file (car files)]) - (if (file-exists? file) - (cons (normalize-path file) (loop (cdr files))) - (begin - (message-box - (string-constant drscheme) - (format (string-constant cannot-open-because-dne) file)) - (loop (cdr files)))))]))] - [no-dups (remove-duplicates normalized/filtered)] - [frames - (map (λ (f) (handler:edit-file - f - (λ () (drscheme:unit:open-drscheme-window f)))) - no-dups)]) - (when (null? (filter (λ (x) x) frames)) - (make-basic)) - (when (and (preferences:get 'drscheme:open-in-tabs) - (not (null? no-dups))) - (handler:edit-file (car no-dups)))) diff --git a/collects/drscheme/private/modes.ss b/collects/drscheme/private/modes.ss deleted file mode 100644 index 973d6275d2..0000000000 --- a/collects/drscheme/private/modes.ss +++ /dev/null @@ -1,46 +0,0 @@ -#lang scheme/unit - (require string-constants - mzlib/class - mzlib/list - framework - "drsig.ss") - - (import) - (export drscheme:modes^) - - (define-struct mode (name surrogate repl-submit matches-language)) - (define modes (list)) - - (define (get-modes) modes) - - (define (add-mode name surrogate repl-submit matches-language) - (let ([new-mode (make-mode name - surrogate - repl-submit - matches-language)]) - (set! modes (cons new-mode modes)) - new-mode)) - - (define (not-a-language-language? l) - (and (not (null? l)) - (equal? (car (last-pair l)) - (string-constant no-language-chosen)))) - - (define (add-initial-modes) - - ;; must be added first, to make it last in mode list, - ;; since predicate matches everything - (add-mode - (string-constant scheme-mode) - (new scheme:text-mode%) - (λ (text prompt-position) (scheme:text-balanced? text prompt-position)) - (λ (l) #t)) - - (add-mode - (string-constant text-mode) - #f - (λ (text prompt-position) #t) - (λ (l) - (and l - (or (not-a-language-language? l) - (ormap (λ (x) (regexp-match #rx"Algol" x)) l)))))) diff --git a/collects/drscheme/private/module-browser.ss b/collects/drscheme/private/module-browser.ss deleted file mode 100644 index 5a6a825258..0000000000 --- a/collects/drscheme/private/module-browser.ss +++ /dev/null @@ -1,1002 +0,0 @@ -#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 deleted file mode 100644 index 8355ae8545..0000000000 --- a/collects/drscheme/private/module-language.ss +++ /dev/null @@ -1,535 +0,0 @@ -#lang scheme/unit - -(require scheme/unit - scheme/class - scheme/list - mred - compiler/embed - launcher - framework - string-constants - "drsig.ss" - scheme/contract) - -(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:rep: drscheme:rep^]) -(export drscheme:module-language^) - -(define module-language<%> - (interface () - )) - -;; add-module-language : -> void -;; adds the special module-only language to drscheme -(define (add-module-language) - (define module-language% - (module-mixin - ((drscheme:language:get-default-mixin) - (drscheme:language:module-based-language->language-mixin - (drscheme:language:simple-module-based-language->module-based-language-mixin - drscheme:language:simple-module-based-language%))))) - (drscheme:language-configuration:add-language - (new module-language%))) - -;; collection-paths : (listof (union 'default string)) -;; command-line-args : (vectorof string) -(define-struct (module-language-settings drscheme:language:simple-settings) - (collection-paths command-line-args)) - -;; module-mixin : (implements drscheme:language:language<%>) -;; -> (implements drscheme:language:language<%>) -(define (module-mixin %) - (class* % (drscheme:language:language<%> module-language<%>) - (define/override (use-namespace-require/copy?) #t) - (field [iteration-number 0]) - - (define/augment (capability-value key) - (if (eq? key 'drscheme:autocomplete-words) - (drscheme:language-configuration:get-all-scheme-manual-keywords) - (drscheme:language:get-capability-default key))) - - ;; config-panel : as in super class - ;; uses drscheme:language:simple-module-based-language-config-panel and - ;; adds a collection paths configuration to it. - (define/override (config-panel parent) - (module-language-config-panel parent)) - - (define/override (default-settings) - (let ([super-defaults (super default-settings)]) - (apply make-module-language-settings - (append (vector->list (drscheme:language:simple-settings->vector - super-defaults)) - (list '(default) - #()))))) - - ;; default-settings? : -> boolean - (define/override (default-settings? settings) - (and (super default-settings? settings) - (equal? (module-language-settings-collection-paths settings) - '(default)) - (equal? (module-language-settings-command-line-args settings) - #()))) - - (define/override (marshall-settings settings) - (let ([super-marshalled (super marshall-settings settings)]) - (list super-marshalled - (module-language-settings-collection-paths settings) - (module-language-settings-command-line-args settings)))) - - (define/override (unmarshall-settings marshalled) - (and (pair? marshalled) - (pair? (cdr marshalled)) - (pair? (cddr marshalled)) - (null? (cdddr marshalled)) - (list? (cadr marshalled)) - (vector? (caddr marshalled)) - (andmap string? (vector->list (caddr marshalled))) - (andmap (λ (x) (or (string? x) (symbol? x))) - (cadr marshalled)) - (let ([super (super unmarshall-settings (car marshalled))]) - (and super - (apply make-module-language-settings - (append - (vector->list (drscheme:language:simple-settings->vector super)) - (list (cadr marshalled) - (caddr marshalled)))))))) - - (define/override (on-execute settings run-in-user-thread) - (set! iteration-number 0) - (super on-execute settings run-in-user-thread) - (run-in-user-thread - (λ () - (current-command-line-arguments - (module-language-settings-command-line-args settings)) - (let ([default (current-library-collection-paths)]) - (current-library-collection-paths - (append-map - (λ (x) (if (symbol? x) default (list x))) - (module-language-settings-collection-paths settings))))))) - - (define/override (get-one-line-summary) - (string-constant module-language-one-line-summary)) - - (inherit get-reader) - (define/override (front-end/interaction port settings) - (if (thread-cell-ref hopeless-repl) - (hopeless-shout) - (super front-end/interaction port settings))) - - (define/override (front-end/complete-program port settings) - (let* ([super-thunk (λ () ((get-reader) (object-name port) port))] - [path (get-filename port)] - [module-name #f] - [get-require-module-name - (λ () - ;; "clearing out" the module-name via datum->syntax ensures - ;; that check syntax doesn't think the original module name - ;; is being used in this require (so it doesn't get turned red) - (datum->syntax #'here (syntax-e module-name)))]) - (λ () - (set! iteration-number (+ iteration-number 1)) - (case iteration-number - [(1) - #`(current-module-declare-name - (if #,path - (make-resolved-module-path '#,path) - #f))] - [(2) - (let ([super-result (super-thunk)]) - (if (eof-object? super-result) - (hopeless-shout) - (let-values ([(name new-module) - (transform-module path super-result)]) - (set! module-name name) - new-module)))] - [(3) - (let ([super-result (super-thunk)]) - (if (eof-object? super-result) - #`(current-module-declare-name #f) - (hopeless-shout - "there can only be one expression in the definitions window" - super-result)))] - [(4) - (if path - #`(begin ((current-module-name-resolver) - (make-resolved-module-path #,path)) - (call-with-continuation-prompt - (λ () (dynamic-require #,path #f)))) - #`(call-with-continuation-prompt - (λ () (dynamic-require ''#,(get-require-module-name) #f))))] - [(5) - (if path - #`(#%app current-namespace (#%app module->namespace #,path)) - #`(#%app current-namespace - (#%app module->namespace - ''#,(get-require-module-name))))] - [else eof])))) - - ;; printer settings are just ignored here. - (define/override (create-executable setting parent program-filename) - (let* ([executable-specs (drscheme:language:create-executable-gui - parent program-filename #t #t)]) - (when executable-specs - (let ([launcher? (eq? 'launcher (car executable-specs))] - [gui? (eq? 'mred (cadr executable-specs))] - [executable-filename (caddr executable-specs)]) - (with-handlers ([(λ (x) #f) ;exn:fail? - (λ (x) - (message-box - (string-constant drscheme) - (if (exn? x) - (format "~a" (exn-message x)) - (format "uncaught exception: ~s" x))))]) - (if (not launcher?) - (let ([short-program-name - (let-values ([(base name dir) (split-path program-filename)]) - (path-replace-suffix name #""))]) - ((if (eq? 'distribution (car executable-specs)) - drscheme:language:create-distribution-for-executable - (lambda (executable-filename gui? make) - (make executable-filename))) - executable-filename - gui? - (lambda (exe-name) - (create-embedding-executable - exe-name - #:mred? gui? - #:verbose? #f ;; verbose? - #:modules (list (list #f program-filename)) - #:literal-expression - (begin - (parameterize ([current-namespace (make-base-empty-namespace)]) - (namespace-require 'scheme/base) - (compile - `(namespace-require '',(string->symbol (path->string short-program-name)))))) - #:cmdline null)))) - (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)]) - (make-launcher (list "-qt-" (path->string program-filename)) - executable-filename)))))))) - - (super-new - [module #f] - [language-position (list "Module")] - [language-numbers (list -32768)]))) - -(define hopeless-repl (make-thread-cell #t)) -(define (hopeless-shout . error-args) - (let ([t (current-thread)]) - (queue-callback - (λ () - (fprintf (current-error-port) "\n(Further interactions disabled.)\n") - ;; special value that will exit the repl but avoid the popup - (exit "NO NEED TO POPUP A TERMINATION EXPLANATION"))) - (apply raise-syntax-error '|Module Language| - (if (null? error-args) - (list (string-append - "There must be a valid module in the\n" - "definitions window. Try starting your program with\n" - "\n" - " #lang scheme\n" - "\n" - "and clicking ‘Run’.")) - error-args)))) - -;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) -(define (module-language-config-panel parent) - (define new-parent - (new vertical-panel% - [parent parent] - [alignment '(center center)] - [stretchable-height #f] - [stretchable-width #f])) - (define simple-case-lambda - (drscheme:language:simple-module-based-language-config-panel new-parent)) - (define cp-panel (new group-box-panel% - [parent new-parent] - [label (string-constant ml-cp-collection-paths)])) - - (define args-panel (new group-box-panel% - [parent new-parent] - [label (string-constant ml-command-line-arguments)])) - (define args-text-box (new text-field% - [parent args-panel] - [label #f] - [init-value "#()"] - [callback void])) - - ;; data associated with each item in listbox : boolean - ;; indicates if the entry is the default paths. - (define lb (new list-box% - [parent cp-panel] - [choices '("a" "b" "c")] - [label #f] - [callback (λ (x y) (update-buttons))])) - (define button-panel (new horizontal-panel% - [parent cp-panel] - [alignment '(center center)] - [stretchable-height #f])) - (define add-button - (make-object button% (string-constant ml-cp-add) button-panel - (λ (x y) (add-callback)))) - (define add-default-button - (make-object button% (string-constant ml-cp-add-default) button-panel - (λ (x y) (add-default-callback)))) - (define remove-button - (make-object button% (string-constant ml-cp-remove) button-panel - (λ (x y) (remove-callback)))) - (define raise-button - (make-object button% (string-constant ml-cp-raise) button-panel - (λ (x y) (move-callback -1)))) - (define lower-button - (make-object button% (string-constant ml-cp-lower) button-panel - (λ (x y) (move-callback +1)))) - - (define (update-buttons) - (let ([lb-selection (send lb get-selection)] - [lb-tot (send lb get-number)]) - (send remove-button enable lb-selection) - (send raise-button enable (and lb-selection (not (= lb-selection 0)))) - (send lower-button enable - (and lb-selection (not (= lb-selection (- lb-tot 1))))))) - - (define (add-callback) - (let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path) - (send parent get-top-level-window))]) - (when dir - (send lb append (path->string dir) #f) - (update-buttons)))) - - (define (add-default-callback) - (cond [(has-default?) - (message-box (string-constant drscheme) - (string-constant ml-cp-default-already-present) - (send parent get-top-level-window))] - [else - (send lb append (string-constant ml-cp-default-collection-path) #t) - (update-buttons)])) - - ;; has-default? : -> boolean - ;; returns #t if the `default' entry has already been added - (define (has-default?) - (let loop ([n (send lb get-number)]) - (cond [(= n 0) #f] - [(send lb get-data (- n 1)) #t] - [else (loop (- n 1))]))) - - (define (remove-callback) - (let ([to-delete (send lb get-selection)]) - (send lb delete to-delete) - (unless (zero? (send lb get-number)) - (send lb set-selection (min to-delete (- (send lb get-number) 1)))) - (update-buttons))) - - (define (move-callback d) - (let* ([sel (send lb get-selection)] - [vec (get-lb-vector)] - [new (+ sel d)] - [other (vector-ref vec new)]) - (vector-set! vec new (vector-ref vec sel)) - (vector-set! vec sel other) - (set-lb-vector vec) - (send lb set-selection new) - (update-buttons))) - - (define (get-lb-vector) - (list->vector (for/list ([n (in-range (send lb get-number))]) - (cons (send lb get-string n) (send lb get-data n))))) - - (define (set-lb-vector vec) - (send lb clear) - (for ([x (in-vector vec)] [n (in-naturals)]) - (send lb append (car x)) - (send lb set-data n (cdr x)))) - - (define (get-collection-paths) - (for/list ([n (in-range (send lb get-number))]) - (let ([data (send lb get-data n)]) - (if data 'default (send lb get-string n))))) - - (define (install-collection-paths paths) - (send lb clear) - (for ([cp paths]) - (if (symbol? cp) - (send lb append (string-constant ml-cp-default-collection-path) #t) - (send lb append cp #f)))) - - (define (get-command-line-args) - (let* ([str (send args-text-box get-value)] - [read-res (parameterize ([read-accept-graph #f]) - (with-handlers ([exn:fail:read? (λ (x) #())]) - (read (open-input-string str))))]) - (if (and (vector? read-res) (andmap string? (vector->list read-res))) - read-res - #()))) - - (define (install-command-line-args vec) - (send args-text-box set-value - (parameterize ([print-vector-length #f]) (format "~s" vec)))) - - (send lb set '()) - (update-buttons) - - (case-lambda - [() - (let ([simple-settings (simple-case-lambda)]) - (apply make-module-language-settings - (append (vector->list (drscheme:language:simple-settings->vector - simple-settings)) - (list (get-collection-paths) - (get-command-line-args)))))] - [(settings) - (simple-case-lambda settings) - (install-collection-paths - (module-language-settings-collection-paths settings)) - (install-command-line-args - (module-language-settings-command-line-args settings)) - (update-buttons)])) - -;; transform-module : (union #f string) syntax -;; -> (values syntax[name-of-module] syntax[module]) -;; = User = -;; in addition to exporting everything, the result module's name -;; is the fully path-expanded name with a directory prefix, -;; if the file has been saved -(define (transform-module filename stx) - (syntax-case* stx (module) (λ (x y) (eq? (syntax-e x) (syntax-e y))) - [(module name lang . rest) - (eq? 'module (syntax-e #'module)) - (let ([v-name #'name]) - (when filename (check-filename-matches filename v-name stx)) - (thread-cell-set! hopeless-repl #f) - (values - v-name - ;; rewrite the module to use the scheme/base version of `module' - (let* ([mod (datum->syntax #'here 'module #'form)] - [expr (datum->syntax stx `(,mod ,#'name ,#'lang . ,#'rest) stx)]) - ;; now expand it, and if there's an error, then use a minimal module - ;; that will use the language as usual and report the error, it'll - ;; turn to 3d code: - ;; (module (raise )) - ;; so the repl will have at least the language bindings. (this won't - ;; work right with a bad language name -- but that kind of error will - ;; be reported anyway.) - (with-handlers - ([void (lambda (e) - (fprintf (current-error-port) - (string-append - "*** Module Language: there is a syntax error" - " in your code, so it was not evaluated;\n" - "*** the interactions below have only the" - " language bindings for ‘~s’\n") - (syntax->datum #'lang)) - (datum->syntax - stx `(,mod ,#'name ,#'lang ,#`(#%app raise #,e)) stx))]) - (expand expr)))))] - [else (hopeless-shout - (string-append "only a module expression is allowed, either\n" - " #lang \n or\n" - " (module ...)\n") - stx)])) - -;; get-filename : port -> (union string #f) -;; extracts the file the definitions window is being saved in, if any. -(define (get-filename port) - (let ([source (object-name port)]) - (cond - [(path? source) source] - [(is-a? source text%) - (let ([canvas (send source get-canvas)]) - (and canvas - (let ([frame (send canvas get-top-level-window)]) - (and (is-a? frame drscheme:unit:frame%) - (let* ([b (box #f)] - [filename (send (send frame get-definitions-text) - get-filename - b)]) - (if (unbox b) - #f - filename))))))] - [else #f]))) - -;; check-filename-matches : string datum syntax -> void -(define (check-filename-matches filename name unexpanded-stx) - (define datum (syntax-e name)) - (unless (symbol? datum) - (hopeless-shout "bad syntax in name position of module" - unexpanded-stx name)) - (let-values ([(base name dir?) (split-path filename)]) - (let ([expected (string->symbol - (path->string (path-replace-suffix name #"")))]) - (unless (equal? expected datum) - (hopeless-shout - (format - "module name doesn't match saved filename, got ~s and expected ~s" - datum - expected) - unexpanded-stx))))) - -(define module-language-put-file-mixin - (mixin (text:basic<%>) () - (inherit get-text last-position get-character get-top-level-window) - (define/override (put-file directory default-name) - (let ([tlw (get-top-level-window)]) - (if (and tlw (is-a? tlw drscheme:unit:frame<%>)) - (let* ([definitions-text (send tlw get-definitions-text)] - [module-language? - (is-a? (drscheme:language-configuration:language-settings-language - (send definitions-text get-next-settings)) - module-language<%>)] - [module-default-filename - (and module-language? (get-module-filename))]) - (super put-file directory module-default-filename)) - (super put-file directory default-name)))) - - ;; returns the name after "(module " suffixed with .scm - ;; in the beginning of the editor - ;; or #f if the beginning doesn't match "(module " - (define/private (get-module-filename) - (let ([open-paren (skip-whitespace 0)]) - (or (match-paren open-paren "(") - (match-paren open-paren "[") - (match-paren open-paren "{")))) - - (define/private (match-paren open-paren paren) - (and (matches open-paren paren) - (let ([module (skip-whitespace (+ open-paren 1))]) - (and (matches module "module") - (let* ([end-module (+ module (string-length "module"))] - [filename-start (skip-whitespace end-module)] - [filename-end (skip-to-whitespace filename-start)]) - (and (not (= filename-start end-module)) - (string-append (get-text filename-start filename-end) - ".scm"))))))) - - - (define/private (matches start string) - (let ([last-pos (last-position)]) - (let loop ([i 0]) - (cond [(and (i . < . (string-length string)) - ((+ i start) . < . last-pos)) - (and (char=? (string-ref string i) - (get-character (+ i start))) - (loop (+ i 1)))] - [(= i (string-length string)) #t] - [else #f])))) - - (define/private (skip-whitespace start) - (let ([last-pos (last-position)]) - (let loop ([pos start]) - (if (pos . >= . last-pos) - last-pos - (let ([char (get-character pos)]) - (if (char-whitespace? char) - (loop (+ pos 1)) - pos)))))) - - (define/private (skip-to-whitespace start) - (let ([last-pos (last-position)]) - (let loop ([pos start]) - (cond [(pos . >= . last-pos) last-pos] - [(char-whitespace? (get-character pos)) pos] - [else (loop (+ pos 1))])))) - - (super-new))) diff --git a/collects/drscheme/private/multi-file-search.ss b/collects/drscheme/private/multi-file-search.ss deleted file mode 100644 index 15c8cc1ab7..0000000000 --- a/collects/drscheme/private/multi-file-search.ss +++ /dev/null @@ -1,716 +0,0 @@ - -#lang scheme/unit - (require framework - mzlib/class - mred - scheme/file - scheme/path - mzlib/thread - mzlib/async-channel - string-constants - "drsig.ss") - - (import [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:unit: drscheme:unit^]) - (export drscheme:multi-file-search^) - - ;; multi-file-search : -> void - ;; opens a dialog to configure the search and initiates the search - (define (multi-file-search) - (let ([search-info (configure-search)]) - (when search-info - (open-search-window search-info)))) - - ;; searcher = (string (string int int int -> void) -> void) - ;; this performs a single search. - ;; the first argument is the filename to be searched - ;; the second argument is called for each match. - ;; the arguments are: line-string line-number col-number match-length - - - ;; search-type = (make-search-type string make-searcher (listof (cons string boolean))) - ;; the param strings are the labels for checkboxes - ;; the param booleans are the default values for the checkboxes - ;; these are the available searches - (define-struct search-type (label make-searcher params)) - - ;; search-info = (make-search-info string boolean (union #f regexp) search-type) - (define-struct search-info (dir recur? filter searcher)) - - ;; search-types : (listof search-type) - (define search-types - (list (make-search-type - (string-constant mfs-string-match/graphics) - (λ (info search-string) (exact-match-searcher info search-string)) - (list (cons (string-constant mfs-case-sensitive-label) #f))) - (make-search-type - (string-constant mfs-regexp-match/no-graphics) - (λ (info search-string) (regexp-match-searcher info search-string)) - (list)))) - - ;; search-entry = (make-search-entry string number number number) - (define-struct search-entry (filename line-string line-number col-number match-length)) - - ;; preferences initialization - (preferences:set-default 'drscheme:multi-file-search:recur? #t boolean?) - (preferences:set-default 'drscheme:multi-file-search:filter? #t boolean?) - (preferences:set-default 'drscheme:multi-file-search:filter-string "\\.(ss|scm)$" string?) - (preferences:set-default 'drscheme:multi-file-search:search-string "" string?) - (preferences:set-default 'drscheme:multi-file-search:search-type - 1 - (λ (x) - (and (number? x) - (exact? x) - (integer? x) - (<= 0 x) - (< x (length search-types))))) - - ;; drscheme:mult-file-search:search-check-boxes : (listof (listof boolean)) - (preferences:set-default 'drscheme:multi-file-search:search-check-boxes - (map (λ (x) (map cdr (search-type-params x))) - search-types) - (λ (x) - (and (list? x) - (andmap (λ (x) - (and (list? x) - (andmap boolean? x))) - x)))) - - (preferences:set-default 'drscheme:multi-file-search:percentages - '(1/3 2/3) - (λ (x) (and (list? x) - (= 2 (length x)) - (= 1 (apply + x))))) - - (preferences:set-default 'drscheme:multi-file-search:frame-size '(300 . 400) - (λ (x) (and (pair? x) - (number? (car x)) - (number? (cdr x))))) - (preferences:set-default 'drscheme:multi-file-search:directory - ;; The default is #f because - ;; filesystem-root-list is expensive under Windows - #f - (lambda (x) (or (not x) (path? x)))) - (preferences:set-un/marshall - 'drscheme:multi-file-search:directory - (λ (v) (and v (path->string v))) - (λ (p) (if (path-string? p) - (string->path p) - #f))) - - - ;; open-search-window : search-info -> void - ;; thread: eventspace main thread - ;; opens a window and creates the thread that does the search - (define (open-search-window search-info) - (define frame (make-object search-size-frame% (string-constant mfs-drscheme-multi-file-search))) - (define panel (make-object saved-vertical-resizable% (send frame get-area-container))) - (define button-panel (make-object horizontal-panel% (send frame get-area-container))) - (define open-button (make-object button% (string-constant mfs-open-file) button-panel - (λ (x y) (open-file-callback)))) - (define stop-button (make-object button% (string-constant mfs-stop-search) button-panel - (λ (x y) (stop-callback)))) - (define grow-box-pane (make-object grow-box-spacer-pane% button-panel)) - - (define zoom-text (make-object scheme:text%)) - (define results-text (make-object results-text% zoom-text)) - (define results-ec (instantiate searching-canvas% () - (parent panel) - (editor results-text) - (frame frame))) - (define zoom-ec (instantiate searching-canvas% () - (parent panel) - (editor zoom-text) - (frame frame))) - - (define (open-file-callback) - (send results-text open-file)) - - ;; sometimes, breaking the other thread puts - ;; the break message in the channel behind - ;; many many requests. Rather than show those, - ;; we use the `broken?' flag as a shortcut. - (define broken? #f) - (define (stop-callback) - (break-thread search-thd) - (set! broken? #t) - (send stop-button enable #f)) - - ;; channel : async-channel[(union 'done search-entry)] - (define channel (make-async-channel 100)) - (define search-thd (thread (λ () (do-search search-info channel)))) - - (send frame set-text-to-search results-text) ;; just to initialize it to something. - (send results-text lock #t) - (send frame reflow-container) - (send panel set-percentages (preferences:get 'drscheme:multi-file-search:percentages)) - (send button-panel set-alignment 'right 'center) - (send button-panel stretchable-height #f) - (send frame show #t) - - (let loop () - (let ([match (yield channel)]) - (yield) - (cond - [(eq? match 'done) - (send results-text search-complete) - (send stop-button enable #f)] - [(or broken? (eq? match 'break)) - (send results-text search-interrupted)] - [else - (send results-text add-match - (search-info-dir search-info) - (search-entry-filename match) - (search-entry-line-string match) - (search-entry-line-number match) - (search-entry-col-number match) - (search-entry-match-length match)) - (loop)])))) - - (define results-super-text% - (text:hide-caret/selection-mixin - (text:basic-mixin - (editor:standard-style-list-mixin - (editor:basic-mixin - text%))))) - - ;; results-text% : derived from text% - ;; init args: zoom-text - ;; zoom-text : (instance-of text%) - ;; public-methods: - ;; add-match : string string int int int int -> void - ;; adds a match to the text - ;; search-interrupted : -> void - ;; inserts a message saying "search interrupted". - ;; search-complete is not expected to be called if this method is called. - ;; search-complete : -> void - ;; inserts a message saying "no matches found" if none were reported - (define results-text% - (class results-super-text% - (init-field zoom-text) - (inherit insert last-paragraph erase - paragraph-start-position paragraph-end-position - last-position change-style - set-clickback set-position - end-edit-sequence begin-edit-sequence - lock) - - [define filename-delta (make-object style-delta% 'change-bold)] - [define match-delta (let ([d (make-object style-delta%)]) - (send d set-delta-foreground - (make-object color% - 0 - 160 - 0)) - d)] - [define hilite-line-delta (make-object style-delta% 'change-style 'italic)] - [define unhilite-line-delta (make-object style-delta% 'change-style 'normal)] - [define widest-filename #f] - [define/private indent-all-lines - ;; indent-all-lines : number -> void - ;; inserts `offset' spaces to the beginning of each line, - ;; except the last one. Must be at least one such line in the text. - (λ (offset) - (let ([spaces (make-string offset #\space)]) - (let loop ([para (- (last-paragraph) 1)]) - (let ([para-start (paragraph-start-position para)]) - (insert spaces para-start para-start) - (change-style filename-delta para-start (+ para-start offset))) - (unless (zero? para) - (loop (- para 1))))))] - - ;; match-shown? : boolean - ;; indicates if a match has ever been shown. - ;; if not, need to clean out the "searching" message - ;; and show a match. Done in `add-match' - [define match-shown? #f] - - ;; current-file : (union #f string) - ;; the name of the currently viewed file, if one if viewed. - ;; line-in-current-file and col-in-current-file are linked - [define current-file #f] - [define line-in-current-file #f] - [define col-in-current-file #f] - - [define old-line #f] - [define/private hilite-line - (λ (line) - (begin-edit-sequence) - (lock #f) - (when old-line - (change-style unhilite-line-delta - (paragraph-start-position old-line) - (paragraph-end-position old-line))) - (when line - (change-style hilite-line-delta - (paragraph-start-position line) - (paragraph-end-position line))) - (set! old-line line) - (lock #t) - (end-edit-sequence))] - - [define/public (open-file) - (when current-file - (let ([f (handler:edit-file current-file)]) - (when (and f - (is-a? f drscheme:unit:frame<%>)) - (let* ([t (send f get-definitions-text)] - [pos (+ (send t paragraph-start-position line-in-current-file) - col-in-current-file)]) - (send t set-position pos)))))] - - [define/public add-match - (λ (base-filename full-filename line-string line-number col-number match-length) - (lock #f) - (let* ([new-line-position (last-position)] - [short-filename - (path->string - (find-relative-path - (normalize-path base-filename) - (normalize-path full-filename)))] - [this-match-number (last-paragraph)] - [len (string-length short-filename)] - [insertion-start #f] - [show-this-match - (λ () - (set! match-shown? #t) - (set! current-file full-filename) - (set! line-in-current-file line-number) - (set! col-in-current-file col-number) - (set-position new-line-position new-line-position) - (send zoom-text begin-edit-sequence) - (send zoom-text lock #f) - (send zoom-text load-file/gui-error full-filename) - (send zoom-text set-position (send zoom-text paragraph-start-position line-number)) - (let ([start (+ (send zoom-text paragraph-start-position line-number) - col-number)]) - (send zoom-text change-style match-delta start (+ start match-length))) - (send zoom-text lock #t) - (send zoom-text set-caret-owner #f 'global) - (hilite-line this-match-number) - (send zoom-text end-edit-sequence))]) - (unless match-shown? - (erase)) - (unless widest-filename - (set! widest-filename len)) - (if (<= len widest-filename) - (begin - (set! insertion-start (last-position)) - (insert (make-string (- widest-filename len) #\space) - (last-position) (last-position))) - (begin - (indent-all-lines (- len widest-filename)) - (set! insertion-start (last-position)) - (set! widest-filename len))) - (let ([filename-start (last-position)]) - (insert short-filename (last-position) (last-position)) - (insert ": " (last-position) (last-position)) - (change-style filename-delta insertion-start (last-position)) - (let ([line-start (last-position)]) - (insert line-string (last-position) (last-position)) - (change-style match-delta - (+ line-start col-number) - (+ line-start col-number match-length))) - (set-clickback filename-start (last-position) - (λ (_1 _2 _3) - (show-this-match))) - (insert #\newline (last-position) (last-position)) - - (unless match-shown? - (show-this-match)))) - (lock #t))] - - (define/public (search-interrupted) - (lock #f) - (insert #\newline (last-position) (last-position)) - (insert (string-constant mfs-search-interrupted) (last-position) (last-position)) - (lock #t)) - - (define/public (search-complete) - (unless match-shown? - (lock #f) - (insert #\newline (last-position) (last-position)) - (insert (string-constant mfs-no-matches-found) (last-position) (last-position)) - (lock #t))) - - (inherit get-style-list set-style-list set-styles-sticky) - (super-instantiate ()) - (send zoom-text lock #t) - (set-styles-sticky #f) - (insert (string-constant mfs-searching...)))) - - ;; collaborates with search-size-frame% - (define searching-canvas% - (class canvas:basic% - (init-field frame) - (inherit get-editor) - (define/override (on-focus on?) - (when on? - (send frame set-text-to-search (get-editor))) - (super on-focus on?)) - (super-instantiate ()))) - - ;; thread: eventspace main thread - (define search-size-frame% - (class (drscheme:frame:basics-mixin - (frame:searchable-mixin - frame:standard-menus%)) - (init-field name) - - (field [text-to-search #f]) - (define/public (set-text-to-search text) (set! text-to-search text)) - (define/override (get-text-to-search) text-to-search) - - (define/override (on-size w h) - (preferences:set 'drscheme:multi-file-search:frame-size (cons w h)) - (super on-size w h)) - (let ([size (preferences:get 'drscheme:multi-file-search:frame-size)]) - (super-instantiate () - (label name) - (width (car size)) - (height (cdr size)))))) - - - ;; this vertical-resizable class just remembers the percentage between the - ;; two panels - ;; thread: eventspace main thread - (define saved-vertical-resizable% - (class panel:vertical-dragable% - (inherit get-percentages) - (define/augment (after-percentage-change) - (let ([ps (get-percentages)]) - (when (= (length ps) 2) - (preferences:set 'drscheme:multi-file-search:percentages ps))) - (inner (void) after-percentage-change)) - (super-instantiate ()))) - - ;; configure-search : -> (union #f search-info) - ;; thread: eventspace main thread - ;; configures the search - (define (configure-search) - (define dialog (make-object dialog% (string-constant mfs-configure-search) - #f 500 #f #f #f '(resize-border))) - (define outer-files-panel (make-object vertical-panel% dialog '(border))) - (define outer-method-panel (make-object vertical-panel% dialog '(border))) - (define button-panel (make-object horizontal-panel% dialog)) - (define files-label (make-object message% (string-constant mfs-files-section) outer-files-panel)) - (define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel)) - (define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel)) - (define files-panel (make-object vertical-panel% files-inset-outer-panel)) - (define method-label (make-object message% (string-constant mfs-search-section) outer-method-panel)) - (define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel)) - (define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel)) - (define method-panel (make-object vertical-panel% method-inset-outer-panel)) - - (define dir-panel (make-object horizontal-panel% files-panel)) - (define dir-field (make-object text-field% (string-constant mfs-dir) dir-panel - (λ (x y) (dir-field-callback)))) - (define dir-button (make-object button% (string-constant browse...) dir-panel - (λ (x y) (dir-button-callback)))) - - (define recur-check-box (make-object check-box% (string-constant mfs-recur-over-subdirectories) files-panel - (λ (x y) (recur-check-box-callback)))) - - (define filter-panel (make-object horizontal-panel% files-panel)) - (define filter-check-box (make-object check-box% (string-constant mfs-regexp-filename-filter) filter-panel - (λ (x y) (filter-check-box-callback)))) - (define filter-text-field (make-object text-field% #f filter-panel - (λ (x y) (filter-text-field-callback)))) - - (define methods-choice (make-object choice% #f (map search-type-label search-types) method-panel - (λ (x y) (methods-choice-callback)))) - (define search-text-field (make-object text-field% (string-constant mfs-search-string) method-panel - (λ (x y) (search-text-field-callback)))) - (define active-method-panel (make-object panel:single% method-panel)) - (define methods-check-boxess - (let ([pref (preferences:get 'drscheme:multi-file-search:search-check-boxes)]) - (map - (λ (search-type prefs-settings) - (let ([p (make-object vertical-panel% active-method-panel)] - [params (search-type-params search-type)]) - (send p set-alignment 'left 'center) - (map (λ (flag-pair prefs-setting) - (let ([cb (make-object check-box% - (car flag-pair) - p - (λ (evt chk) (method-callback chk)))]) - (send cb set-value prefs-setting) - cb)) - params - (if (= (length params) (length prefs-settings)) - prefs-settings - (map (λ (x) #f) params))))) - search-types - (if (= (length search-types) (length pref)) - pref - (map (λ (x) '()) search-types))))) - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons - button-panel - (λ (x y) (ok-button-callback)) - (λ (x y) (cancel-button-callback)))) - (define spacer (make-object grow-box-spacer-pane% button-panel)) - - ;; initialized to a searcher during the ok button callback - ;; so the user can be informed of an error before the dialog - ;; closes. - (define searcher #f) - - ;; initialized to a regexp if the user wants to filter filenames, - ;; during the ok-button-callback, so errors can be signalled. - (define filter #f) - - ;; title for message box that signals error messages - (define message-box-title (string-constant mfs-drscheme-multi-file-search)) - - (define (ok-button-callback) - (cond - [(with-handlers ([exn:fail:filesystem? - (λ (x) #f)]) - (directory-exists? (send dir-field get-value))) - (let ([_searcher - ((search-type-make-searcher (list-ref search-types (send methods-choice get-selection))) - (map (λ (cb) (send cb get-value)) - (send (send active-method-panel active-child) get-children)) - (send search-text-field get-value))]) - (if (string? _searcher) - (message-box message-box-title _searcher dialog) - (let ([regexp (with-handlers ([(λ (x) #t) - (λ (exn) - (format "~a" (exn-message exn)))]) - (and (send filter-check-box get-value) - (regexp (send filter-text-field get-value))))]) - (if (string? regexp) - (message-box message-box-title regexp dialog) - (begin (set! searcher _searcher) - (set! filter regexp) - (set! ok? #t) - (send dialog show #f))))))] - [else - (message-box message-box-title - (format (string-constant mfs-not-a-dir) (send dir-field get-value)) - dialog)])) - (define (cancel-button-callback) - (send dialog show #f)) - - (define (method-callback chk) - (preferences:set - 'drscheme:multi-file-search:search-check-boxes - (let loop ([methods-check-boxess methods-check-boxess]) - (cond - [(null? methods-check-boxess) null] - [else - (cons (let loop ([methods-check-boxes (car methods-check-boxess)]) - (cond - [(null? methods-check-boxes) null] - [else (cons (send (car methods-check-boxes) get-value) - (loop (cdr methods-check-boxes)))])) - (loop (cdr methods-check-boxess)))])))) - - (define (dir-field-callback) - (let ([df (send dir-field get-value)]) - (when (path-string? df) - (preferences:set 'drscheme:multi-file-search:directory (string->path df))))) - - (define (filter-check-box-callback) - (preferences:set 'drscheme:multi-file-search:filter? (send filter-check-box get-value)) - (send filter-text-field enable (send filter-check-box get-value))) - (define (filter-text-field-callback) - (preferences:set 'drscheme:multi-file-search:filter-string (send filter-text-field get-value))) - - (define (recur-check-box-callback) - (preferences:set 'drscheme:multi-file-search:recur? (send recur-check-box get-value))) - (define (methods-choice-callback) - (preferences:set 'drscheme:multi-file-search:search-type (send methods-choice get-selection)) - (send active-method-panel active-child - (list-ref (send active-method-panel get-children) - (send methods-choice get-selection)))) - (define (search-text-field-callback) - (preferences:set 'drscheme:multi-file-search:search-string (send search-text-field get-value))) - (define (dir-button-callback) - (let ([d (get-directory)]) - (when (and d - (directory-exists? d)) - (preferences:set 'drscheme:multi-file-search:directory d) - (send dir-field set-value (path->string d))))) - - (define (get-files) - (let ([dir (string->path (send dir-field get-value))]) - (and (directory-exists? dir) - (if (send recur-check-box get-value) - (build-recursive-file-list dir filter) - (build-flat-file-list dir filter))))) - - (define ok? #f) - - (send button-panel set-alignment 'right 'center) - (send dir-panel stretchable-height #f) - (send outer-files-panel stretchable-height #f) - (send outer-files-panel set-alignment 'left 'center) - (send files-inset-panel min-width 20) - (send files-inset-panel stretchable-width #f) - (send files-panel set-alignment 'left 'center) - - (send recur-check-box set-value (preferences:get 'drscheme:multi-file-search:recur?)) - (send filter-check-box set-value (preferences:get 'drscheme:multi-file-search:filter?)) - (send search-text-field set-value (preferences:get 'drscheme:multi-file-search:search-string)) - (send filter-text-field set-value (preferences:get 'drscheme:multi-file-search:filter-string)) - (send dir-field set-value (path->string - (let ([p (preferences:get 'drscheme:multi-file-search:directory)]) - (if (not p) - (let ([p (car (filesystem-root-list))]) - (preferences:set 'drscheme:multi-file-search:directory p) - p) - p)))) - - (send outer-method-panel stretchable-height #f) - (send outer-method-panel set-alignment 'left 'center) - (send method-inset-panel min-width 20) - (send method-inset-panel stretchable-width #f) - (send method-panel set-alignment 'left 'center) - (send filter-panel stretchable-height #f) - - (send search-text-field focus) - (send dialog show #t) - - (and - ok? - (make-search-info - (send dir-field get-value) - (send recur-check-box get-value) - (and (send filter-check-box get-value) - (regexp (send filter-text-field get-value))) - searcher))) - - - ;; do-search : search-info text -> void - ;; thread: searching thread - ;; called in a new thread that may be broken (to indicate a stop) - (define (do-search search-info channel) - (let* ([dir (search-info-dir search-info)] - [filter (search-info-filter search-info)] - [searcher (search-info-searcher search-info)] - [get-filenames (if (search-info-recur? search-info) - (build-recursive-file-list dir filter) - (build-flat-file-list dir filter))]) - (with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))]) - (let loop () - (let ([filename (get-filenames)]) - (when filename - (searcher filename - (λ (line-string line-number col-number match-length) - (async-channel-put - channel - (make-search-entry - filename - line-string - line-number - col-number - match-length)))) - (loop)))) - (async-channel-put channel 'done)))) - - ;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f)) - ;; thread: search thread - (define (build-recursive-file-list dir filter) - (letrec ([touched (make-hash)] - [next-thunk (λ () (process-dir dir (λ () #f)))] - [process-dir - ; string[dirname] (listof string[filename]) -> (listof string[filename]) - (λ (dir k) - (let* ([key (normalize-path dir)] - [traversed? (hash-ref touched key (λ () #f))]) - (if traversed? - (k) - (begin - (hash-set! touched key #t) - (process-dir-contents - (map (λ (x) (build-path dir x)) - (directory-list dir)) - k)))))] - [process-dir-contents - ; string[dirname] (listof string[filename]) -> (listof string[filename]) - (λ (contents k) - (cond - [(null? contents) - (k)] - [else - (let ([file/dir (car contents)]) - (cond - [(and (file-exists? file/dir) - (or (not filter) - (regexp-match filter (path->string file/dir)))) - (set! next-thunk - (λ () - (process-dir-contents (cdr contents) k))) - file/dir] - [(directory-exists? file/dir) - (process-dir-contents - (cdr contents) - (λ () - (process-dir file/dir k)))] - [else - (process-dir-contents (cdr contents) k)]))]))]) - (λ () (next-thunk)))) - - ;; build-flat-file-list : path (union #f regexp) -> (-> (union string #f)) - ;; thread: searching thread - (define (build-flat-file-list dir filter) - (let ([contents (map (λ (x) (build-path dir x)) (directory-list dir))]) - (λ () - (let loop () - (cond - [(null? contents) - #f] - [(and filter (regexp-match filter (path->string (car contents)))) - (begin0 - (car contents) - (set! contents (cdr contents)))] - [else - (set! contents (cdr contents)) - (loop)]))))) - - ;; exact-match-searcher : make-searcher - (define (exact-match-searcher params key) ;; thread: main eventspace thread - (let ([case-sensitive? (car params)]) - (λ (filename add-entry) ;; thread: searching thread - (let ([text (make-object text:basic%)]) - (send text load-file filename) - (let loop ([pos 0]) - (let ([found (send text find-string key 'forward pos 'eof #t case-sensitive?)]) - (when found - (let* ([para (send text position-paragraph found)] - [para-start (send text paragraph-start-position para)] - [line-string (send text get-text para-start - (send text paragraph-end-position para))] - [line-number para] - [col-number (- found para-start)] - [match-length (string-length key)]) - (add-entry line-string line-number col-number match-length) - (loop (+ found 1)))))))))) - - ;; regexp-match-searcher : make-searcher - ;; thread: searching thread - (define (regexp-match-searcher parmas key) ;; thread: main eventspace thread - (let ([re:key (with-handlers ([(λ (x) #t) - (λ (exn) - (format "~a" (exn-message exn)))]) - (regexp key))]) - (if (string? re:key) - re:key - (λ (filename add-entry) ;; thread: searching thread - (call-with-input-file filename - (λ (port) - (let loop ([line-number 0]) - (let ([line (read-line port)]) - (cond - [(eof-object? line) (void)] - [else - (let ([match (regexp-match-positions re:key line)]) - (when match - (let ([pos (car match)]) - (add-entry line line-number - (car pos) - (- (cdr pos) (car pos)))))) - (loop (+ line-number 1))])))) - #:mode 'text))))) diff --git a/collects/drscheme/private/number-snip.ss b/collects/drscheme/private/number-snip.ss deleted file mode 100644 index 0cb5347273..0000000000 --- a/collects/drscheme/private/number-snip.ss +++ /dev/null @@ -1,9 +0,0 @@ -(module number-snip mzscheme - (require mred - mzlib/class - framework) - - (provide snip-class) - (define snip-class (make-object number-snip:snip-class%)) - (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private"))) - (send (get-the-snip-class-list) add snip-class)) diff --git a/collects/drscheme/private/recon.ss b/collects/drscheme/private/recon.ss deleted file mode 100644 index 19993c224e..0000000000 --- a/collects/drscheme/private/recon.ss +++ /dev/null @@ -1,19 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base)) -(provide reconstitute) - -(begin-for-syntax - (define-struct sloc (inside loc) #:omit-define-syntaxes #:prefab)) - -(define-syntax (reconstitute orig-stx) - (syntax-case orig-stx () - [(_ arg src) - (let loop ([stx #'arg]) - (cond - [(syntax? stx) (datum->syntax stx (loop (syntax-e stx)))] - [(pair? stx) (cons (loop (car stx)) (loop (cdr stx)))] - [(sloc? stx) - (datum->syntax #'src - (loop (syntax-e (sloc-inside stx))) - (syntax->datum (sloc-loc stx)))] - [else stx]))])) \ No newline at end of file diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss deleted file mode 100644 index 10f63cc30e..0000000000 --- a/collects/drscheme/private/rep.ss +++ /dev/null @@ -1,1840 +0,0 @@ -#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)) - - ;; special value that is used with `exit' when we don't want the popup - (define no-terminate-explanation-string - "NO NEED TO POPUP A TERMINATION EXPLANATION") - - (define/private (cleanup) - (set! in-evaluation? #f) - (update-running #f) - (unless (and (get-user-thread) (thread-running? (get-user-thread))) - (lock #t) - (unless (or shutting-down? - (equal? user-exit-code no-terminate-explanation-string)) - (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 (or (and (integer? x) (<= 0 x 255)) - (equal? x no-terminate-explanation-string)) - 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%))))))))))))) diff --git a/collects/drscheme/private/stick-figures.ss b/collects/drscheme/private/stick-figures.ss deleted file mode 100644 index 380e18e15a..0000000000 --- a/collects/drscheme/private/stick-figures.ss +++ /dev/null @@ -1,341 +0,0 @@ -(module stick-figures mzscheme - (require mzlib/class - mzlib/pretty - mred) - - (define head-size 40) - (define small-bitmap-factor 1/2) - (define small-factor 1/5) - (define line-size 2) - - (define waiting-points - '((head 47 2) - (neck 46 15) - (shoulders 38 42) - (left-shoulder 18 39) - (right-shoulder 65 42) - (left-elbow 8 74) - (right-elbow 68 76) - (left-hand 24 79) - (right-hand 56 83) - (waist 37 87) - (left-knee 23 117) - (right-knee 57 117) - (left-ankle 21 149) - (right-ankle 59 148) - (left-toe 3 148) - (right-toe 79 145))) - - (define waiting-points/2 - '((head 47 2) - (neck 46 15) - (shoulders 38 42) - (left-shoulder 18 39) - (right-shoulder 65 42) - (left-elbow 8 74) - (right-elbow 68 76) - (left-hand 24 79) - (right-hand 56 83) - (waist 37 87) - (left-knee 23 117) - (right-knee 57 117) - (left-ankle 21 149) - (right-ankle 59 148) - (left-toe 3 148) - (right-toe 79 132))) - - (define waiting-points/old - '((head 55 0) - (neck 43 18) - (shoulders 37 33) - (left-shoulder 23 34) - (right-shoulder 50 37) - (left-elbow 8 74) - (right-elbow 66 69) - (left-hand 60 78) - (right-hand 68 18) - (waist 37 87) - (left-knee 19 122) - (right-knee 57 117) - (left-ankle 19 154) - (right-ankle 62 155) - (left-toe 0 154) - (right-toe 83 146))) - - (define waiting-points/2/old - '((head 55 0) - (neck 43 18) - (shoulders 37 33) - (left-shoulder 23 34) - (right-shoulder 50 37) - (left-elbow 8 74) - (right-elbow 66 69) - (left-hand 60 78) - (right-hand 68 18) - (waist 37 87) - (left-knee 19 122) - (right-knee 57 117) - (left-ankle 19 154) - (left-toe 0 154) - (right-ankle 62 155) - (right-toe 83 154))) - - (define running-points - '((head 130 18) - (neck 114 33) - (shoulders 105 44) - (left-shoulder 105 44) - (right-shoulder 105 44) - (left-elbow 71 28) - (right-elbow 115 67) - (left-hand 50 54) - (right-hand 148 53) - (waist 59 78) - (left-knee 41 112) - (right-knee 97 93) - (left-ankle 0 129) - (right-ankle 89 132) - (left-toe 14 146) - (right-toe 109 132))) - - (define (get-size-parameters) - (let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] - [(max-rx max-ry) (get-max/min-x/y max running-points)] - [(min-wx min-wy) (get-max/min-x/y min waiting-points)] - [(max-wx max-wy) (get-max/min-x/y max waiting-points)]) - (let* ([running-w (* small-factor (- max-rx min-rx))] - [waiting-w (* small-factor (- max-wx min-wx))] - [running-h (* small-factor (- max-ry min-ry))] - [waiting-h (* small-factor (- max-wy min-wy))] - [w (+ 2 (ceiling (max running-w waiting-w)))] - [h (+ 2 (ceiling (max running-h waiting-h)))] - [running-dx (+ 1 (- (/ w 2) (/ running-w 2)))] - [running-dy (+ 1 (- (/ h 2) (/ running-h 2)))] - [waiting-dx (+ 1 (- (/ w 2) (/ waiting-w 2)))] - [waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))]) - (values w h running-dx running-dy waiting-dx waiting-dy)))) - - (define (get-bitmap points green) - (let-values ([(min-rx min-ry) (get-max/min-x/y min points)] - [(max-rx max-ry) (get-max/min-x/y max points)]) - (let* ([margin 2] - [bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))] - [bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))] - [w (ceiling (* bw small-bitmap-factor))] - [h (ceiling (* bh small-bitmap-factor))] - [bm-big (make-object bitmap% bw bh)] - [bm-solid (make-object bitmap% w h)] - [bm-small (make-object bitmap% w h)] - [bdc-big (make-object bitmap-dc% bm-big)] - [bdc-solid (make-object bitmap-dc% bm-solid)] - [bdc-small (make-object bitmap-dc% bm-small)]) - (send bdc-big clear) - (draw-callback bdc-big small-factor #f points - (+ margin (- (* small-factor min-rx))) - (+ margin #;(- (* small-factor min-ry))) - 3) - - (send bdc-small clear) - (send bdc-small set-scale small-bitmap-factor small-bitmap-factor) - (send bdc-small draw-bitmap bm-big 0 0) - (send bdc-small set-scale 1 1) - - (send bdc-solid set-brush green 'solid) - (send bdc-solid set-pen green 1 'solid) - (send bdc-solid draw-rectangle 0 0 w h) - - (send bdc-solid set-bitmap #f) - (send bdc-small set-bitmap #f) - (send bdc-big set-bitmap #f) - - (send bm-solid set-loaded-mask bm-small) - bm-solid))) - - (define (get-running-bitmap) (get-bitmap running-points (make-object color% 30 100 30))) - (define (get-waiting-bitmap) (get-bitmap waiting-points (make-object color% 30 100 30))) - - (define (normalize points) - (let-values ([(min-x min-y) (get-max/min-x/y min points)]) - (map (λ (x) (list (car x) - (+ (- (list-ref x 1) min-x)) - (+ (- (list-ref x 2) min-y)))) - points))) - - (define (get-max/min-x/y choose points) - (values (apply choose - (- (list-ref (assoc 'head points) 1) (/ head-size 2)) - (+ (list-ref (assoc 'head points) 1) (/ head-size 2)) - (map (λ (x) (list-ref x 1)) points)) - (apply choose - (- (list-ref (assoc 'head points) 2) (/ head-size 2)) - (+ (list-ref (assoc 'head points) 2) (/ head-size 2)) - (map (λ (x) (list-ref x 2)) points)))) - - (define show-dots? #t) - (define (draw-callback dc factor dots? points dx dy line-size) - (send dc set-smoothing 'aligned) - (let ([points (normalize points)]) - (send dc set-pen "orange" 1 'solid) - (send dc set-brush "orange" 'solid) - (when (and dots? show-dots?) - (for-each - (λ (x) (send dc draw-ellipse - (+ dx (- (list-ref x 1) 4)) - (+ dy (- (list-ref x 2) 4)) - 9 9)) - points)) - (send dc set-pen "black" line-size 'solid) - (send dc set-brush "black" 'transparent) - (draw-points points dc factor dx dy) - - (let* ([head (assoc 'head points)] - [hx (list-ref head 1)] - [hy (list-ref head 2)]) - (send dc draw-ellipse - (+ dx (* factor (- hx (/ head-size 2)))) - (+ dy (* factor (- hy (/ head-size 2)))) - (* factor head-size) - (* factor head-size))))) - - (define (draw-points points dc factor dx dy) - (connect 'neck 'shoulders points dc factor dx dy) - (connect 'shoulders 'left-shoulder points dc factor dx dy) - (connect 'left-shoulder 'left-elbow points dc factor dx dy) - (connect 'shoulders 'right-shoulder points dc factor dx dy) - (connect 'right-shoulder 'right-elbow points dc factor dx dy) - (connect 'left-elbow 'left-hand points dc factor dx dy) - (connect 'right-elbow 'right-hand points dc factor dx dy) - (connect 'shoulders 'waist points dc factor dx dy) - (connect 'waist 'left-knee points dc factor dx dy) - (connect 'waist 'right-knee points dc factor dx dy) - (connect 'left-knee 'left-ankle points dc factor dx dy) - (connect 'right-knee 'right-ankle points dc factor dx dy) - (connect 'left-ankle 'left-toe points dc factor dx dy) - (connect 'right-ankle 'right-toe points dc factor dx dy)) - - (define (connect from to points dc factor dx dy) - (let ([from-p (assoc from points)] - [to-p (assoc to points)]) - (when (and from-p to-p) - (send dc draw-line - (+ dx (* factor (list-ref from-p 1))) - (+ dy (* factor (list-ref from-p 2))) - (+ dx (* factor (list-ref to-p 1))) - (+ dy (* factor (list-ref to-p 2))))))) - - ;; Use this thunk to edit the points. - ;; Click the 'show' button to print out the points and then - ;; copy and paste them back into this file. - (define (edit-points points) - (define c% - (class canvas% - (inherit get-client-size refresh get-dc) - (define clicked-point #f) - (define clicked-x 0) - (define clicked-y 0) - (define orig-x 0) - (define orig-y 0) - (define/override (on-paint) - (draw-callback (get-dc) 1 #t points 0 0 line-size)) - (define/override (on-event evt) - (cond - [(send evt button-down? 'left) - (let-values ([(w h) (get-client-size)]) - (let ([x (send evt get-x)] - [y (send evt get-y)]) - (let ([point (find-point this x y)]) - (when point - (set! clicked-x x) - (set! clicked-y y) - (set! clicked-point point) - (let ([orig-point (assoc point points)]) - (set! orig-x (list-ref orig-point 1)) - (set! orig-y (list-ref orig-point 2)))))))] - [(and clicked-point (send evt moving?)) - (set! points - (map (λ (x) - (if (eq? (car x) clicked-point) - (list (list-ref x 0) - (+ orig-x (- (send evt get-x) clicked-x)) - (+ orig-y (- (send evt get-y) clicked-y))) - x)) - points)) - (refresh) - (send csmall refresh)] - [(send evt button-up? 'left) - (set! clicked-point #f)])) - (super-new))) - - (define (find-point c x y) - (let loop ([points (normalize points)]) - (cond - [(null? points) #f] - [else (let ([point (car points)]) - (if (and (<= (- (list-ref point 1) 4) - x - (+ (list-ref point 1) 4)) - (<= (- (list-ref point 2) 4) - y - (+ (list-ref point 2) 4))) - (car point) - (loop (cdr points))))]))) - - (define f (new frame% [label ""] [width 400] [height 400])) - (define cp (new horizontal-panel% [parent f])) - (define cbig (new c% [parent cp])) - (define csmall - (new canvas% - [parent cp] - [paint-callback (λ (c dc) - (draw-callback dc small-factor #f running-points 0 0 line-size) - (draw-callback dc small-factor #f waiting-points 30 0 line-size) - (draw-callback dc small-factor #f points 30 50 line-size) - (draw-callback dc small-factor #f points 0 50 line-size))])) - (define cbitmap (new message% [label (get-bitmap points (send the-color-database find-color "black"))] [parent cp])) - (define bp (new horizontal-panel% [parent f] [stretchable-height #f])) - (new button% - [parent bp] - [label "Show"] - [callback - (λ (x y) - (pretty-print points))]) - (new button% - [parent bp] - [label "Toggle dots"] - [callback - (λ (x y) - (set! show-dots? (not show-dots?)) - (send cbig refresh))]) - (new button% - [parent bp] - [label "Bitmap"] - [callback - (λ (x y) - (send cbitmap set-label (get-bitmap points (send the-color-database find-color "black"))))]) - (send f show #t)) - - (let () - (define f (new frame% [label ""])) - (define hp (new horizontal-panel% [parent f])) - (define left-column (new vertical-panel% [parent hp])) - (define right-column (new vertical-panel% [parent hp])) - (define green-rb (get-running-bitmap)) - (define black (send the-color-database find-color "black")) - (define rb (get-bitmap running-points black)) - (define wb (get-bitmap waiting-points black)) - (define wb2 (get-bitmap waiting-points/2 black)) - (define rm (new message% [label rb] [parent left-column])) - (define grm (new message% [label green-rb] [parent right-column])) - (new message% [label wb] [parent left-column]) - (new message% [label wb2] [parent left-column]) - (new message% [label wb2] [parent right-column]) - (new message% [label wb] [parent right-column]) - (new grow-box-spacer-pane% [parent f]) - (send green-rb save-file (build-path (collection-path "icons") "run.png") 'png) - (send rb save-file (build-path (collection-path "icons") "b-run.png") 'png) - (send wb save-file (build-path (collection-path "icons") "b-wait.png") 'png) - (send wb2 save-file (build-path (collection-path "icons") "b-wait2.png") 'png) - (send f show #t)) - - #;(edit-points waiting-points/2) - #;(edit-points running-points)) diff --git a/collects/drscheme/private/syncheck-debug.ss b/collects/drscheme/private/syncheck-debug.ss deleted file mode 100644 index 364702e84a..0000000000 --- a/collects/drscheme/private/syncheck-debug.ss +++ /dev/null @@ -1,164 +0,0 @@ -(module syncheck-debug mzscheme - (require mzlib/pretty - mzlib/list - mzlib/class - mred) - - (provide debug-origin) ;; : syntax [syntax] -> void - ;; creates a frame for examining the - ;; origin and source fields of an expanded sexp - ;; also the 'bound-in-source syntax property - - (define debug-origin - (case-lambda - [(original-object) (debug-origin original-object (expand original-object))] - [(original-object expanded-object) - (define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object)) - - (define output-text (make-object text%)) - (define output-port (make-text-port output-text)) - (define info-text (make-object text%)) - (define info-port (make-text-port info-text)) - - ;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc) - ;; this is guaranteed by syntax-object->datum/ht - (define range-start-ht (make-hash-table)) - (define range-ht (make-hash-table)) - (define original-output-port (current-output-port)) - (define (range-pretty-print-pre-hook x v) - (hash-table-put! range-start-ht x (send output-text last-position))) - (define (range-pretty-print-post-hook x v) - (hash-table-put! range-ht x - (cons - (cons - (hash-table-get range-start-ht x) - (send output-text last-position)) - (hash-table-get range-ht x (λ () null))))) - - (define (make-modern text) - (send text change-style - (make-object style-delta% 'change-family 'modern) - 0 - (send text last-position))) - - (define dummy - (begin (pretty-print (syntax-object->datum original-object) output-port) - (newline output-port) - (parameterize ([current-output-port output-port] - [pretty-print-pre-print-hook range-pretty-print-pre-hook] - [pretty-print-post-print-hook range-pretty-print-post-hook] - [pretty-print-columns 30]) - (pretty-print expanded-datum)) - (make-modern output-text))) - - (define ranges - (sort - (apply append (hash-table-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs)))) - (λ (x y) - (<= (- (car (cdr x)) (cdr (cdr x))) - (- (car (cdr y)) (cdr (cdr y))))))) - - (define (show-info stx) - (fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n" - (syntax-object->datum stx) - (syntax-source stx) - (syntax-position stx) - (syntax-span stx) - (syntax-original? stx) - (syntax-property stx 'bound-in-source)) - (let loop ([origin (syntax-property stx 'origin)]) - (cond - [(pair? origin) - (loop (car origin)) - (loop (cdr origin))] - [(syntax? origin) - (display " " info-port) - (display origin info-port) - (newline info-port) - (fprintf info-port - " original? ~a\n datum:\n ~a\n\n" - (and (syntax? origin) (syntax-original? origin)) - (and (syntax? origin) (syntax-object->datum origin)))] - [else (void)]))) - - (for-each - (λ (range) - (let* ([obj (car range)] - [stx (hash-table-get stx-ht obj)] - [start (cadr range)] - [end (cddr range)]) - (when (syntax? stx) - (send output-text set-clickback start end - (λ _ - (send info-text begin-edit-sequence) - (send info-text erase) - (show-info stx) - (make-modern info-text) - (send info-text end-edit-sequence)))))) - ranges) - - (newline output-port) - (newline output-port) - (let ([before (send output-text last-position)]) - (display "all" output-port) - (send output-text set-clickback - before - (send output-text last-position) - (λ _ - (send info-text begin-edit-sequence) - (send info-text erase) - (for-each (λ (rng) - (let ([stx (hash-table-get stx-ht (car rng))]) - (when (syntax? stx) - (show-info stx)))) - ranges) - (make-modern info-text) - (send info-text end-edit-sequence)))) - - (let () - (define f (make-object frame% "Syntax 'origin Browser" #f 600 300)) - (define p (make-object horizontal-panel% f)) - (make-object editor-canvas% p output-text) - (make-object editor-canvas% p info-text) - (send f show #t))])) - - ;; build-ht : stx -> hash-table - ;; the resulting hash-table maps from the each sub-object's to it's syntax. - (define (syntax-object->datum/ht stx) - (let ([ht (make-hash-table)]) - (values (let loop ([stx stx]) - (let ([obj (syntax-e stx)]) - (cond - [(list? obj) - (let ([res (map loop obj)]) - (hash-table-put! ht res stx) - res)] - [(pair? obj) - (let ([res (cons (loop (car obj)) - (loop (cdr obj)))]) - (hash-table-put! ht res stx) - res)] - [(vector? obj) - (let ([res (list->vector (map loop (vector->list obj)))]) - (hash-table-put! ht res stx) - res)] - [else - (let ([res (syntax-object->datum stx)]) - (hash-table-put! ht res stx) - res)]))) - ht))) - - ;; make-text-port : text -> port - ;; builds a port from a text object. - (define (make-text-port text) - (let-values ([(in out) (make-pipe)]) - (thread - (λ () - (let loop () - (let ([c (read-char in)]) - (unless (eof-object? c) - (send text insert (string c) - (send text last-position) - (send text last-position)) - (loop)))))) - out))) diff --git a/collects/drscheme/private/text.ss b/collects/drscheme/private/text.ss deleted file mode 100644 index 196e591614..0000000000 --- a/collects/drscheme/private/text.ss +++ /dev/null @@ -1,34 +0,0 @@ - -#lang scheme/unit - (require mzlib/class - "drsig.ss" - framework) - - (import) - (export drscheme:text^) - (define text<%> - (interface (scheme:text<%>) - printing-on - printing-off - is-printing?)) - - (define text% - (class* scheme:text% (text<%>) - (define printing? #f) - (define/public (is-printing?) printing?) - (define/public (printing-on) (set! printing? #t)) - (define/public (printing-off) (set! printing? #f)) - ; (rename [super-on-paint on-paint]) - ; (inherit get-filename) - ; (override - ; [on-paint - ; (λ (before? dc left top right bottom dx dy draw-caret) - ; (super-on-paint before? dc left top right bottom dx dy draw-caret) - ; (let ([str (string-append - ; (mzlib:date:date->string (seconds->date (current-seconds))) - ; " " - ; (if (string? (get-filename)) - ; (get-filename) - ; "Untitled"))]) - ; (send dc draw-text str dx dy)))]) - (super-new))) diff --git a/collects/drscheme/private/time-keystrokes.ss b/collects/drscheme/private/time-keystrokes.ss deleted file mode 100644 index b0d75e70c7..0000000000 --- a/collects/drscheme/private/time-keystrokes.ss +++ /dev/null @@ -1,86 +0,0 @@ -(module time-keystrokes mzscheme - - (require (lib "tool.ss" "drscheme") - mzlib/list - mzlib/unit - mzlib/class - mzlib/etc - mred - framework) - - (provide tool@) - - (define short-str "(abc)") - (define chars-to-test (build-string - 400 - (λ (i) (string-ref short-str (modulo i (string-length short-str)))))) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define (phase1) (void)) - (define (phase2) (void)) - - (define (tool-mixin super%) - (class super% - (inherit get-button-panel) - (super-new) - (let ([button (new button% - (label "Time Keystrokes") - (parent (get-button-panel)) - (callback - (lambda (button evt) - (time-keystrokes this))))]) - (send (get-button-panel) change-children - (lambda (l) - (cons button (remq button l))))))) - - (define (time-keystrokes frame) - (let loop ([n 10]) - (when (zero? n) - (error 'time-keystrokes "could not find drscheme frame")) - (let ([front-frame (get-top-level-focus-window)]) - (unless (eq? front-frame frame) - (sleep 1/10) - (loop (- n 1))))) - (let ([win (send frame get-definitions-canvas)]) - (send win focus) - (time (send-key-events win chars-to-test)))) - - (define (send-key-events window chars) - (for-each (λ (char) - (send-key-event window (new key-event% (key-code char)))) - (string->list chars))) - - - ;; copied from framework/test.ss - (define (send-key-event window event) - (let loop ([l (ancestor-list window #t)]) - (cond [(null? l) - (cond - [(method-in-interface? 'on-char (object-interface window)) - (send window on-char event)] - [(is-a? window text-field%) - (send (send window get-editor) on-char event)] - [else - (error - 'send-key-event - "focused window is not a text-field% and does not have on-char: ~s" window)])] - [(send (car l) on-subwindow-char window event) #f] - [else (loop (cdr l))]))) - - ;; copied from framework/test.ss - (define (ancestor-list window stop-at-top-level-window?) - (let loop ([w window] [l null]) - (if (or (not w) - (and stop-at-top-level-window? - (is-a? w top-level-window<%>))) - l - (loop (send w get-parent) (cons w l))))) - - (when (getenv "PLTDRKEYS") - (printf "PLTDRKEYS: installing unit frame mixin\n") - (drscheme:get/extend:extend-unit-frame tool-mixin))))) - diff --git a/collects/drscheme/private/tool-contract-language.ss b/collects/drscheme/private/tool-contract-language.ss deleted file mode 100644 index 7c8486c72b..0000000000 --- a/collects/drscheme/private/tool-contract-language.ss +++ /dev/null @@ -1,135 +0,0 @@ -(module tool-contract-language mzscheme - (provide (rename -#%module-begin #%module-begin) - (all-from-except mzscheme #%module-begin)) - - (require mzlib/contract) - (require-for-syntax mzlib/list) - - (define-syntax (-#%module-begin stx) - - (define-struct ctc-binding (var arg)) - (define-struct def-binding (var arg)) - - (define (process-case case-stx) - (syntax-case case-stx (define) - [(define name expr) - (identifier? (syntax name)) - (make-def-binding (syntax name) (syntax expr))] - [(name type type-names strs ...) - (and (identifier? (syntax name)) - (not (string? (syntax-object->datum (syntax type)))) - (andmap (λ (x) (string? (syntax-object->datum x))) (syntax->list (syntax (strs ...))))) - (make-ctc-binding (syntax name) (syntax type))] - [else (raise-syntax-error 'tool-contract-language.ss "unknown case" stx case-stx)])) - - - (syntax-case stx () - [(_ cases ...) - (let* ([pcases (map process-case (syntax->list (syntax (cases ...))))] - [def-cases (filter def-binding? pcases)] - [ctc-cases (filter ctc-binding? pcases)]) - (with-syntax ([(ctc-name ...) (map ctc-binding-var ctc-cases)] - [(ctc ...) (map ctc-binding-arg ctc-cases)] - [(def-name ...) (map def-binding-var def-cases)] - [(def-exp ...) (map def-binding-arg def-cases)] - [wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)]) - (syntax/loc stx - (#%module-begin - (provide wrap-tool-inputs) - (define-syntax wrap-tool-inputs - (λ (in-stx) - (syntax-case in-stx () - [(_ body tool-name) - (let ([f (λ (in-obj) - (datum->syntax-object - in-stx - (syntax-object->datum in-obj) - in-obj))]) - (with-syntax ([(in-type (... ...)) (map f (syntax->list (syntax (ctc ...))))] - [(in-name (... ...)) (map f (syntax->list (syntax (ctc-name ...))))] - [(in-def-name (... ...)) (map f (syntax->list (syntax (def-name ...))))] - [(in-def-exp (... ...)) (map f (syntax->list (syntax (def-exp ...))))]) - (syntax/loc in-stx - (let ([in-def-name in-def-exp] (... ...)) - (let ([in-name (contract (let ([in-name in-type]) in-name) - in-name - 'drscheme - tool-name - (quote-syntax in-name))] (... ...)) - body)))))])))))))] - [(_ (name type type-names strs ...) ...) - (begin - (for-each - (λ (str-stx) - (when (string? (syntax-object->datum str-stx)) - (raise-syntax-error 'tool-contract-language.ss "expected type name specification" - stx - str-stx))) - (syntax->list (syntax (type-names ...)))) - (for-each - (λ (name) - (unless (identifier? name) - (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name))) - (syntax->list (syntax (name ...)))) - (for-each - (λ (str) - (unless (string? (syntax-object->datum str)) - (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str))) - (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))])) - - (define-syntax (-#%module-begin2 stx) - (syntax-case stx () - [(_ (name type type-names strs ...) ...) - (and (andmap identifier? (syntax->list (syntax (name ...)))) - (andmap (λ (x) (not (string? (syntax-object->datum x)))) - (syntax->list (syntax (type-names ...)))) - (andmap (λ (x) (string? (syntax-object->datum x))) - (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...))))))) - (with-syntax ([wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)]) - (syntax/loc stx - (#%module-begin - (provide wrap-tool-inputs) - (define-syntax wrap-tool-inputs - (λ (in-stx) - (syntax-case in-stx () - [(_ body tool-name) - (with-syntax ([(in-type (... ...)) - (map (λ (in-type-obj) - (datum->syntax-object - in-stx - (syntax-object->datum in-type-obj) - in-type-obj)) - (syntax->list (syntax (type ...))))] - [(in-name (... ...)) - (map (λ (in-name-obj) - (datum->syntax-object - in-stx - (syntax-object->datum in-name-obj) - in-name-obj)) - (syntax->list (syntax (name ...))))]) - (syntax/loc in-stx - (let ([in-name (contract (let ([in-name in-type]) in-name) - in-name - 'drscheme - tool-name - (quote-syntax in-name))] (... ...)) - body)))]))))))] - [(_ (name type type-names strs ...) ...) - (begin - (for-each - (λ (str-stx) - (when (string? (syntax-object->datum str-stx)) - (raise-syntax-error 'tool-contract-language.ss "expected type name specification" - stx - str-stx))) - (syntax->list (syntax (type-names ...)))) - (for-each - (λ (name) - (unless (identifier? name) - (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name))) - (syntax->list (syntax (name ...)))) - (for-each - (λ (str) - (unless (string? (syntax-object->datum str)) - (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str))) - (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss deleted file mode 100644 index f59afc7178..0000000000 --- a/collects/drscheme/private/tools.ss +++ /dev/null @@ -1,582 +0,0 @@ - -#lang scheme/unit - -(require (lib "getinfo.ss" "setup") - mred - scheme/class - scheme/list - "drsig.ss" - "language-object-contract.ss" - scheme/contract - framework - string-constants - scheme/runtime-path) - -(require (for-syntax scheme/base scheme/match)) - -(import [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:get/extend: drscheme:get/extend^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:language-configuration: drscheme:language-configuration^] - [prefix drscheme:help-desk: drscheme:help-desk^] - [prefix drscheme:init: drscheme:init^] - [prefix drscheme:debug: drscheme:debug^] - [prefix drscheme:eval: drscheme:eval^] - [prefix drscheme:modes: drscheme:modes^]) -(export drscheme:tools^) - -;; An installed-tool is -;; (make-installed-tool directory-record module-spec string/#f string/#f string/#f string/#f) -(define-struct installed-tool (dir spec bitmap name url)) - -;; installed-tools : (list-of installed-tool) -(define installed-tools null) - -;; successful-tool = (make-successful-tool module-spec -;; (union #f (instanceof bitmap%)) -;; (union #f string) -;; (union #f string)) -(define-struct successful-tool (spec bitmap name url)) - -;; successful-tools : (listof successful-tool) -(define successful-tools null) - -;; get-successful-tools : -> (listof successful-tool) -(define (get-successful-tools) successful-tools) - -;; successfully-loaded-tool = -;; (make-successfully-loaded-tool -;; module-spec (union #f (instanceof bitmap%)) (union #f string) (union #f string) -;; (-> void) (-> void)) -(define-struct successfully-loaded-tool (spec bitmap name url phase1 phase2)) - -;; successfully-loaded-tools : (listof successfully-loaded-tool) -;; this list contains the tools that successfully were loaded -;; it is updated in load/invoke-tool. -(define successfully-loaded-tools null) - -;; load/invoke-all-tools : -> void -(define (load/invoke-all-tools phase1-extras phase2-extras) - (rescan-installed-tools!) - (set! current-phase 'loading-tools) - (let ([candidate-tools (filter candidate-tool? installed-tools)]) - (for-each load/invoke-tool candidate-tools) - (run-phases phase1-extras phase2-extras))) - -;; rescan-installed-tools! : -> void -(define (rescan-installed-tools!) - (set! installed-tools (all-installed-tools))) - -;; all-installed-tools : -> (list-of installed-tool) -(define (all-installed-tools) - (apply append - (map installed-tools-for-directory - (all-tool-directories)))) - -;; all-tool-directories : -> (list-of directory-record) -(define (all-tool-directories) - (find-relevant-directory-records '(tools tool-icons tool-names tool-urls))) - -;; installed-tools-for-directory : directory-record -> (list-of installed-tool) -(define (installed-tools-for-directory coll-dir) - (let ([table (get-info/full (directory-record-path coll-dir))]) - (if table - (let* ([tools (table 'tools (lambda () null))] - [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))] - [tool-names (table 'tool-names (lambda () (map (lambda (x) #f) tools)))] - [tool-urls (table 'tool-urls (lambda () (map (lambda (x) #f) tools)))]) - (unless (= (length tools) (length tool-icons)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-icons-same-length) - coll-dir tools tool-icons) - #f - '(ok stop)) - (set! tool-icons (map (lambda (x) #f) tools))) - (unless (= (length tools) (length tool-names)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-names-same-length) - coll-dir tools tool-names) - #f - '(ok stop)) - (set! tool-names (map (lambda (x) #f) tools))) - (unless (= (length tools) (length tool-urls)) - (message-box (string-constant drscheme) - (format (string-constant tool-tool-urls-same-length) - coll-dir tools tool-urls) - #f - '(ok stop)) - (set! tool-urls (map (lambda (x) #f) tools))) - (map (lambda (t i n u) (make-installed-tool coll-dir t i n u)) - tools tool-icons tool-names tool-urls)) - null))) - -;; candidate-tool? : installed-tool -> boolean -;; Predicate for tools selected for execution in this -;; run of DrScheme (depending on env variables and preferences) -(define candidate-tool? - (cond - [(getenv "PLTNOTOOLS") - (printf "PLTNOTOOLS: skipping tools\n") - (lambda (it) #f)] - [(getenv "PLTONLYTOOL") => - (lambda (onlys) - (let* ([allowed (let ([exp (read (open-input-string onlys))]) - (cond - [(symbol? exp) (list exp)] - [(pair? exp) exp] - [else '()]))] - [directory-ok? (lambda (x) - (let-values ([(base name dir) (split-path x)]) - (memq (string->symbol (path->string name)) - allowed)))]) - (printf "PLTONLYTOOL: only loading ~s\n" allowed) - (lambda (it) - (directory-ok? - (directory-record-path - (installed-tool-dir it))))))] - [else - (lambda (it) - (eq? (or (get-tool-configuration it) - (default-tool-configuration it)) - 'load))])) - -;; get-tool-configuration : installed-tool -> symbol/#f -;; Get tool configuration preference or #f if no preference set. -(define (get-tool-configuration it) - (let ([p (assoc (installed-tool->key it) (toolspref))]) - (and p (cadr p)))) - -;; default-tool-configuration : installed-tool -> (union 'load 'skip) -(define (default-tool-configuration it) - (preferences:get 'drscheme:default-tools-configuration)) - -(define toolspref - (case-lambda - [() (preferences:get 'drscheme:tools-configuration)] - [(v) (preferences:set 'drscheme:tools-configuration v)])) - -(define (installed-tool->key it) - (list (directory-record-spec (installed-tool-dir it)) - (installed-tool-spec it))) - -(define (installed-tool-full-path it) - (apply build-path - (directory-record-path (installed-tool-dir it)) - (let ([path-parts (installed-tool-spec it)]) - (cond [(list? path-parts) - (append (cdr path-parts) (list (car path-parts)))] - [else (list path-parts)])))) - -(define (installed-tool->module-spec it) - (let* ([dirrec (installed-tool-dir it)] - [key (directory-record-spec dirrec)] - [maj (directory-record-maj dirrec)] - [min (directory-record-min dirrec)] - [parts (let ([parts0 (installed-tool-spec it)]) - (if (list? parts0) - parts0 - (list parts0)))] - [file (car parts)] - [rest-parts (cdr parts)]) - (case (car key) - ((lib) - `(lib ,(string-append - (apply string-append - (map (lambda (s) - (string-append s "/")) - (append (cdr key) rest-parts))) - file))) - ((planet) - `(planet ,file (,@(cdr key) ,maj ,min) ,@rest-parts))))) - -;; installed-tool-is-loaded : installed-tool -> boolean -(define (installed-tool-is-loaded? it) - (let ([path (installed-tool-full-path it)]) - (ormap (lambda (st) (equal? path (successful-tool-spec st))) - (get-successful-tools)))) - - -; -; -; -; ;;;; ;;;; ;; ;; ;;;; -; ;;;; ;;;; ;; ;; ;;;; -; ;;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; ;;; ;;; ;;; ;;;; ;;;; ;;; ;;; -; ;;;; ;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;;;;;;; ;;; ;;; ;;;;;; ;;;; ;;; ;;;;; -; ;;;; ;;;;;;;; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;;; ;;;;;;; ;;;; ;; -; ;;;; ;;;; ;;; ;;;;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;; ;;;;;;; ;;;;;;; -; ;;;; ;;;;;;;; ;; ;;;; ;;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;; ;;;;;;;; ;;;; ;;; ;;;;; -; ;;;; ;;;;;; ;;;;;;;; ;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;; ;;;;;; -; ;;;; ;;;; ;; ;;;; ;;;;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; -; ;; -; -; - - - -;; load/invoke-tool : installed-tool -> void -(define (load/invoke-tool it) - (load/invoke-tool* (directory-record-path (installed-tool-dir it)) - (installed-tool-spec it) - (installed-tool-bitmap it) - (installed-tool-name it) - (installed-tool-url it))) - -;; load/invoke-tool* : path -;; (listof string[sub-collection-name]) -;; (union #f (cons string[filename] (listof string[collection-name]))) -;; (union #f string) -;; (union #f string) -;; -> void -;; `coll' is a collection to load the tool from -;; `in-path' is the `coll'-relative collection-path spec for the tool module file -;; `icon-spec' is the collection-path spec for the tool's icon, if there is one. -;; `name' is the name of the tool (only used in about box) -(define (load/invoke-tool* coll-dir in-path icon-spec name tool-url) - (let* ([icon-path - (cond - [(string? icon-spec) - (build-path coll-dir icon-spec)] - [(and (list? icon-spec) - (andmap string? icon-spec)) - (build-path (apply collection-path (cdr icon-spec)) (car icon-spec))] - [else #f])] - [tool-bitmap - (and icon-path - (install-tool-bitmap name icon-path))]) - (let/ec k - (unless (or (string? in-path) - (and (list? in-path) - (not (null? in-path)) - (andmap string? in-path))) - (message-box (string-constant drscheme) - (format (string-constant invalid-tool-spec) - coll-dir in-path) - #f - '(ok stop)) - (k (void))) - (let* ([tool-path - (if (string? in-path) - (build-path coll-dir in-path) - (apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))] - [unit - (with-handlers ([exn:fail? - (lambda (x) - (show-error - (format (string-constant error-invoking-tool-title) - coll-dir in-path) - x) - (k (void)))]) - (dynamic-require tool-path 'tool@))]) - (with-handlers ([exn:fail? - (lambda (x) - (show-error - (format (string-constant error-invoking-tool-title) - coll-dir in-path) - x))]) - (let-values ([(phase1-thunk phase2-thunk) - (invoke-tool unit (string->symbol (or name (path->string coll-dir))))]) - (set! successfully-loaded-tools - (cons (make-successfully-loaded-tool - tool-path - tool-bitmap - name - tool-url - phase1-thunk - phase2-thunk) - successfully-loaded-tools)))))))) - -(define-syntax (wrap-tool-inputs stx) - (syntax-case stx () - [(_ body tool-name) - (let () - (define full-sexp - (call-with-input-file (build-path (collection-path "drscheme") "tool-lib.ss") - (λ (port) - (parameterize ([read-accept-reader #t]) - (read port))))) - - (let loop ([sexp full-sexp]) - (match sexp - [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...) - #`(let #,(map (λ (name ctc) - (with-syntax ([name (datum->syntax #'tool-name name)] - [ctc (datum->syntax #'tool-name ctc)]) - #`[name (contract (let ([name ctc]) name) - name - 'drscheme - tool-name - (quote-syntax name))])) - name - ctc) - body)] - [`(,a . ,b) - (loop b)] - [`() - (error 'tcl.ss "did not find provide/doc" full-sexp)])))])) - -;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) -;; invokes the tools and returns the two phase thunks. -(define (invoke-tool unit tool-name) - (define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^)) - (language-object-abstraction drscheme:language:object/c #f) - (wrap-tool-inputs - (let () - (define-values/invoke-unit unit@ - (import drscheme:tool^) (export drscheme:tool-exports^)) - (values phase1 phase2)) - tool-name)) - -;; show-error : string (union exn TST) -> void -(define (show-error title x) - (parameterize ([drscheme:init:error-display-handler-message-box-title - title]) - ((error-display-handler) - (if (exn? x) - (format "~a\n\n~a" title (exn-message x)) - (format "~a\n\nuncaught exception: ~s" title x)) - x))) - - -;; install-tool-bitmap : string path -> bitmap -;; adds the tool's bitmap to the splash screen -(define (install-tool-bitmap name bitmap-path) - (let/ec k - (let ([bitmap - (with-handlers ([exn:fail:filesystem? (lambda (x) (k (void)))]) - (make-object bitmap% bitmap-path 'unknown/mask))]) - (unless (and (is-a? bitmap bitmap%) - (send bitmap ok?)) - (k #f)) - (let ([splash-eventspace ((dynamic-require '(lib "framework/splash.ss") 'get-splash-eventspace))] - [splash-bitmap ((dynamic-require '(lib "framework/splash.ss") 'get-splash-bitmap))] - [splash-canvas ((dynamic-require '(lib "framework/splash.ss") 'get-splash-canvas))]) - - (unless (and (eventspace? splash-eventspace) - (is-a? splash-bitmap bitmap%) - (send splash-bitmap ok?) - (is-a? splash-canvas canvas%)) - (k (void))) - - (parameterize ([current-eventspace splash-eventspace]) - (queue-callback - (lambda () - (let ([bdc (make-object bitmap-dc%)] - [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))]) - - ;; truncate/expand the bitmap, if necessary - (unless (and (= tool-bitmap-size (send bitmap get-width)) - (= tool-bitmap-size (send bitmap get-height))) - (let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)]) - (send bdc set-bitmap new-b) - (send bdc clear) - (send bdc draw-bitmap-section splash-bitmap - 0 0 - tool-bitmap-x translated-tool-bitmap-y - tool-bitmap-size tool-bitmap-size) - (send bdc draw-bitmap bitmap - (max 0 (- (/ tool-bitmap-size 2) - (/ (send bitmap get-width) 2))) - (max 0 (- (/ tool-bitmap-size 2) - (/ (send bitmap get-height) 2))) - 'solid - (make-object color% "black") - (send bitmap get-loaded-mask)) - (send bdc set-bitmap #f) - (set! bitmap new-b))) - - ((dynamic-require '(lib "framework/splash.ss") 'add-splash-icon) - bitmap tool-bitmap-x translated-tool-bitmap-y) - (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap)) - (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) - (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap)) - (set! tool-bitmap-x tool-bitmap-gap)) - (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) - (set! tool-bitmap-y tool-bitmap-gap))))))) - bitmap))) - -(define tool-bitmap-gap 3) -(define tool-bitmap-x tool-bitmap-gap) -(define tool-bitmap-y tool-bitmap-gap) -(define tool-bitmap-size 32) - - - -;; ; ;;; -; ;;; ;;; ; ; -; ; ; ; ; ; -; ;;; ; ;; ;;;; ;;; ;;; ; ; ; ; -; ; ;; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;;;; ;;; ;;;;; ; ;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; -;;;; ;;; ;;; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;;;; -; -; -;;; - - -;; run-phases : -> void -(define (run-phases phase1-extras phase2-extras) - (let* ([after-phase1 (run-one-phase 'phase1 - (string-constant tool-error-phase1) - successfully-loaded-tool-phase1 - successfully-loaded-tools - phase1-extras)] - [after-phase2 (run-one-phase 'phase2 - (string-constant tool-error-phase2) - successfully-loaded-tool-phase2 - after-phase1 - phase2-extras)]) - (set! current-phase 'init-complete) - (set! successful-tools - (map (lambda (x) (make-successful-tool - (successfully-loaded-tool-spec x) - (successfully-loaded-tool-bitmap x) - (successfully-loaded-tool-name x) - (successfully-loaded-tool-url x))) - after-phase2)))) - -;; run-one-phase : string -;; (successfully-loaded-tool -> (-> void)) -;; (listof successfully-loaded-tool) -;; (-> void) -;; -> (listof successfully-loaded-tool) -;; filters out the tools that raise exceptions during the phase. -;; extras is the thunk for DrScheme init stuff on this phase. -(define (run-one-phase _the-phase err-fmt selector tools extras) - (set! current-phase _the-phase) - (extras) - (let loop ([tools tools]) - (cond - [(null? tools) null] - [else - (let ([tool (car tools)]) - (let ([phase-thunk (selector tool)]) - (with-handlers ([exn:fail? - (lambda (exn) - (show-error - (format err-fmt - (successfully-loaded-tool-spec tool) - (successfully-loaded-tool-name tool)) - exn) - (loop (cdr tools)))]) - (phase-thunk) - (cons tool (loop (cdr tools))))))]))) - -;; current-phase : (union #f 'loading-tools 'phase1 'phase2 'init-complete) -(define current-phase #f) -(define (get-current-phase) current-phase) - -;; only-in-phase : sym (union #f 'loading-tools 'phase1 'phase2 'init-complete) ... -> void -;; raises an error unless one of `phases' is the current phase -(define (only-in-phase func . phases) - (unless (memq current-phase phases) - (error func "can only be called in phase: ~a" - (apply string-append - (map (lambda (x) (format "~e " x)) - (filter (lambda (x) x) phases)))))) - -;; Preferences GUI - -(define load-action "Load the tool") -(define skip-action "Skip the tool") - -(define (add-prefs-panel) - (preferences:add-panel - "Tools" - (lambda (parent) - (define main (new vertical-panel% (parent parent))) - (define advisory - (new message% - (parent main) - (label "Changes to tool configuration will take effect the next time you start DrScheme."))) - (define listing - (new list-box% - (parent main) - (label "Installed tools") - (choices null) - (callback (lambda _ (on-select-tool))))) - (define info - (new vertical-panel% - (parent main) - (style '(border)) - (stretchable-height #f))) - (define location - (new text-field% - (parent info) - (label "Tool: "))) - (define location-editor (send location get-editor)) - (define configuration - (new radio-box% - (label "Load the tool when DrScheme starts?") - (parent info) - (choices (list load-action skip-action #| default-action |#)) - (callback (lambda _ (on-select-policy))))) - - (define (populate-listing!) - (send listing clear) - (for-each - (lambda (entry+it) - (send listing append - (car entry+it) - (cdr entry+it))) - (sort (map (lambda (it) (cons (tool-list-entry it) it)) - installed-tools) - (lambda (a b) - (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 deleted file mode 100644 index e1d6de5dc8..0000000000 --- a/collects/drscheme/private/ts.ss +++ /dev/null @@ -1,12 +0,0 @@ -#reader scribble/reader -#lang scheme/base - -(require scribble/decode - scribble/manual) - -(define (phase n) - (make-splice - @list{This function can only be called in - phase @(number->string n) (see @secref["implementing-tools"] for details).})) - -(provide phase) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss deleted file mode 100644 index c6877ac9e3..0000000000 --- a/collects/drscheme/private/unit.ss +++ /dev/null @@ -1,3821 +0,0 @@ - -#| - -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 deleted file mode 100644 index 8e51b17be7..0000000000 --- a/collects/drscheme/syncheck.ss +++ /dev/null @@ -1,2738 +0,0 @@ -#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 deleted file mode 100644 index e5e1ee978a..0000000000 --- a/collects/drscheme/tool-lib.ss +++ /dev/null @@ -1,1383 +0,0 @@ -#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 deleted file mode 100644 index 7fd1b8188c..0000000000 --- a/collects/drscheme/tool.ss +++ /dev/null @@ -1,4 +0,0 @@ -(module tool mzscheme - (require "private/drsig.ss") - (provide drscheme:tool^ - drscheme:tool-exports^))