added a test that saves and reopens a file in the teaching languages
svn: r18088
This commit is contained in:
Robby Findler
parent
89da613073
commit
b73613460b
|
|
@ -312,44 +312,6 @@
|
|||
;; set language level in the frontmost DrScheme frame (resets settings to defaults)
|
||||
;; If `close-dialog?' it #t,
|
||||
(define set-language-level!
|
||||
(lambda (in-language-spec [close-dialog? #t])
|
||||
(unless (and (pair? in-language-spec)
|
||||
(list? in-language-spec)
|
||||
(andmap (lambda (x) (or string? regexp?)) in-language-spec))
|
||||
(error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec))
|
||||
(let ([drs-frame (get-top-level-focus-window)])
|
||||
(fw:test:menu-select "Language" "Choose Language...")
|
||||
(let* ([language-dialog (wait-for-new-frame drs-frame)]
|
||||
[language-choice (find-labelled-window #f hierarchical-list%)]
|
||||
[b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[click-on-snip
|
||||
(lambda (snip)
|
||||
(let* ([editor (send (send snip get-admin) get-editor)]
|
||||
[between-threshold (send editor get-between-threshold)])
|
||||
(send editor get-snip-location snip b1 b2)
|
||||
(let-values ([(gx gy) (send editor editor-location-to-dc-location
|
||||
(unbox b1)
|
||||
(unbox b2))])
|
||||
(let ([x (inexact->exact (+ gx between-threshold 1))]
|
||||
[y (inexact->exact (+ gy between-threshold 1))])
|
||||
(fw:test:mouse-click 'left x y)))))])
|
||||
(send language-choice focus)
|
||||
(let loop ([list-item language-choice]
|
||||
[language-spec in-language-spec])
|
||||
(let* ([name (car language-spec)]
|
||||
[which (filter (lambda (child)
|
||||
(let* ([text (send (send child get-editor) get-text)]
|
||||
[matches
|
||||
(or (and (regexp? name)
|
||||
(regexp-match name text))
|
||||
(and (string? name)
|
||||
(string=? name text)))])
|
||||
(and matches
|
||||
child)))
|
||||
(send list-item get-items))])
|
||||
(when (null? which)
|
||||
(error '(define set-language-level!
|
||||
(lambda (in-language-spec [close-dialog? #t])
|
||||
(unless (and (pair? in-language-spec)
|
||||
(list? in-language-spec)
|
||||
|
|
@ -392,38 +354,6 @@
|
|||
(unless (= 1 (length which))
|
||||
(error 'set-language-level! "couldn't find language: ~e, double match ~e"
|
||||
in-language-spec name))
|
||||
(let ([next-item (car which)])
|
||||
(cond
|
||||
[(null? (rest language-spec))
|
||||
(when (is-a? next-item hierarchical-list-compound-item<%>)
|
||||
(error 'set-language-level! "expected no more languages after ~e, but still are, input ~e"
|
||||
name in-language-spec))
|
||||
(click-on-snip (send next-item get-clickable-snip))]
|
||||
[else
|
||||
(unless (is-a? next-item hierarchical-list-compound-item<%>)
|
||||
(error 'set-language-level! "expected more languages after ~e, but got to end, input ~e"
|
||||
name in-language-spec))
|
||||
(unless (send next-item is-open?)
|
||||
(click-on-snip (send next-item get-arrow-snip)))
|
||||
(loop next-item (cdr language-spec))]))))
|
||||
|
||||
(with-handlers ([exn:fail? (lambda (x) (void))])
|
||||
(fw:test:button-push "Show Details"))
|
||||
|
||||
(fw:test:button-push "Revert to Language Defaults")
|
||||
|
||||
(when close-dialog?
|
||||
(fw:test:button-push "OK")
|
||||
(let ([new-frame (wait-for-new-frame language-dialog)])
|
||||
(unless (eq? new-frame drs-frame)
|
||||
(error 'set-language-level!
|
||||
"didn't get drscheme frame back, got: ~s (drs-frame ~s)\n"
|
||||
new-frame
|
||||
drs-frame)))))))) "couldn't find language: ~e, no match at ~e"
|
||||
in-language-spec name))
|
||||
(unless (= 1 (length which))
|
||||
(error 'set-language-level! "couldn't find language: ~e, double match ~e"
|
||||
in-language-spec name))
|
||||
(let ([next-item (car which)])
|
||||
(cond
|
||||
[(null? (cdr language-spec))
|
||||
|
|
|
|||
|
|
@ -4,4 +4,5 @@ mred repl-test.ss &&
|
|||
mred io.ss &&
|
||||
mred language-test.ss &&
|
||||
mred syncheck-test.ss &&
|
||||
mred teachpack.ss
|
||||
mred teachpack.ss &&
|
||||
mred save-teaching-lang-file.ss
|
||||
|
|
|
|||
45
collects/tests/drscheme/save-teaching-lang-file.ss
Normal file
45
collects/tests/drscheme/save-teaching-lang-file.ss
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
#lang scheme/base
|
||||
(require scheme/file
|
||||
scheme/class
|
||||
scheme/port
|
||||
framework/test
|
||||
framework/preferences)
|
||||
|
||||
(require tests/drscheme/drscheme-test-util)
|
||||
|
||||
(fire-up-drscheme-and-run-tests
|
||||
(λ ()
|
||||
(let* ([drs-frame (wait-for-drscheme-frame)]
|
||||
[fn (make-temporary-file "save-teaching-lang-test~a")])
|
||||
(test:menu-select "File" "New Tab")
|
||||
|
||||
(let ([definitions-text (send drs-frame get-definitions-text)]
|
||||
[interactions-text (send drs-frame get-interactions-text)])
|
||||
|
||||
(set-language-level! (list #rx"How to Design Programs" #rx"Beginning Student$"))
|
||||
(clear-definitions drs-frame)
|
||||
(send definitions-text set-filename fn)
|
||||
(send definitions-text insert "(define (f x) x)\n(f 1)\n")
|
||||
(test:menu-select "File" "Save Definitions")
|
||||
(unless (call-with-input-file fn
|
||||
(λ (p) (regexp-match #rx";;[^\n]*metadata" p)))
|
||||
|
||||
(fprintf (current-error-port) "---- saved file, cut here ----\n")
|
||||
(call-with-input-file fn (λ (p) (copy-port p (current-error-port))))
|
||||
(fprintf (current-error-port) "---- saved file, cut here ----\n")
|
||||
(error 'save-teaching-lang-file.ss "expected the saved file to contain the word 'metadata' in a comment"))
|
||||
(do-execute drs-frame)
|
||||
(test:menu-select "File" "Close Tab")
|
||||
(use-get/put-dialog
|
||||
(λ ()
|
||||
(test:menu-select "File" "Open..."))
|
||||
fn)
|
||||
(do-execute drs-frame)
|
||||
(let ([result (fetch-output
|
||||
drs-frame
|
||||
(send interactions-text paragraph-start-position 2)
|
||||
(send interactions-text last-position))])
|
||||
(test:menu-select "File" "Close Tab")
|
||||
(delete-file fn)
|
||||
(unless (equal? result "1\n> ")
|
||||
(error 'save-teaching-lang-file.ss "expected the program to produce 1 (followed by the prompt), got ~s" result)))))))
|
||||
Loading…
Reference in New Issue
Block a user