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

merge in trunk to 11458

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-08-27 15:22:23 -04:00
parent 8489d5cfb9
commit f0e5a33f46
30 changed files with 370 additions and 296 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/acks.ss
View File

@ -35,12 +35,14 @@
"Dave Gurnell, "
"Bruce Hauman, "
"Dave Herman, "
"Geoffrey S. Knauth, "
"Mark Krentel, "
"Shriram Krishnamurthi, "
"Mario Latendresse, "
"Guillaume Marceau, "
"Jacob Matthews, "
"Jay McCarthy, "
"Mike T. McHenry, "
"Philippe Meunier, "
"Scott Owens, "
"Jamie Raymond, "

8
collects/drscheme/drscheme.ss
View File

@ -18,8 +18,8 @@
[use-compiled-file-paths '()])
(values
(dynamic-require 'errortrace/zo-compile 'zo-compile)
(dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'mzlib/cm 'manager-trace-handler)))])
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/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))
@ -36,8 +36,8 @@
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)))])
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when cm-trace?
(printf "PLTDRCM: enabling CM tracing\n")

8
collects/drscheme/info.ss
View File

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

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

@ -1,4 +1,4 @@
(module auto-language mzscheme
#lang mzscheme
(require mred
mzlib/class)
@ -59,4 +59,4 @@
;; If tp contains a snip, read-line fails.
(read-line tp))])
(and (string? l1)
(regexp-match #rx"#lang .*$" l1)))))
(regexp-match #rx"#lang .*$" l1))))

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

@ -1,3 +1,4 @@
#lang mzscheme
#|
CODE COPIED (with permission ...) from syntax-browser.ss
@ -7,7 +8,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
|#
(module bindings-browser mzscheme
(require mzlib/pretty
mzlib/list
mzlib/class
@ -288,7 +289,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
(send text last-position)
(send text last-position))
(- end start))
void)))
void))
; one trivial test case:
;

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

@ -1,3 +1,5 @@
#lang scheme/base
#|
profile todo:
@ -6,8 +8,6 @@ profile todo:
|#
#lang scheme/base
(require scheme/unit
errortrace/stacktrace
scheme/class

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

@ -1,5 +1,5 @@
#lang mzscheme
(module drscheme-normal mzscheme
(require mred
mzlib/class
mzlib/cmdline
@ -271,4 +271,4 @@
(parent f))])
(send f show #t)))))
(dynamic-require 'drscheme/tool-lib #f))
(dynamic-require 'drscheme/tool-lib #f)

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

@ -1,5 +1,4 @@
(module drsig scheme/base
#lang scheme/base
(require scheme/unit)
(provide drscheme:eval^
@ -313,5 +312,4 @@
(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^)))))
(open (prefix drscheme:modes: drscheme:modes^))))

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

@ -1,5 +1,5 @@
#lang mzscheme
(module eval mzscheme
(require mred
mzlib/unit
mzlib/port
@ -218,4 +218,4 @@
[else
(let ([port (open-input-file filename)])
(port-count-lines! port)
(values port filename))])))))
(values port filename))]))))

184
collects/drscheme/private/first-line-text.ss
View File

@ -1,29 +1,104 @@
#lang scheme/base
(require scheme/gui/base
scheme/class)
scheme/class
framework)
(provide first-line-text-mixin)
(provide first-line-text-mixin
first-line-text-mixin<%>)
(define (first-line-text-mixin text%)
(class text%
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location)
(define first-line-text-mixin<%>
(interface ()
highlight-first-line))
(define dark-color (make-object color% 50 0 50))
(define dark-wob-color (make-object color% 220 150 220))
(define first-line-text-mixin
(mixin ((class->interface text%)) (first-line-text-mixin<%>)
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location
scroll-to local-to-global get-dc)
(define bx (box 0))
(define by (box 0))
(define bw (box 0))
(define fancy-first-line? #t)
(define/override (scroll-to snip localx localy width height refresh? [bias 'none])
(printf "~s\n" (list 'scroll-to snip localx localy width height refresh? bias))
(super scroll-to snip localx localy width height refresh? bias))
(define fancy-first-line? #f)
(define first-line "")
(define end-of-first-line 0)
(define first-line-is-lang? #f)
(define/private (show-first-line?)
(and fancy-first-line? first-line-is-lang?))
(define/private (update-first-line)
(set! end-of-first-line (paragraph-end-position 0))
(set! first-line (get-text 0 end-of-first-line))
(set! first-line-is-lang? (is-lang-line? first-line)))
(define/augment (after-insert start len)
(when (<= start end-of-first-line)
(update-first-line))
(inner (void) after-insert start len))
(define/augment (after-delete start len)
(when (<= start end-of-first-line)
(update-first-line))
(inner (void) after-delete start len))
(define/private (fetch-first-line-height)
(let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))])
h))
(define/override (scroll-editor-to localx localy width height refresh? bias)
(let ([admin (get-admin)])
(cond
[(not admin)
#f]
[(show-first-line?)
(let ([h (fetch-first-line-height)])
(set-box! by localy)
(local-to-global #f by)
(cond
[(<= (unbox by) h)
;; the max is relevant when we're already scrolled to the top.
(send admin scroll-to localx (max 0 (- localy h)) width height refresh? bias)]
[else
(send admin scroll-to localx localy width height refresh? bias)]))]
[else
(send admin scroll-to localx localy width height refresh? bias)])))
(define/public (highlight-first-line on?)
(set! fancy-first-line? on?)
(invalidate-bitmap-cache)
(send (send this get-canvas) refresh))
(unless (equal? fancy-first-line? on?)
(set! fancy-first-line? on?)
(invalidate-bitmap-cache)
(let ([canvas (send this get-canvas)])
(when canvas
(send canvas refresh)))))
(define/override (on-event event)
(cond
[(or (send event moving?)
(send event leaving?)
(send event entering?))
(super on-event event)]
[else
(let ([y (send event get-y)]
[h (fetch-first-line-height)]
[admin (get-admin)])
(unless admin (send admin get-view #f by #f #f #f))
(cond
[(and admin
(< y h)
(not (= (unbox by) 0)))
(send admin scroll-to (send event get-x) 0 0 0 #t)
(super on-event event)]
[else
(super on-event event)]))]))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
(when fancy-first-line?
(when (show-first-line?)
(let ([admin (get-admin)])
(when admin
(send admin get-view bx by bw #f #f)
@ -33,7 +108,8 @@
[old-brush (send dc get-brush)]
[old-smoothing (send dc get-smoothing)]
[old-α (send dc get-alpha)]
[old-font (send dc get-font)])
[old-font (send dc get-font)]
[old-text-foreground (send dc get-text-foreground)])
(send dc set-font (get-font))
(send dc set-smoothing 'aligned)
(let-values ([(tw th _1 _2) (send dc get-text-extent first-line)])
@ -41,32 +117,49 @@
[line-left (+ (unbox bx) dx)]
[line-right (+ (unbox bx) dx (unbox bw))])
(send dc set-pen "black" 1 'solid)
(if (preferences:get 'framework:white-on-black?)
(send dc set-pen "white" 1 'solid)
(send dc set-pen "black" 1 'solid))
(send dc draw-line line-left line-height line-right line-height)
(when (eq? (send dc get-smoothing) 'aligned)
(send dc set-pen "black" 1 'solid)
(let loop ([i 10])
(let ([start 3/10]
[end 0]
[steps 10])
(send dc set-pen
(if (preferences:get 'framework:white-on-black?)
dark-wob-color
dark-color)
1
'solid)
(let loop ([i steps])
(unless (zero? i)
(let ([g (+ 200 (* i 5))])
(send dc set-alpha (+ 1/5 (* i -1/50)))
(let ([alpha-value (+ start (* (- end start) (/ i steps)))])
(send dc set-alpha alpha-value)
(send dc draw-line
line-left
(+ line-height i)
line-right
(+ line-height i)))
(loop (- i 1))))))
(+ line-height i))
(loop (- i 1))))))))
(send dc set-alpha 1)
(send dc set-pen "gray" 1 'transparent)
(send dc set-brush "white" 'solid)
(if (preferences:get 'framework:white-on-black?)
(send dc set-brush "black" 'solid)
(send dc set-brush "white" 'solid))
(send dc draw-rectangle
(+ (unbox bx) dx)
(+ (unbox by) dy)
(unbox bw)
th)
(send dc set-text-foreground
(if (preferences:get 'framework:white-on-black?)
(send the-color-database find-color "white")
(send the-color-database find-color "black")))
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy)))
(send dc set-text-foreground old-text-foreground)
(send dc set-font old-font)
(send dc set-pen old-pen)
(send dc set-brush old-brush)
@ -83,11 +176,54 @@
(super-new)))
;; is-lang-line? : string -> boolean
;; given the first line in the editor, this returns #t if it is a #lang line.
(define (is-lang-line? l)
(let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)])
(and m
(let ([lang-name (list-ref m 3)]
[last-char (list-ref m 4)])
(and (not (char=? #\/ (string-ref lang-name 0)))
(not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1))))
(or (string=? "" last-char)
(char-whitespace? (string-ref last-char 0))))))))
;; test cases for is-lang-line?
#;
(list (is-lang-line? "#lang x")
(is-lang-line? "#lang scheme")
(is-lang-line? "#lang scheme ")
(not (is-lang-line? "#lang schemeα"))
(not (is-lang-line? "#lang scheme/ "))
(not (is-lang-line? "#lang /scheme "))
(is-lang-line? "#lang sch/eme ")
(is-lang-line? "#lang r6rs")
(is-lang-line? "#!r6rs")
(is-lang-line? "#!r6rs ")
(not (is-lang-line? "#!/bin/sh")))
#;
(begin
(define f (new frame% [label ""] [width 200] [height 200]))
(define t (new (first-line-text-mixin text%)))
;(define t (new (editor:standard-style-list-mixin (first-line-text-mixin text%))))
(define t
(new
(scheme:text-mixin
(text:autocomplete-mixin
(color:text-mixin
(mode:host-text-mixin
(values ; text:delegate-mixin
(text:foreground-color-mixin
(first-line-text-mixin
text:info%)))))))))
(require scheme/runtime-path)
(define-runtime-path here ".")
(send t load-file (build-path (build-path here 'up 'up "framework" "private" "text.ss")))
#;
(send t insert (apply string-append (map (λ (x) (build-string 100 (λ (i) (if (= i 99) #\newline x))))
(string->list "abcdefghijklnopqrstuvwxyz"))))
(define c (new editor-canvas% [parent f] [editor t]))
(define b (new button% [callback (λ (c dc) (send t highlight-first-line #t))] [label "button"] [parent f]))
(define b (new button% [callback (λ (c dc) (send t highlight-first-line #t))] [label "on"] [parent f]))
(define b2 (new button% [callback (λ (c dc) (send t highlight-first-line #f))] [label "off"] [parent f]))
(send c focus)
(send f show #t))

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

@ -1,4 +1,4 @@
(module font mzscheme
#lang mzscheme
(require mzlib/unit
mzlib/class
"drsig.ss"
@ -215,4 +215,4 @@
(send options-panel stretchable-height #f)
(send options-panel set-alignment 'center 'top)
(send text lock #t)
main))))))
main)))))

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

@ -1,4 +1,3 @@
#lang scheme/unit
(require string-constants
mzlib/match
@ -376,11 +375,21 @@
(cond
[cancel? (void)]
[(from-web?)
(install-plt-from-url (send url-text-field get-value) parent)]
(install-plt-from-url (trim-whitespace (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))))]))
;; trim-whitespace: string -> string
;; Trims the whitespace surrounding a string.
(define (trim-whitespace a-str)
(cond
[(regexp-match #px"^\\s*(.*[^\\s])\\s*$"
a-str)
=> second]
[else
a-str]))
;; 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)

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

@ -1,4 +1,3 @@
#lang scheme/unit
(require string-constants
"drsig.ss"

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

@ -1,4 +1,4 @@
(module key mzscheme
#lang mzscheme
(provide break-threads)
(define super-cust (current-custodian))
(define first-child (make-custodian))
@ -16,4 +16,4 @@
(break-thread man))
(when (custodian? man)
(loop current-cust man)))
(custodian-managed-list current-cust super-cust))))))))
(custodian-managed-list current-cust super-cust)))))))

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

@ -1,4 +1,4 @@
(module label-frame-mred mzscheme
#lang mzscheme
(require mred
mzlib/class)
(provide (all-from-except mred frame%)
@ -25,4 +25,4 @@
(super-instantiate ())
(semaphore-wait label-sema)
(hash-table-put! label-ht this (get-label))
(semaphore-post label-sema))))
(semaphore-post label-sema)))

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

@ -1,5 +1,4 @@
(module language-configuration mzscheme
#lang mzscheme
(require mzlib/unit
mrlib/hierlist
mzlib/class
@ -1786,4 +1785,4 @@
(define (find-parent-from-snip snip)
(let* ([admin (send snip get-admin)]
[ed (send admin get-editor)])
(find-parent-from-editor ed)))))
(find-parent-from-editor ed))))

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

@ -1,9 +1,9 @@
#lang scheme/unit
;; 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
@ -42,6 +42,7 @@
default-settings?
front-end/complete-program
front-end/finished-complete-program
front-end/interaction
config-panel
on-execute
@ -480,6 +481,9 @@
(inherit get-module get-transformer-module use-namespace-require/copy-from-setting?
get-init-code use-mred-launcher get-reader)
(define/public (front-end/finished-complete-program settings) (void))
(define/public (module-based-language->language-mixin settings) (void))
(define/pubment (capability-value s)
(inner (get-capability-default s) capability-value s))

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

@ -1,4 +1,4 @@
(module link mzscheme
#lang mzscheme
(require "modes.ss"
"font.ss"
"eval.ss"
@ -51,5 +51,5 @@
(prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:eval: drscheme:eval^)
(prefix drscheme:modes: drscheme:modes^))
drscheme-unit@)))
drscheme-unit@))

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

@ -136,55 +136,27 @@
(define/public (get-auto-text settings)
(module-language-settings-auto-text settings))
;; utility for the front-end methods: return a function that will return
;; utility for the front-end method: return a function that will return
;; each of the given syntax values on each call, executing thunks when
;; included; when done with the list, use the given getter thunk.
(define (expr-getter getter . exprs/thunks)
;; included; when done with the list, send eof.
(define (expr-getter . exprs/thunks)
(define (loop)
(if (null? exprs/thunks)
(getter)
eof
(let ([x (car exprs/thunks)])
(set! exprs/thunks (cdr exprs/thunks))
(if (procedure? x) (begin (x) (loop)) x))))
loop)
(inherit get-reader)
(define hopeless-repl (make-thread-cell #t))
(define repl-init-thunk (make-thread-cell #f))
(define/override (front-end/interaction port settings)
(let ([x (thread-cell-ref hopeless-repl)])
(cond
[(not x) (super front-end/interaction port settings)]
[(not (syntax? x)) (raise-hopeless-syntax-error)]
;; this means that there was a problem getting into the
;; module's namespace, and we have a language to try to require
[else
(let ([default-handler (uncaught-exception-handler)])
(expr-getter (super front-end/interaction port settings)
#`(current-module-declare-name #f)
(λ ()
(uncaught-exception-handler
(λ (e)
(uncaught-exception-handler default-handler)
(raise-hopeless-syntax-error "invalid language" x))))
#`(require #,x)
(λ ()
(uncaught-exception-handler default-handler)
(unless (memq '#%top-interaction (namespace-mapped-symbols))
(raise-hopeless-syntax-error
"invalid language (existing module, but no language bindings)"
x)))))])))
;; This is used to setup the user environment. There's a subtle hack
;; here: instead of doing things like (namespace-require ...), construct
;; and return a #'(require ...) syntax: this way when we're not going to
;; run the code (eg, when it's used by the syntax checker or the macro
;; debugger), it won't run.
(define/override (front-end/complete-program port settings)
(define (super-thunk) ((get-reader) (object-name port) port))
(define path (cond [(get-filename port)
=> (compose simplify-path cleanse-path)]
[else #f]))
(define path
(cond [(get-filename port) => (compose simplify-path cleanse-path)]
[else #f]))
(define resolved-modpath (and path (make-resolved-module-path path)))
(define-values (name lang module-expr)
(let ([expr
;; just reading the definitions might be a syntax error,
@ -199,31 +171,50 @@
"there can only be one expression in the definitions window"
more)))
(transform-module path expr)))
(define require-spec
(or path
;; "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)
(quasisyntax ''#,(datum->syntax #'here (syntax-e name)))))
;; we have a language, so put it here, so front-end/interaction can
;; require the language if we fail to go into the module -- most
;; commonly due to a syntax error, in attempt to still provide a
;; working repl
(thread-cell-set! hopeless-repl lang)
(expr-getter (λ () eof)
#`(current-module-declare-name
(and #,path (make-resolved-module-path '#,path)))
module-expr
#`(current-module-declare-name #f)
(if path
#`(#%app (#%app current-module-name-resolver)
(#%app make-resolved-module-path #,path))
void)
;; the prompt makes it continue after an error
#`(#%app call-with-continuation-prompt
(λ () (#%app dynamic-require #,require-spec #f)))
#`(#%app current-namespace (#%app module->namespace #,require-spec))
(λ () (thread-cell-set! hopeless-repl #f))))
(define modspec (or path `',(syntax-e name)))
(define (check-interactive-language)
(unless (memq '#%top-interaction (namespace-mapped-symbols))
(raise-hopeless-exception
#f #f ; no error message, just a suffix
(format "~s does not support a REPL (no #%top-interaction)"
(syntax->datum lang)))))
;; We're about to send the module expression to drscheme now, the rest
;; of the setup is done in `front-end/finished-complete-program' below,
;; so use `repl-init-thunk' to store an appropriate continuation for
;; this setup. Once we send the expression, we'll be called again only
;; if it was evaluated (or expanded) with no errors, so begin with a
;; continuation that deals with an error, and if we're called again,
;; change it to a continuation that initializes the repl for the
;; module. So the code is split among several thunks that follow.
(define (*pre)
(thread-cell-set! repl-init-thunk *error)
(current-module-declare-name resolved-modpath))
(define (*post)
(current-module-declare-name #f)
(when path ((current-module-name-resolver) resolved-modpath))
(thread-cell-set! repl-init-thunk *init))
(define (*error)
(current-module-declare-name #f)
;; syntax error => try to require the language to get a working repl
(with-handlers ([void (λ (e)
(raise-hopeless-syntax-error
"invalid language specification"
lang))])
(namespace-require lang))
(check-interactive-language))
(define (*init)
(parameterize ([current-namespace (current-namespace)])
;; the prompt makes it continue after an error
(call-with-continuation-prompt
(λ () (dynamic-require modspec #f))))
(current-namespace (module->namespace modspec))
(check-interactive-language))
;; here's where they're all combined with the module expression
(expr-getter *pre module-expr *post))
(define/override (front-end/finished-complete-program settings)
(cond [(thread-cell-ref repl-init-thunk)
=> (λ (t) (thread-cell-set! repl-init-thunk #f) (t))]))
;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename)
@ -272,23 +263,31 @@
[language-position (list "Module")]
[language-numbers (list -32768)])))
(define (raise-hopeless-exception exn [prefix #f])
;; can be called with #f to just kill the repl (in case we want to kill it
;; but keep the highlighting of a previous error)
(define (raise-hopeless-exception exn [prefix #f] [suffix #f])
(define rep (drscheme:rep:current-rep))
;; if we don't have the drscheme rep, then we just raise the exception as
;; normal. (It can happen in some rare cases like having a single empty
;; scheme box in the definitions.)
(unless rep (raise exn))
;; Throw an error as usual if we don't have the drscheme rep, then we just
;; raise the exception as normal. (It can happen in some rare cases like
;; having a single empty scheme box in the definitions.)
(unless rep (if exn (raise exn) (error "\nInteractions disabled")))
(when prefix (fprintf (current-error-port) "Module Language: ~a\n" prefix))
((error-display-handler) (exn-message exn) exn)
(when exn ((error-display-handler) (exn-message exn) exn))
;; these are needed, otherwise the warning can appear before the output
(flush-output (current-output-port))
(flush-output (current-error-port))
;; do the rep-related work carefully -- using drscheme's eventspace, and
;; wait for it to finish before we continue.
(let ([s (make-semaphore 0)])
(let ([s (make-semaphore 0)]
[msg (string-append "\nInteractions disabled"
(if suffix (string-append ": " suffix) "."))])
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback
(λ ()
(send* rep (insert-warning "\nInteractions disabled.")
(set-show-no-user-evaluation-message? #f)
(highlight-errors/exn exn))
(send rep call-without-reset-highlighting
(λ ()
(send* rep (insert-warning msg)
(set-show-no-user-evaluation-message? #f))))
(semaphore-post s))))
(semaphore-wait s))
(custodian-shutdown-all (send rep get-user-custodian)))
@ -476,7 +475,7 @@
(update-buttons)]))
;; transform-module : (union #f path) syntax
;; -> (values syntax[name-of-module] syntax[module])
;; -> (values syntax[name-of-module] syntax[lang-of-module] syntax[module])
;; = User =
(define (transform-module filename stx)
(define-values (mod name lang body)
@ -567,7 +566,7 @@
[filename-end (skip-to-whitespace filename-start)])
(and (not (= filename-start end-module))
(string-append (get-text filename-start filename-end)
".scm")))))))
".ss")))))))
(define/private (matches start string)

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

@ -1,4 +1,3 @@
#lang scheme/unit
(require framework
mzlib/class

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

@ -1,4 +1,4 @@
(module number-snip mzscheme
#lang mzscheme
(require mred
mzlib/class
framework)
@ -6,4 +6,4 @@
(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))
(send (get-the-snip-class-list) add snip-class)

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

@ -665,7 +665,7 @@ TODO
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(port-name-matches? (srcloc-source srcloc))
(hash-set! ht (srcloc-source srcloc) definitions-text)
(hash-set! ht (srcloc-source srcloc) this)
(make-srcloc this
(srcloc-line srcloc)
(srcloc-column srcloc)
@ -733,8 +733,12 @@ TODO
(when first-loc
(send first-file set-caret-owner (get-focus-snip) 'global)))))
(define highlights-can-be-reset (make-parameter #t))
(define/public (reset-highlighting)
(reset-error-ranges))
(when (highlights-can-be-reset) (reset-error-ranges)))
(define/public (call-without-reset-highlighting thunk)
(parameterize ([highlights-can-be-reset #f])
(thunk)))
;; remove-duplicate-error-arrows : (listof X) -> (listof X)
;; duplicate arrows point from and to the same place -- only
@ -1099,6 +1103,16 @@ TODO
(default-continuation-prompt-tag)
(λ args (void)))
(when complete-program?
(call-with-continuation-prompt
(λ ()
(call-with-break-parameterization
user-break-parameterization
(λ ()
(send lang front-end/finished-complete-program settings))))
(default-continuation-prompt-tag)
(λ args (void))))
(set! in-evaluation? #f)
(update-running #f)
(cleanup)

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

@ -1,4 +1,4 @@
(module stick-figures mzscheme
#lang mzscheme
(require mzlib/class
mzlib/pretty
mred)
@ -338,4 +338,4 @@
(send f show #t))
#;(edit-points waiting-points/2)
#;(edit-points running-points))
#;(edit-points running-points)

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

@ -1,4 +1,5 @@
(module syncheck-debug mzscheme
#lang mzscheme
(require mzlib/pretty
mzlib/list
mzlib/class
@ -161,4 +162,4 @@
(send text last-position)
(send text last-position))
(loop))))))
out)))
out))

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

@ -1,4 +1,3 @@
#lang scheme/unit
(require mzlib/class
"drsig.ss"

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

@ -1,86 +0,0 @@
(module time-keystrokes mzscheme
(require drscheme/tool
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)))))

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

@ -1,4 +1,5 @@
(module tool-contract-language mzscheme
#lang mzscheme
(provide (rename -#%module-begin #%module-begin)
(all-from-except mzscheme #%module-begin))
@ -132,4 +133,4 @@
(λ (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 ...) ...)))))))])))
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))

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

@ -1,4 +1,3 @@
#lang scheme/unit
(require setup/getinfo

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

@ -1,4 +1,4 @@
#lang scheme/base
#|
closing:
@ -11,7 +11,6 @@ module browser threading seems wrong.
|#
(module unit scheme/base
(require scheme/contract
scheme/unit
scheme/class
@ -27,6 +26,7 @@ module browser threading seems wrong.
"drsig.ss"
"auto-language.ss"
"insert-large-letters.ss"
"first-line-text.ss"
mrlib/switchable-button
mrlib/cache-image-snip
@ -202,7 +202,7 @@ module browser threading seems wrong.
(define (find-symbol text pos)
(send text split-snip pos)
(send text split-snip (+ pos 1))
(let ([snip (send text find-snip pos 'after-or-none)])
(let ([snip (send text find-snip pos 'after)])
(if (is-a? snip string-snip%)
(let* ([before
(let loop ([i (- pos 1)]
@ -428,18 +428,19 @@ module browser threading seems wrong.
(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%)))))))))])
(first-line-text-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 while-unlocked)
(inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line)
(define interactions-text #f)
(define/public (set-interactions-text it)
@ -588,40 +589,42 @@ module browser threading seems wrong.
(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))
(remove-auto-text)
(insert-auto-text)
(after-set-next-settings _next-settings)))
(define/pubment (set-next-settings _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)))
(highlight-first-line
(is-a? (drscheme:language-configuration:language-settings-language _next-settings)
drscheme:module-language:module-language<%>))
(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))
(remove-auto-text)
(insert-auto-text)
(after-set-next-settings _next-settings))
(define/pubment (after-set-next-settings s)
(inner (void) after-set-next-settings s))
@ -729,7 +732,7 @@ module browser threading seems wrong.
(/ (+ yl yr) 2)))))
(define/public (still-untouched?)
(and (= (last-position) 0)
(and (or (= (last-position) 0) (not really-modified?))
(not (is-modified?))
(not (get-filename))))
;; inserts the auto-text if any, and executes the text if so
@ -780,7 +783,9 @@ module browser threading seems wrong.
;; insert the default-text
(queue-callback (lambda () (insert-auto-text)))
(highlight-first-line
(is-a? (drscheme:language-configuration:language-settings-language next-settings)
drscheme:module-language:module-language<%>))
(inherit set-max-undo-history)
(set-max-undo-history 'forever))))
@ -3063,15 +3068,7 @@ module browser threading seems wrong.
(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)))
"<<unknown caller>>"))
insert-menu)
(define/public (get-special-menu) insert-menu)
(define/public (choose-language-callback)
(let ([new-settings (drscheme:language-configuration:language-dialog
@ -3959,4 +3956,4 @@ module browser threading seems wrong.
(send frame update-toolbar-visibility)
(send frame show #t)
(set! first-frame? #f)
frame))))
frame)))

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

@ -140,8 +140,11 @@ all of the names in the tools library, for use defining keybindings
@scheme[#t].
This function calls
@scheme[drscheme:language:language front-end/complete-program<%>]
to expand the program.
@method[drscheme:language:language<%> front-end/complete-program]
to expand the program. Unlike when the @onscreen{Run} is clicked,
however, it does not call
@method[drscheme:language:language<%> front-end/finished-complete-program].
The first argument to @scheme[iter] is the expanded program
(represented as syntax) or eof.